section\<open>Cofinality\label{sec:cofinality}\<close>

theory Cofinality
  imports
    ZF_Library
begin

subsection\<open>Basic results and definitions\<close>

text\<open>A set \<^term>\<open>X\<close> is \<^emph>\<open>cofinal\<close> in \<^term>\<open>A\<close> (with respect to the relation
    \<^term>\<open>r\<close>) if every element of \<^term>\<open>A\<close> is ``bounded
    above'' by some element of \<^term>\<open>X\<close>. Note that \<^term>\<open>X\<close> does not need
    to be a subset of \<^term>\<open>A\<close>.\<close>
definition
  cofinal :: "[i,i,i] \<Rightarrow> o" where
  "cofinal(X,A,r) \<equiv> \<forall>a\<in>A. \<exists>x\<in>X. \<langle>a,x\<rangle>\<in>r \<or> a = x"

(*
(* Alternative definitions *)
definition
  cofinal_predic :: "[i,i,[i,i]\<Rightarrow>o] \<Rightarrow> o" where
  "cofinal_predic(X,A,r) \<equiv> \<forall>a\<in>A. \<exists>x\<in>X. r(a,x) \<or> a = x"

definition
  f_cofinal :: "[i\<Rightarrow>i,i,i,i] \<Rightarrow> o" where
  "f_cofinal(f,C,A,r) \<equiv> \<forall>a\<in>A. \<exists>x\<in>C. \<langle>a,f(x)\<rangle>\<in>r \<or> a = f(x)"

(* The next definition doesn't work if 0 is the top element of A.
   But it works for limit ordinals. *)
definition
  cofinal_fun' :: "[i,i,i] \<Rightarrow> o" where
  "cofinal_fun'(f,A,r) == f_cofinal(\<lambda>x. f`x,domain(f),A, r)"
*)

text\<open>A function is cofinal if it range is.\<close>
definition
  cofinal_fun :: "[i,i,i] \<Rightarrow> o" where
  "cofinal_fun(f,A,r) \<equiv> \<forall>a\<in>A. \<exists>x\<in>domain(f). \<langle>a,f`x\<rangle>\<in>r \<or> a = f`x"

lemma cofinal_funI:
  assumes "\<And>a. a\<in>A \<Longrightarrow> \<exists>x\<in>domain(f). \<langle>a,f`x\<rangle>\<in>r \<or> a = f`x"
  shows "cofinal_fun(f,A,r)"
  using assms unfolding cofinal_fun_def by simp

lemma cofinal_funD:
  assumes "cofinal_fun(f,A,r)" "a\<in>A"
  shows "\<exists>x\<in>domain(f). \<langle>a,f`x\<rangle>\<in>r \<or> a = f`x"
  using assms unfolding cofinal_fun_def by simp

lemma cofinal_in_cofinal:
  assumes
    "trans(r)" "cofinal(Y,X,r)" "cofinal(X,A,r)"
  shows
    "cofinal(Y,A,r)"
  unfolding cofinal_def
proof
  fix a
  assume "a\<in>A"
  moreover from \<open>cofinal(X,A,r)\<close>
  have "b\<in>A\<Longrightarrow>\<exists>x\<in>X. \<langle>b,x\<rangle>\<in>r \<or> b=x" for b
    unfolding cofinal_def by simp
  ultimately
  obtain y where "y\<in>X" "\<langle>a,y\<rangle>\<in>r \<or> a=y" by auto
  moreover from \<open>cofinal(Y,X,r)\<close>
  have "c\<in>X\<Longrightarrow>\<exists>y\<in>Y. \<langle>c,y\<rangle>\<in>r \<or> c=y" for c
    unfolding cofinal_def by simp
  ultimately
  obtain x where "x\<in>Y" "\<langle>y,x\<rangle>\<in>r \<or> y=x" by auto
  with \<open>a\<in>A\<close> \<open>y\<in>X\<close> \<open>\<langle>a,y\<rangle>\<in>r \<or> a=y\<close> \<open>trans(r)\<close>
  show "\<exists>x\<in>Y. \<langle>a,x\<rangle>\<in>r \<or> a=x" unfolding trans_def by auto
qed

lemma codomain_is_cofinal:
  assumes "cofinal_fun(f,A,r)" "f:C \<rightarrow> D"
  shows "cofinal(D,A,r)"
  unfolding cofinal_def
proof
  fix b
  assume "b \<in> A"
  moreover from assms
  have "a\<in>A \<Longrightarrow> \<exists>x\<in>domain(f). \<langle>a, f ` x\<rangle> \<in> r \<or> a = f`x" for a
    unfolding cofinal_fun_def by simp
  ultimately
  obtain x where "x\<in>domain(f)" "\<langle>b, f ` x\<rangle> \<in> r \<or> b = f`x"
    by blast
  moreover from \<open>f:C \<rightarrow> D\<close>  \<open>x\<in>domain(f)\<close>
  have "f`x\<in>D"
    using domain_of_fun apply_rangeI by simp
  ultimately
  show  "\<exists>y\<in>D. \<langle>b, y\<rangle> \<in> r \<or> b = y" by auto
qed

lemma cofinal_range_iff_cofinal_fun:
  assumes "function(f)"
  shows "cofinal(range(f),A,r) \<longleftrightarrow> cofinal_fun(f,A,r)"
  unfolding cofinal_fun_def
proof (intro iffI ballI)
  fix a
  assume "a\<in>A" \<open>cofinal(range(f),A,r)\<close>
  then
  obtain y where "y\<in>range(f)" "\<langle>a,y\<rangle> \<in> r \<or> a = y"
    unfolding cofinal_def by blast
  moreover from this
  obtain x where "\<langle>x,y\<rangle>\<in>f"
    unfolding range_def domain_def converse_def by blast
  moreover
  note \<open>function(f)\<close>
  ultimately
  have "\<langle>a, f ` x\<rangle> \<in> r \<or> a = f ` x"
    using function_apply_equality by blast
  with \<open>\<langle>x,y\<rangle>\<in>f\<close>
  show "\<exists>x\<in>domain(f). \<langle>a, f ` x\<rangle> \<in> r \<or> a = f ` x"  by blast
next
  assume "\<forall>a\<in>A. \<exists>x\<in>domain(f). \<langle>a, f ` x\<rangle> \<in> r \<or> a = f ` x"
  with assms
  show "cofinal(range(f), A, r)"
    using function_apply_Pair[of f] unfolding cofinal_def by fast
qed

lemma cofinal_comp:
  assumes
    "f\<in> mono_map(C,s,D,r)" "cofinal_fun(f,D,r)" "h:B \<rightarrow> C"  "cofinal_fun(h,C,s)"
    "trans(r)"
  shows "cofinal_fun(f O h,D,r)"
  unfolding cofinal_fun_def
proof
  fix a
  from \<open>f\<in> mono_map(C,s,D,r)\<close>
  have "f:C \<rightarrow> D"
    using mono_map_is_fun by simp
  with \<open>h:B \<rightarrow> C\<close>
  have "domain(f) = C" "domain(h) = B"
    using domain_of_fun by simp_all
  moreover
  assume "a \<in> D"
  moreover
  note \<open>cofinal_fun(f,D,r)\<close>
  ultimately
  obtain c where "c\<in>C"  "\<langle>a, f ` c\<rangle> \<in> r \<or> a = f ` c"
    unfolding cofinal_fun_def by blast
  with \<open>cofinal_fun(h,C,s)\<close> \<open>domain(h) = B\<close>
  obtain b where "b \<in> B"  "\<langle>c, h ` b\<rangle> \<in> s \<or> c = h ` b"
    unfolding cofinal_fun_def by blast
  moreover from this and \<open>h:B \<rightarrow> C\<close>
  have "h`b \<in> C" by simp
  moreover
  note \<open>f \<in> mono_map(C,s,D,r)\<close>  \<open>c\<in>C\<close>
  ultimately
  have "\<langle>f`c, f` (h ` b)\<rangle> \<in> r \<or> f`c = f` (h ` b)"
    unfolding mono_map_def by blast
  with \<open>\<langle>a, f ` c\<rangle> \<in> r \<or> a = f ` c\<close> \<open>trans(r)\<close> \<open>h:B \<rightarrow> C\<close> \<open>b\<in>B\<close>
  have "\<langle>a, (f O h) ` b\<rangle> \<in> r \<or> a = (f O h) ` b"
    using transD by auto
  moreover from \<open>h:B \<rightarrow> C\<close> \<open>domain(f) = C\<close> \<open>domain(h) = B\<close>
  have "domain(f O h) = B"
    using range_fun_subset_codomain by blast
  moreover
  note \<open>b\<in>B\<close>
  ultimately
  show "\<exists>x\<in>domain(f O h). \<langle>a, (f O h) ` x\<rangle> \<in> r \<or> a = (f O h) ` x"  by blast
qed

definition
  cf_fun :: "[i,i] \<Rightarrow> o" where
  "cf_fun(f,\<alpha>) \<equiv> cofinal_fun(f,\<alpha>,Memrel(\<alpha>))"

lemma cf_funI[intro!]: "cofinal_fun(f,\<alpha>,Memrel(\<alpha>)) \<Longrightarrow> cf_fun(f,\<alpha>)"
  unfolding cf_fun_def by simp

lemma cf_funD[dest!]: "cf_fun(f,\<alpha>) \<Longrightarrow> cofinal_fun(f,\<alpha>,Memrel(\<alpha>))"
  unfolding cf_fun_def by simp

lemma cf_fun_comp:
  assumes
    "Ord(\<alpha>)" "f\<in> mono_map(C,s,\<alpha>,Memrel(\<alpha>))" "cf_fun(f,\<alpha>)"
    "h:B \<rightarrow> C" "cofinal_fun(h,C,s)"
  shows "cf_fun(f O h,\<alpha>)"
  using assms cofinal_comp[OF _ _ _ _ trans_Memrel] by auto

definition
  cf :: "i\<Rightarrow>i" where
  "cf(\<gamma>) \<equiv> \<mu> \<beta>.  \<exists>A. A\<subseteq>\<gamma> \<and> cofinal(A,\<gamma>,Memrel(\<gamma>)) \<and> \<beta> = ordertype(A,Memrel(\<gamma>))"

lemma Ord_cf [TC]: "Ord(cf(\<beta>))"
  unfolding cf_def using Ord_Least by simp

lemma gamma_cofinal_gamma:
  assumes "Ord(\<gamma>)"
  shows "cofinal(\<gamma>,\<gamma>,Memrel(\<gamma>))"
  unfolding cofinal_def by auto

lemma cf_is_ordertype:
  assumes "Ord(\<gamma>)"
  shows "\<exists>A. A\<subseteq>\<gamma> \<and> cofinal(A,\<gamma>,Memrel(\<gamma>)) \<and> cf(\<gamma>) = ordertype(A,Memrel(\<gamma>))"
    (is "?P(cf(\<gamma>))")
  using gamma_cofinal_gamma LeastI[of ?P \<gamma>] ordertype_Memrel[symmetric] assms
  unfolding cf_def by blast

lemma cf_fun_succ':
  assumes "Ord(\<beta>)" "Ord(\<alpha>)" "f:\<alpha>\<rightarrow>succ(\<beta>)"
  shows "(\<exists>x\<in>\<alpha>. f`x=\<beta>) \<longleftrightarrow> cf_fun(f,succ(\<beta>))"
proof (intro iffI)
  assume "(\<exists>x\<in>\<alpha>. f`x=\<beta>)"
  with assms
  show "cf_fun(f,succ(\<beta>))"
    using domain_of_fun[OF \<open>f:\<alpha>\<rightarrow>succ(\<beta>)\<close>]
    unfolding cf_fun_def cofinal_fun_def by auto
next
  assume "cf_fun(f,succ(\<beta>))"
  with assms
  obtain x where "x\<in>\<alpha>" "\<langle>\<beta>,f`x\<rangle> \<in> Memrel(succ(\<beta>)) \<or> \<beta> = f ` x"
    using domain_of_fun[OF \<open>f:\<alpha>\<rightarrow>succ(\<beta>)\<close>]
    unfolding cf_fun_def cofinal_fun_def by auto
  moreover from \<open>Ord(\<beta>)\<close>
  have "\<langle>\<beta>,y\<rangle> \<notin> Memrel(succ(\<beta>))" for y
    using foundation unfolding Memrel_def by blast
  ultimately
  show "\<exists>x\<in>\<alpha>. f ` x = \<beta>" by blast
qed

lemma cf_fun_succ:
  "Ord(\<beta>) \<Longrightarrow> f:1\<rightarrow>succ(\<beta>) \<Longrightarrow> f`0=\<beta> \<Longrightarrow> cf_fun(f,succ(\<beta>))"
  using cf_fun_succ' by blast

lemma ordertype_0_not_cofinal_succ:
  assumes "ordertype(A,Memrel(succ(i))) = 0"  "A\<subseteq>succ(i)" "Ord(i)"
  shows "\<not>cofinal(A,succ(i),Memrel(succ(i)))"
proof
  have 1:"ordertype(A,Memrel(succ(i))) = ordertype(0,Memrel(0))"
    using \<open>ordertype(A,Memrel(succ(i))) = 0\<close> ordertype_0 by simp
  from  \<open>A\<subseteq>succ(i)\<close> \<open>Ord(i)\<close>
  have "\<exists>f. f \<in> \<langle>A, Memrel(succ(i))\<rangle> \<cong> \<langle>0, Memrel(0)\<rangle>"
    using   well_ord_Memrel well_ord_subset
      ordertype_eq_imp_ord_iso[OF 1] Ord_0  by blast
  then
  have "A=0"
    using  ord_iso_is_bij bij_imp_eqpoll eqpoll_0_is_0 by blast
  moreover
  assume "cofinal(A, succ(i), Memrel(succ(i)))"
  moreover
  note \<open>Ord(i)\<close>
  ultimately
  show "False"
    using not_mem_empty unfolding cofinal_def by auto
qed

text\<open>I thank Edwin Pacheco Rodríguez for the following lemma.\<close>
lemma cf_succ:
  assumes "Ord(\<alpha>)"
  shows "cf(succ(\<alpha>)) = 1"
proof -
  define f where "f \<equiv> {\<langle>0,\<alpha>\<rangle>}"
  then
  have  "f : 1\<rightarrow>succ(\<alpha>)" "f`0 = \<alpha>"
    using fun_extend3[of 0 0 "succ(\<alpha>)" 0 \<alpha>] singleton_0 by auto
  with assms
  have "cf_fun(f,succ(\<alpha>))"
    using cf_fun_succ unfolding cofinal_fun_def by simp
  from \<open>f:1\<rightarrow>succ(\<alpha>)\<close>
  have "0\<in>domain(f)" using domain_of_fun by simp
  define A where "A={f`0}"
  with \<open>cf_fun(f,succ(\<alpha>))\<close> \<open>0\<in>domain(f)\<close> \<open>f`0=\<alpha>\<close>
  have "cofinal(A,succ(\<alpha>),Memrel(succ(\<alpha>)))"
    unfolding cofinal_def cofinal_fun_def by simp
  moreover from  \<open>f`0=\<alpha>\<close> \<open>A={f`0}\<close>
  have "A \<subseteq> succ(\<alpha>)" unfolding succ_def  by auto
  moreover from \<open>Ord(\<alpha>)\<close> \<open>A\<subseteq> succ(\<alpha>)\<close>
  have "well_ord(A,Memrel(succ(\<alpha>)))"
    using Ord_succ well_ord_Memrel  well_ord_subset relation_Memrel by blast
  moreover from \<open>Ord(\<alpha>)\<close>
  have "\<not>(\<exists>A. A \<subseteq> succ(\<alpha>) \<and> cofinal(A, succ(\<alpha>), Memrel(succ(\<alpha>))) \<and> 0 = ordertype(A, Memrel(succ(\<alpha>))))"
    (is "\<not>?P(0)")
    using ordertype_0_not_cofinal_succ  unfolding cf_def  by auto
  moreover
  have "1 = ordertype(A,Memrel(succ(\<alpha>)))"
  proof -
    from \<open>A={f`0}\<close>
    have "A\<approx>1" using singleton_eqpoll_1 by simp
    with \<open>well_ord(A,Memrel(succ(\<alpha>)))\<close>
    show ?thesis using nat_1I ordertype_eq_n by simp
  qed
  ultimately
  show "cf(succ(\<alpha>)) = 1" using Ord_1  Least_equality[of ?P 1]
    unfolding cf_def by blast
qed

lemma cf_zero [simp]:
  "cf(0) = 0"
  unfolding cf_def cofinal_def using
    ordertype_0 subset_empty_iff Least_le[of _ 0] by auto

lemma surj_is_cofinal: "f \<in> surj(\<delta>,\<gamma>) \<Longrightarrow> cf_fun(f,\<gamma>)"
  unfolding surj_def cofinal_fun_def cf_fun_def
  using domain_of_fun by force

lemma cf_zero_iff: "Ord(\<alpha>) \<Longrightarrow> cf(\<alpha>) = 0 \<longleftrightarrow> \<alpha> = 0"
proof (intro iffI)
  assume "\<alpha> = 0" "Ord(\<alpha>)"
  then
  show "cf(\<alpha>) = 0" using cf_zero by simp
next
  assume "cf(\<alpha>) = 0" "Ord(\<alpha>)"
  moreover from this
  obtain A where "A\<subseteq>\<alpha>" "cf(\<alpha>) = ordertype(A,Memrel(\<alpha>))"
    "cofinal(A,\<alpha>,Memrel(\<alpha>))"
    using cf_is_ordertype by blast
  ultimately
  have "cofinal(0,\<alpha>,Memrel(\<alpha>))"
    using ordertype_zero_imp_zero[of A "Memrel(\<alpha>)"] by simp
  then
  show "\<alpha>=0"
    unfolding cofinal_def by blast
qed

\<comment> \<open>TODO: define Succ (predicate for successor ordinals)\<close>
lemma cf_eq_one_iff:
  assumes "Ord(\<gamma>)"
  shows "cf(\<gamma>) = 1 \<longleftrightarrow> (\<exists>\<alpha>. Ord(\<alpha>) \<and> \<gamma>  = succ(\<alpha>))"
proof (intro iffI)
  assume "\<exists>\<alpha>. Ord(\<alpha>) \<and> \<gamma>  = succ(\<alpha>)"
  then
  show "cf(\<gamma>) = 1" using cf_succ by auto
next
  assume "cf(\<gamma>) = 1"
  moreover from assms
  obtain A where "A \<subseteq> \<gamma>" "cf(\<gamma>) = ordertype(A,Memrel(\<gamma>))"
    "cofinal(A,\<gamma>,Memrel(\<gamma>))"
    using cf_is_ordertype by blast
  ultimately
  have "ordertype(A,Memrel(\<gamma>)) = 1" by simp
  moreover
  define f where "f\<equiv>converse(ordermap(A,Memrel(\<gamma>)))"
  moreover from this \<open>ordertype(A,Memrel(\<gamma>)) = 1\<close> \<open>A \<subseteq> \<gamma>\<close> assms
  have "f \<in> surj(1,A)"
    using well_ord_subset[OF well_ord_Memrel, THEN ordermap_bij,
        THEN bij_converse_bij, of \<gamma> A] bij_is_surj
    by simp
  with \<open>cofinal(A,\<gamma>,Memrel(\<gamma>))\<close>
  have "\<forall>a\<in>\<gamma>. \<langle>a, f`0\<rangle> \<in> Memrel(\<gamma>) \<or> a = f`0"
    unfolding cofinal_def surj_def
    by auto
  with assms \<open>A \<subseteq> \<gamma>\<close> \<open>f \<in> surj(1,A)\<close>
  show "\<exists>\<alpha>. Ord(\<alpha>) \<and> \<gamma>  = succ(\<alpha>)"
    using Ord_has_max_imp_succ[of \<gamma> "f`0"]
      surj_is_fun[of f 1 A] apply_type[of f 1 "\<lambda>_.A" 0]
    unfolding lt_def
    by (auto intro:Ord_in_Ord)
qed

lemma ordertype_in_cf_imp_not_cofinal:
  assumes
    "ordertype(A,Memrel(\<gamma>)) \<in> cf(\<gamma>)"
    "A \<subseteq> \<gamma>"
  shows
    "\<not> cofinal(A,\<gamma>,Memrel(\<gamma>))"
proof
  note \<open>A \<subseteq> \<gamma>\<close>
  moreover
  assume "cofinal(A,\<gamma>,Memrel(\<gamma>))"
  ultimately
  have "\<exists>B. B \<subseteq> \<gamma> \<and> cofinal(B, \<gamma>, Memrel(\<gamma>)) \<and>  ordertype(A,Memrel(\<gamma>)) = ordertype(B, Memrel(\<gamma>))"
    (is "?P(ordertype(A,_))")
    by blast
  moreover from assms
  have "ordertype(A,Memrel(\<gamma>)) < cf(\<gamma>)"
    using Ord_cf ltI by blast
  ultimately
  show "False"
    unfolding cf_def using less_LeastE[of ?P  "ordertype(A,Memrel(\<gamma>))"]
    by auto
qed

lemma cofinal_mono_map_cf:
  assumes "Ord(\<gamma>)"
  shows "\<exists>j \<in> mono_map(cf(\<gamma>), Memrel(cf(\<gamma>)), \<gamma>, Memrel(\<gamma>)) . cf_fun(j,\<gamma>)"
proof -
  note assms
  moreover from this
  obtain A where "A \<subseteq> \<gamma>" "cf(\<gamma>) = ordertype(A,Memrel(\<gamma>))"
    "cofinal(A,\<gamma>,Memrel(\<gamma>))"
    using cf_is_ordertype by blast
  moreover
  define j where "j \<equiv> converse(ordermap(A,Memrel(\<gamma>)))"
  moreover from calculation
  have "j :cf(\<gamma>) \<rightarrow>\<^sub>< \<gamma>"
    using ordertype_ord_iso[THEN ord_iso_sym,
        THEN ord_iso_is_mono_map, THEN mono_map_mono,
        of A "Memrel(\<gamma>)" \<gamma>] well_ord_Memrel[THEN well_ord_subset]
    by simp
  moreover from calculation
  have "j \<in> surj(cf(\<gamma>),A)"
    using well_ord_Memrel[THEN well_ord_subset, THEN ordertype_ord_iso,
        THEN ord_iso_sym, of \<gamma> A, THEN ord_iso_is_bij,
        THEN bij_is_surj]
    by simp
  with \<open>cofinal(A,\<gamma>,Memrel(\<gamma>))\<close>
  have "cf_fun(j,\<gamma>)"
    using cofinal_range_iff_cofinal_fun[of j \<gamma> "Memrel(\<gamma>)"]
      surj_range[of j "cf(\<gamma>)" A] surj_is_fun fun_is_function
    by fastforce
  with \<open>j \<in> mono_map(_,_,_,_)\<close>
  show ?thesis by auto
qed

subsection\<open>The factorization lemma\<close>

text\<open>In this subsection we prove a factorization lemma for cofinal functions
into ordinals, which shows that any cofinal function between ordinals can be
``decomposed'' in such a way that a commutative triangle of strictly increasing
maps arises.

The factorization lemma has a kind of
fundamental character, in that the rest of the basic results on cofinality
(for, instance, idempotence) follow easily from it, in a more algebraic way.

This is a consequence that the proof encapsulates uses of transfinite
recursion in the basic theory of cofinality; indeed, only one use is needed.
In the setting of Isabelle/ZF, this is convenient since the machinery of
recursion is pretty clumsy. On the downside, this way of presenting things
results in a longer proof of the factorization lemma. This approach was
taken by the author in the notes \<^cite>\<open>"apunte_st"\<close> for an introductory course
in Set Theory.

To organize the use of the hypotheses of the factorization lemma,
we set up a locale containing all the relevant ingredients.
\<close>
locale cofinal_factor =
  fixes j \<delta> \<xi> \<gamma> f
  assumes j_mono: "j :\<xi> \<rightarrow>\<^sub>< \<gamma>"
    and     ords: "Ord(\<delta>)" "Ord(\<xi>)" "Limit(\<gamma>)"
    and   f_type: "f: \<delta> \<rightarrow> \<gamma>"
begin

text\<open>Here, \<^term>\<open>f\<close> is cofinal function from \<^term>\<open>\<delta>\<close> to \<^term>\<open>\<gamma>\<close>, and the
ordinal \<^term>\<open>\<xi>\<close> is meant to be the cofinality of \<^term>\<open>\<gamma>\<close>. Hence, there exists
an increasing map \<^term>\<open>j\<close> from  \<^term>\<open>\<xi>\<close> to  \<^term>\<open>\<gamma>\<close> by the last lemma.

The main goal is to construct an increasing function \<^term>\<open>g:\<xi>\<rightarrow>\<delta>\<close> such that
the composition \<^term>\<open>f O g\<close> is still cofinal but also increasing.\<close>

definition
  factor_body :: "[i,i,i] \<Rightarrow> o" where
  "factor_body(\<beta>,h,x) \<equiv> (x\<in>\<delta> \<and> j`\<beta> \<le> f`x \<and> (\<forall>\<alpha><\<beta> . f`(h`\<alpha>) < f`x)) \<or> x=\<delta>"

definition
  factor_rec :: "[i,i] \<Rightarrow> i" where
  "factor_rec(\<beta>,h) \<equiv>  \<mu> x. factor_body(\<beta>,h,x)"

text\<open>\<^term>\<open>factor_rec\<close> is the inductive step for the definition by transfinite
recursion of the \<^emph>\<open>factor\<close> function (called \<^term>\<open>g\<close> above), which in
turn is obtained by minimizing the predicate \<^term>\<open>factor_body\<close>. Next we show
that this predicate is monotonous.\<close>

lemma factor_body_mono:
  assumes
    "\<beta>\<in>\<xi>" "\<alpha><\<beta>"
    "factor_body(\<beta>,\<lambda>x\<in>\<beta>. G(x),x)"
  shows
    "factor_body(\<alpha>,\<lambda>x\<in>\<alpha>. G(x),x)"
proof -
  from \<open>\<alpha><\<beta>\<close>
  have "\<alpha>\<in>\<beta>" using ltD by simp
  moreover
  note \<open>\<beta>\<in>\<xi>\<close>
  moreover from calculation
  have "\<alpha>\<in>\<xi>" using ords ltD Ord_cf Ord_trans by blast
  ultimately
  have "j`\<alpha> \<in> j`\<beta>" using j_mono mono_map_increasing by blast
  moreover from \<open>\<beta>\<in>\<xi>\<close>
  have "j`\<beta>\<in>\<gamma>"
    using j_mono domain_of_fun apply_rangeI mono_map_is_fun by force
  moreover from this
  have "Ord(j`\<beta>)"
    using Ord_in_Ord ords Limit_is_Ord by auto
  ultimately
  have "j`\<alpha> \<le> j`\<beta>"  unfolding lt_def by blast
  then
  have "j`\<beta> \<le> f`\<theta> \<Longrightarrow> j`\<alpha> \<le> f`\<theta>" for \<theta> using le_trans by blast
  moreover
  have "f`((\<lambda>w\<in>\<alpha>. G(w))`y) < f`z" if "z\<in>\<delta>" "\<forall>x<\<beta>. f`((\<lambda>w\<in>\<beta>. G(w))`x) < f`z" "y<\<alpha>" for y z
  proof -
    note \<open>y<\<alpha>\<close>
    also
    note \<open>\<alpha><\<beta>\<close>
    finally
    have "y<\<beta>" by simp
    with \<open>\<forall>x<\<beta>. f`((\<lambda>w\<in>\<beta>. G(w))`x) < f`z\<close>
    have "f ` ((\<lambda>w\<in>\<beta>. G(w)) ` y) < f ` z" by simp
    moreover from \<open>y<\<alpha>\<close> \<open>y<\<beta>\<close>
    have "(\<lambda>w\<in>\<beta>. G(w)) ` y = (\<lambda>w\<in>\<alpha>. G(w)) ` y"
      using beta_if  by (auto dest:ltD)
    ultimately show ?thesis by simp
  qed
  moreover
  note \<open>factor_body(\<beta>,\<lambda>x\<in>\<beta>. G(x),x)\<close>
  ultimately
  show ?thesis
    unfolding factor_body_def by blast
qed

lemma factor_body_simp[simp]: "factor_body(\<alpha>,g,\<delta>)"
  unfolding factor_body_def by simp

lemma factor_rec_mono:
  assumes
    "\<beta>\<in>\<xi>" "\<alpha><\<beta>"
  shows
    "factor_rec(\<alpha>,\<lambda>x\<in>\<alpha>. G(x)) \<le> factor_rec(\<beta>,\<lambda>x\<in>\<beta>. G(x))"
  unfolding factor_rec_def
  using assms ords factor_body_mono Least_antitone by simp

text\<open>We now define the factor as higher-order function.
Later it will be restricted to a set to obtain a bona fide function of
type @{typ i}.\<close>
definition
  factor :: "i \<Rightarrow> i" where
  "factor(\<beta>) \<equiv> transrec(\<beta>,factor_rec)"

lemma factor_unfold:
  "factor(\<alpha>) = factor_rec(\<alpha>,\<lambda>x\<in>\<alpha>. factor(x))"
  using def_transrec[OF factor_def] .

lemma factor_mono:
  assumes "\<beta>\<in>\<xi>" "\<alpha><\<beta>" "factor(\<alpha>)\<noteq>\<delta>" "factor(\<beta>)\<noteq>\<delta>"
  shows "factor(\<alpha>) \<le> factor(\<beta>)"
proof -
  have "factor(\<alpha>) = factor_rec(\<alpha>, \<lambda>x\<in>\<alpha>. factor(x))"
    using factor_unfold .
  also from assms and factor_rec_mono
  have "... \<le> factor_rec(\<beta>, \<lambda>x\<in>\<beta>. factor(x))"
    by simp
  also
  have "factor_rec(\<beta>, \<lambda>x\<in>\<beta>. factor(x)) = factor(\<beta>)"
    using def_transrec[OF factor_def, symmetric] .
  finally show ?thesis .
qed

text\<open>The factor satisfies the predicate body of the minimization.\<close>

lemma factor_body_factor:
  "factor_body(\<alpha>,\<lambda>x\<in>\<alpha>. factor(x),factor(\<alpha>))"
  using ords factor_unfold[of \<alpha>]
    LeastI[of "factor_body(_,_)" \<delta>]
  unfolding factor_rec_def by simp

lemma factor_type [TC]: "Ord(factor(\<alpha>))"
  using ords factor_unfold[of \<alpha>]
  unfolding factor_rec_def by simp

text\<open>The value \<^term>\<open>\<delta>\<close> in \<^term>\<open>factor_body\<close> (and therefore, in
\<^term>\<open>factor\<close>) is meant to be a ``default value''. Whenever it is not
attained, the factor function behaves as expected: It is increasing
and its composition with \<^term>\<open>f\<close> also is.\<close>

lemma f_factor_increasing:
  assumes "\<beta>\<in>\<xi>" "\<alpha><\<beta>" "factor(\<beta>)\<noteq>\<delta>"
  shows "f`factor(\<alpha>) < f`factor(\<beta>)"
proof -
  from assms
  have "f ` ((\<lambda>x\<in>\<beta>. factor(x)) ` \<alpha>) < f ` factor(\<beta>)"
    using factor_unfold[of \<beta>] ords LeastI[of "factor_body(\<beta>,\<lambda>x\<in>\<beta>. factor(x))"]
    unfolding factor_rec_def factor_body_def
    by (auto simp del:beta_if)
  with \<open>\<alpha><\<beta>\<close>
  show ?thesis using ltD by auto
qed

lemma factor_increasing:
  assumes "\<beta>\<in>\<xi>" "\<alpha><\<beta>" "factor(\<alpha>)\<noteq>\<delta>" "factor(\<beta>)\<noteq>\<delta>"
  shows "factor(\<alpha>)<factor(\<beta>)"
  using assms f_factor_increasing factor_mono by (force intro:le_neq_imp_lt)

lemma factor_in_delta:
  assumes "factor(\<beta>) \<noteq> \<delta>"
  shows "factor(\<beta>) \<in> \<delta>"
  using assms factor_body_factor ords
  unfolding factor_body_def by auto

text\<open>Finally, we define the (set) factor function as the restriction of
factor to the ordinal  \<^term>\<open>\<xi>\<close>.\<close>

definition
  fun_factor :: "i" where
  "fun_factor \<equiv> \<lambda>\<beta>\<in>\<xi>. factor(\<beta>)"

lemma fun_factor_is_mono_map:
  assumes "\<And>\<beta>. \<beta> \<in> \<xi> \<Longrightarrow> factor(\<beta>) \<noteq> \<delta>"
  shows "fun_factor \<in> mono_map(\<xi>, Memrel(\<xi>), \<delta>, Memrel(\<delta>))"
  unfolding mono_map_def
proof (intro CollectI ballI impI)
  text\<open>Proof that \<^term>\<open>fun_factor\<close> respects membership:\<close>
  fix \<alpha> \<beta>
  assume "\<alpha>\<in>\<xi>" "\<beta>\<in>\<xi>"
  moreover
  note assms
  moreover from calculation
  have "factor(\<alpha>)\<noteq>\<delta>" "factor(\<beta>)\<noteq>\<delta>" "Ord(\<beta>)"
    using factor_in_delta Ord_in_Ord ords by auto
  moreover
  assume "\<langle>\<alpha>, \<beta>\<rangle> \<in> Memrel(\<xi>)"
  ultimately
  show "\<langle>fun_factor ` \<alpha>, fun_factor ` \<beta>\<rangle> \<in> Memrel(\<delta>)"
    unfolding fun_factor_def
    using ltI factor_increasing[THEN ltD] factor_in_delta
    by simp
next
  text\<open>Proof that it has the appropriate type:\<close>
  from assms
  show "fun_factor : \<xi> \<rightarrow> \<delta>"
    unfolding fun_factor_def
    using ltI lam_type factor_in_delta by simp
qed

lemma f_fun_factor_is_mono_map:
  assumes "\<And>\<beta>. \<beta> \<in> \<xi> \<Longrightarrow> factor(\<beta>) \<noteq> \<delta>"
  shows "f O fun_factor \<in> mono_map(\<xi>, Memrel(\<xi>), \<gamma>, Memrel(\<gamma>))"
  unfolding mono_map_def
  using f_type
proof (intro CollectI ballI impI comp_fun[of _ _ \<delta>])
  from assms
  show "fun_factor : \<xi> \<rightarrow> \<delta>"
    using fun_factor_is_mono_map mono_map_is_fun by simp
  text\<open>Proof that \<^term>\<open>f O fun_factor\<close> respects membership\<close>
  fix \<alpha> \<beta>
  assume "\<langle>\<alpha>, \<beta>\<rangle> \<in> Memrel(\<xi>)"
  then
  have "\<alpha><\<beta>"
    using Ord_in_Ord[of "\<xi>"] ltI ords by blast
  assume "\<alpha>\<in>\<xi>" "\<beta>\<in>\<xi>"
  moreover from this and assms
  have "factor(\<alpha>)\<noteq>\<delta>" "factor(\<beta>)\<noteq>\<delta>" by auto
  moreover
  have "Ord(\<gamma>)" "\<gamma>\<noteq>0" using ords Limit_is_Ord by auto
  moreover
  note \<open>\<alpha><\<beta>\<close> \<open>fun_factor : \<xi> \<rightarrow> \<delta>\<close>
  ultimately
  show "\<langle>(f O fun_factor) ` \<alpha>, (f O fun_factor) ` \<beta>\<rangle> \<in> Memrel(\<gamma>)"
    using ltD[of "f ` factor(\<alpha>)" "f ` factor(\<beta>)"]
      f_factor_increasing apply_in_codomain_Ord f_type
    unfolding fun_factor_def by auto
qed

end \<comment> \<open>\<^locale>\<open>cofinal_factor\<close>\<close>

text\<open>We state next the factorization lemma.\<close>

lemma cofinal_fun_factorization:
  notes le_imp_subset [dest] lt_trans2 [trans]
  assumes
    "Ord(\<delta>)" "Limit(\<gamma>)" "f: \<delta> \<rightarrow> \<gamma>" "cf_fun(f,\<gamma>)"
  shows
    "\<exists>g \<in> cf(\<gamma>) \<rightarrow>\<^sub>< \<delta>.  f O g : cf(\<gamma>) \<rightarrow>\<^sub>< \<gamma> \<and>
           cofinal_fun(f O g,\<gamma>,Memrel(\<gamma>))"
proof -
  from \<open>Limit(\<gamma>)\<close>
  have "Ord(\<gamma>)" using Limit_is_Ord by simp
  then
  obtain j where "j :cf(\<gamma>) \<rightarrow>\<^sub>< \<gamma>" "cf_fun(j,\<gamma>)"
    using cofinal_mono_map_cf by blast
  then
  have "domain(j) = cf(\<gamma>)"
    using domain_of_fun mono_map_is_fun by force
  from \<open>j \<in> _\<close> assms
  interpret cofinal_factor j \<delta> "cf(\<gamma>)"
    by (unfold_locales) (simp_all)
  text\<open>The core of the argument is to show that the factor function
  indeed maps into \<^term>\<open>\<delta>\<close>, therefore its values satisfy the first
  disjunct of \<^term>\<open>factor_body\<close>. This holds in turn because no
  restriction of the factor composed with \<^term>\<open>f\<close> to a proper initial
  segment of \<^term>\<open>cf(\<gamma>)\<close> can be cofinal in \<^term>\<open>\<gamma>\<close> by definition of
  cofinality. Hence there must be a witness that satisfies the first
  disjunct.\<close>
  have factor_not_delta: "factor(\<beta>)\<noteq>\<delta>" if "\<beta> \<in> cf(\<gamma>)" for \<beta>
    text\<open>For this, we induct on \<^term>\<open>\<beta>\<close> ranging over \<^term>\<open>cf(\<gamma>)\<close>.\<close>
  proof (induct \<beta> rule:Ord_induct[OF _ Ord_cf[of \<gamma>]])
    case 1 with that show ?case .
  next
    case (2 \<beta>)
    then
    have IH: "z\<in>\<beta> \<Longrightarrow> factor(z)\<noteq>\<delta>" for z by simp
    define h where "h \<equiv> \<lambda>x\<in>\<beta>. f`factor(x)"
    from IH
    have "z\<in>\<beta> \<Longrightarrow> factor(z) \<in> \<delta>" for z
      using factor_in_delta by blast
    with \<open>f:\<delta>\<rightarrow>\<gamma>\<close>
    have "h : \<beta> \<rightarrow> \<gamma>" unfolding h_def using apply_funtype lam_type by auto
    then
    have "h : \<beta> \<rightarrow>\<^sub>< \<gamma>"
      unfolding mono_map_def
    proof (intro CollectI ballI impI)
      fix x y
      assume "x\<in>\<beta>" "y\<in>\<beta>"
      moreover from this and IH
      have "factor(y) \<noteq> \<delta>" by simp
      moreover from calculation and \<open>h \<in> \<beta> \<rightarrow> \<gamma>\<close>
      have "h`x \<in> \<gamma>" "h`y \<in> \<gamma>" by simp_all
      moreover from \<open>\<beta>\<in>cf(\<gamma>)\<close> and \<open>y\<in>\<beta>\<close>
      have "y \<in> cf(\<gamma>)"
        using Ord_trans Ord_cf by blast
      moreover from this
      have "Ord(y)"
        using Ord_cf Ord_in_Ord by blast
      moreover
      assume "\<langle>x,y\<rangle> \<in> Memrel(\<beta>)"
      moreover from calculation
      have "x<y" by (blast intro:ltI)
      ultimately
      show "\<langle>h ` x, h ` y\<rangle> \<in> Memrel(\<gamma>)"
        unfolding h_def using f_factor_increasing ltD by (auto)
    qed
    with \<open>\<beta>\<in>cf(\<gamma>)\<close> \<open>Ord(\<gamma>)\<close>
    have "ordertype(h``\<beta>,Memrel(\<gamma>)) = \<beta>" (* Maybe should use range(h) *)
      using mono_map_ordertype_image[of \<beta>] Ord_cf Ord_in_Ord by blast
    also
    note \<open>\<beta> \<in>cf(\<gamma>)\<close>
    finally
    have "ordertype(h``\<beta>,Memrel(\<gamma>)) \<in> cf(\<gamma>)" by simp
    moreover from \<open>h \<in> \<beta> \<rightarrow> \<gamma>\<close>
    have "h``\<beta> \<subseteq> \<gamma>"
      using mono_map_is_fun Image_sub_codomain by blast
    ultimately
    have "\<not> cofinal(h``\<beta>,\<gamma>,Memrel(\<gamma>))"
      using ordertype_in_cf_imp_not_cofinal by simp
    then
    obtain \<alpha>_0 where "\<alpha>_0\<in>\<gamma>" "\<forall>x\<in>h `` \<beta>. \<not> \<langle>\<alpha>_0, x\<rangle> \<in> Memrel(\<gamma>) \<and> \<alpha>_0 \<noteq> x"
      unfolding cofinal_def by auto
    with \<open>Ord(\<gamma>)\<close> \<open>h``\<beta> \<subseteq> \<gamma>\<close>
    have "\<forall>x\<in>h `` \<beta>. x \<in> \<alpha>_0"
      using well_ord_Memrel[of \<gamma>] well_ord_is_linear[of \<gamma> "Memrel(\<gamma>)"]
      unfolding linear_def by blast
    from \<open>\<alpha>_0 \<in> \<gamma>\<close> \<open>j \<in> mono_map(_,_,\<gamma>,_)\<close> \<open>Ord(\<gamma>)\<close>
    have "j`\<beta> \<in> \<gamma>"
      using mono_map_is_fun apply_in_codomain_Ord by force
    with \<open>\<alpha>_0 \<in> \<gamma>\<close> \<open>Ord(\<gamma>)\<close>
    have "\<alpha>_0 \<union> j`\<beta> \<in> \<gamma>"
      using Un_least_mem_iff Ord_in_Ord by auto
    with \<open>cf_fun(f,\<gamma>)\<close>
    obtain \<theta> where "\<theta>\<in>domain(f)" "\<langle>\<alpha>_0 \<union> j`\<beta>, f ` \<theta>\<rangle> \<in> Memrel(\<gamma>) \<or>  \<alpha>_0 \<union> j`\<beta> = f ` \<theta>"
      by (auto simp add:cofinal_fun_def) blast
    moreover from this and \<open>f:\<delta>\<rightarrow>\<gamma>\<close>
    have "\<theta> \<in> \<delta>" using domain_of_fun by auto
    moreover
    note \<open>Ord(\<gamma>)\<close>
    moreover from this and \<open>f:\<delta>\<rightarrow>\<gamma>\<close>  \<open>\<alpha>_0 \<in> \<gamma>\<close>
    have "Ord(f`\<theta>)"
      using apply_in_codomain_Ord Ord_in_Ord by blast
    moreover from calculation and \<open>\<alpha>_0 \<in> \<gamma>\<close> and \<open>Ord(\<delta>)\<close> and \<open>j`\<beta> \<in> \<gamma>\<close>
    have "Ord(\<alpha>_0)" "Ord(j`\<beta>)" "Ord(\<theta>)"
      using Ord_in_Ord by auto
    moreover from \<open>\<forall>x\<in>h `` \<beta>. x \<in> \<alpha>_0\<close> \<open>Ord(\<alpha>_0)\<close> \<open>h:\<beta>\<rightarrow>\<gamma>\<close>
    have "x\<in>\<beta> \<Longrightarrow> h`x < \<alpha>_0" for x
      using fun_is_function[of h \<beta> "\<lambda>_. \<gamma>"]
        Image_subset_Ord_imp_lt domain_of_fun[of h \<beta> "\<lambda>_. \<gamma>"]
      by blast
    moreover
    have "x\<in>\<beta> \<Longrightarrow> h`x < f`\<theta>" for x
    proof -
      fix x
      assume "x\<in>\<beta>"
      with \<open>\<forall>x\<in>h `` \<beta>. x \<in> \<alpha>_0\<close> \<open>Ord(\<alpha>_0)\<close> \<open>h:\<beta>\<rightarrow>\<gamma>\<close>
      have "h`x < \<alpha>_0"
        using fun_is_function[of h \<beta> "\<lambda>_. \<gamma>"]
          Image_subset_Ord_imp_lt domain_of_fun[of h \<beta> "\<lambda>_. \<gamma>"]
        by blast
      also from \<open>\<langle>\<alpha>_0 \<union> _, f ` \<theta>\<rangle> \<in> Memrel(\<gamma>) \<or> \<alpha>_0 \<union> _= f ` \<theta>\<close>
        \<open>Ord(f`\<theta>)\<close> \<open>Ord(\<alpha>_0)\<close> \<open>Ord(j`\<beta>)\<close>
      have "\<alpha>_0 \<le> f`\<theta>"
        using Un_leD1[OF leI [OF ltI]] Un_leD1[OF le_eqI] by blast
      finally
      show "h`x < f`\<theta>" .
    qed
    ultimately
    have "factor_body(\<beta>,\<lambda>x\<in>\<beta>. factor(x),\<theta>)"
      unfolding h_def factor_body_def using ltD
      by (auto dest:Un_memD2 Un_leD2[OF le_eqI])
    with \<open>Ord(\<theta>)\<close>
    have "factor(\<beta>) \<le> \<theta>"
      using factor_unfold[of \<beta>] Least_le unfolding factor_rec_def by auto
    with \<open>\<theta>\<in>\<delta>\<close> \<open>Ord(\<delta>)\<close>
    have "factor(\<beta>) \<in> \<delta>"
      using leI[of \<theta>] ltI[of \<theta>]  by (auto dest:ltD)
    then
    show ?case by (auto elim:mem_irrefl)
  qed
  moreover
  have "cofinal_fun(f O fun_factor, \<gamma>, Memrel(\<gamma>))"
  proof (intro cofinal_funI)
    fix a
    assume "a \<in> \<gamma>"
    with \<open>cf_fun(j,\<gamma>)\<close> \<open>domain(j) = cf(\<gamma>)\<close>
    obtain x where "x\<in>cf(\<gamma>)" "a \<in> j`x \<or> a = j`x"
      by (auto simp add:cofinal_fun_def) blast
    with factor_not_delta
    have "x \<in> domain(f O fun_factor)"
      using f_fun_factor_is_mono_map mono_map_is_fun domain_of_fun by force
    moreover
    have "a \<in> (f O fun_factor) `x \<or> a = (f O fun_factor) `x"
    proof -
      from \<open>x\<in>cf(\<gamma>)\<close> factor_not_delta
      have "j ` x \<le> f ` factor(x)"
        using mem_not_refl factor_body_factor factor_in_delta
        unfolding factor_body_def by auto
      with \<open>a \<in> j`x \<or> a = j`x\<close>
      have "a \<in> f ` factor(x) \<or> a = f ` factor(x)"
        using ltD by blast
      with \<open>x\<in>cf(\<gamma>)\<close>
      show ?thesis using lam_funtype[of "cf(\<gamma>)" factor]
        unfolding fun_factor_def by auto
    qed
    moreover
    note \<open>a \<in> \<gamma>\<close>
    moreover from calculation and \<open>Ord(\<gamma>)\<close> and factor_not_delta
    have "(f O fun_factor) `x \<in> \<gamma>"
      using Limit_nonzero apply_in_codomain_Ord mono_map_is_fun[of "f O fun_factor"]
        f_fun_factor_is_mono_map by blast
    ultimately
    show "\<exists>x \<in> domain(f O fun_factor). \<langle>a, (f O fun_factor) ` x\<rangle> \<in> Memrel(\<gamma>)
                                       \<or> a = (f O fun_factor) `x"
      by blast
  qed
  ultimately
  show ?thesis
    using fun_factor_is_mono_map f_fun_factor_is_mono_map by blast
qed

text\<open>As a final observation in this part, we note that if the original
cofinal map was increasing, then the factor function is also cofinal.\<close>
lemma factor_is_cofinal:
  assumes
    "Ord(\<delta>)" "Ord(\<gamma>)"
    "f :\<delta> \<rightarrow>\<^sub>< \<gamma>"  "f O g \<in> mono_map(\<alpha>,r,\<gamma>,Memrel(\<gamma>))"
    "cofinal_fun(f O g,\<gamma>,Memrel(\<gamma>))" "g: \<alpha> \<rightarrow> \<delta>"
  shows
    "cf_fun(g,\<delta>)"
  unfolding cf_fun_def cofinal_fun_def
proof
  fix a
  assume "a \<in> \<delta>"
  with \<open>f \<in> mono_map(\<delta>,_,\<gamma>,_)\<close>
  have "f`a \<in> \<gamma>"
    using mono_map_is_fun by force
  with \<open>cofinal_fun(f O g,\<gamma>,_)\<close>
  obtain y where "y\<in>\<alpha>"  "\<langle>f`a, (f O g) ` y\<rangle> \<in> Memrel(\<gamma>) \<or> f`a = (f O g) ` y"
    unfolding cofinal_fun_def using domain_of_fun[OF \<open>g:\<alpha> \<rightarrow> \<delta>\<close>] by blast
  with \<open>g:\<alpha> \<rightarrow> \<delta>\<close>
  have "\<langle>f`a, f ` (g ` y)\<rangle> \<in> Memrel(\<gamma>) \<or> f`a = f ` (g ` y)" "g`y \<in> \<delta>"
    using comp_fun_apply[of g \<alpha> \<delta> y f] by auto
  with assms(1-3) and \<open>a\<in>\<delta>\<close>
  have "\<langle>a, g ` y\<rangle> \<in> Memrel(\<delta>) \<or> a = g ` y"
    using Memrel_mono_map_reflects Memrel_mono_map_is_inj[of \<delta> f \<gamma> \<gamma>]
      inj_apply_equality[of f \<delta> \<gamma>]  by blast
  with \<open>y\<in>\<alpha>\<close>
  show "\<exists>x\<in>domain(g). \<langle>a, g ` x\<rangle> \<in> Memrel(\<delta>) \<or> a = g ` x"
    using domain_of_fun[OF \<open>g:\<alpha> \<rightarrow> \<delta>\<close>] by blast
qed

subsection\<open>Classical results on cofinalities\<close>

text\<open>Now the rest of the results follow in a more algebraic way. The
next proof one invokes a case analysis on whether the argument is zero,
a successor ordinal or a limit one; the last case being the most
relevant one and is immediate from the factorization lemma.\<close>

lemma cf_le_domain_cofinal_fun:
  assumes
    "Ord(\<gamma>)" "Ord(\<delta>)" "f:\<delta> \<rightarrow> \<gamma>" "cf_fun(f,\<gamma>)"
  shows
    "cf(\<gamma>)\<le>\<delta>"
  using assms
proof (cases rule:Ord_cases)
  case 0
  with \<open>Ord(\<delta>)\<close>
  show ?thesis using Ord_0_le by simp
next
  case (succ \<gamma>)
  with assms
  obtain x where "x\<in>\<delta>" "f`x=\<gamma>" using cf_fun_succ' by blast
  then
  have "\<delta>\<noteq>0" by blast
  let ?f="{\<langle>0,f`x\<rangle>}"
  from \<open>f`x=\<gamma>\<close>
  have "?f:1\<rightarrow>succ(\<gamma>)"
    using singleton_0 singleton_fun[of 0 \<gamma>] singleton_subsetI fun_weaken_type by simp
  with \<open>Ord(\<gamma>)\<close>  \<open>f`x=\<gamma>\<close>
  have "cf(succ(\<gamma>)) = 1" using cf_succ by simp
  with \<open>\<delta>\<noteq>0\<close> succ
  show ?thesis using Ord_0_lt_iff succ_leI \<open>Ord(\<delta>)\<close> by simp
next
  case (limit)
  with assms
  obtain g where "g :cf(\<gamma>) \<rightarrow>\<^sub>< \<delta>"
    using cofinal_fun_factorization by blast
  with assms
  show ?thesis using mono_map_imp_le by simp
qed

lemma cf_ordertype_cofinal:
  assumes
    "Limit(\<gamma>)" "A\<subseteq>\<gamma>" "cofinal(A,\<gamma>,Memrel(\<gamma>))"
  shows
    "cf(\<gamma>) = cf(ordertype(A,Memrel(\<gamma>)))"
proof (intro le_anti_sym)
  text\<open>We show the result by proving the two inequalities.\<close>
  from \<open>Limit(\<gamma>)\<close>
  have "Ord(\<gamma>)"
    using Limit_is_Ord by simp
  with \<open>A \<subseteq> \<gamma>\<close>
  have "well_ord(A,Memrel(\<gamma>))"
    using well_ord_Memrel well_ord_subset by blast
  then
  obtain f \<alpha> where "f:\<langle>\<alpha>, Memrel(\<alpha>)\<rangle> \<cong> \<langle>A,Memrel(\<gamma>)\<rangle>" "Ord(\<alpha>)" "\<alpha> = ordertype(A,Memrel(\<gamma>))"
    using ordertype_ord_iso Ord_ordertype ord_iso_sym by blast
  moreover from this
  have "f: \<alpha> \<rightarrow> A"
    using ord_iso_is_mono_map mono_map_is_fun[of f _ "Memrel(\<alpha>)"] by blast
  moreover from this
  have "function(f)"
    using fun_is_function by simp
  moreover from \<open>f:\<langle>\<alpha>, Memrel(\<alpha>)\<rangle> \<cong> \<langle>A,Memrel(\<gamma>)\<rangle>\<close>
  have "range(f) = A"
    using ord_iso_is_bij bij_is_surj surj_range by blast
  moreover note \<open>cofinal(A,\<gamma>,_)\<close>
  ultimately
  have "cf_fun(f,\<gamma>)"
    using cofinal_range_iff_cofinal_fun by blast
  moreover from \<open>Ord(\<alpha>)\<close>
  obtain h where "h :cf(\<alpha>) \<rightarrow>\<^sub>< \<alpha>" "cf_fun(h,\<alpha>)"
    using cofinal_mono_map_cf by blast
  moreover from \<open>Ord(\<gamma>)\<close>
  have "trans(Memrel(\<gamma>))"
    using trans_Memrel by simp
  moreover
  note \<open>A\<subseteq>\<gamma>\<close>
  ultimately
  have "cofinal_fun(f O h,\<gamma>,Memrel(\<gamma>))"
    using cofinal_comp ord_iso_is_mono_map[OF \<open>f:\<langle>\<alpha>,_\<rangle> \<cong> \<langle>A,_\<rangle>\<close>] mono_map_is_fun
      mono_map_mono by blast
  moreover from \<open>f:\<alpha>\<rightarrow>A\<close> \<open>A\<subseteq>\<gamma>\<close> \<open>h\<in>mono_map(cf(\<alpha>),_,\<alpha>,_)\<close>
  have "f O h : cf(\<alpha>) \<rightarrow> \<gamma>"
    using Pi_mono[of A \<gamma>] comp_fun  mono_map_is_fun by blast
  moreover
  note \<open>Ord(\<gamma>)\<close> \<open>Ord(\<alpha>)\<close> \<open>\<alpha> = ordertype(A,Memrel(\<gamma>))\<close>
  ultimately
  show "cf(\<gamma>) \<le> cf(ordertype(A,Memrel(\<gamma>)))"
    using cf_le_domain_cofinal_fun[of _ _ "f O h"]
    by (auto simp add:cf_fun_def)
  text\<open>That finishes the first inequality. Now we go the other side.\<close>
  from \<open>f:\<langle>\<alpha>, _\<rangle> \<cong> \<langle>A,_\<rangle>\<close> \<open>A\<subseteq>\<gamma>\<close>
  have "f :\<alpha> \<rightarrow>\<^sub>< \<gamma>"
    using mono_map_mono[OF ord_iso_is_mono_map] by simp
  then
  have "f: \<alpha> \<rightarrow> \<gamma>"
    using mono_map_is_fun by simp
  with \<open>cf_fun(f,\<gamma>)\<close> \<open>Limit(\<gamma>)\<close> \<open>Ord(\<alpha>)\<close>
  obtain g where "g :cf(\<gamma>) \<rightarrow>\<^sub>< \<alpha>"
    "f O g :cf(\<gamma>) \<rightarrow>\<^sub>< \<gamma>"
    "cofinal_fun(f O g,\<gamma>,Memrel(\<gamma>))"
    using cofinal_fun_factorization by blast
  moreover from this
  have "g:cf(\<gamma>)\<rightarrow>\<alpha>"
    using mono_map_is_fun by simp
  moreover
  note \<open>Ord(\<alpha>)\<close>
  moreover from calculation and \<open>f :\<alpha> \<rightarrow>\<^sub>< \<gamma>\<close> \<open>Ord(\<gamma>)\<close>
  have "cf_fun(g,\<alpha>)"
    using factor_is_cofinal by blast
  moreover
  note \<open>\<alpha> = ordertype(A,Memrel(\<gamma>))\<close>
  ultimately
  show "cf(ordertype(A,Memrel(\<gamma>))) \<le> cf(\<gamma>)"
    using cf_le_domain_cofinal_fun[OF _ Ord_cf mono_map_is_fun] by simp
qed

lemma cf_idemp:
  assumes "Limit(\<gamma>)"
  shows "cf(\<gamma>) = cf(cf(\<gamma>))"
proof -
  from assms
  obtain A where "A\<subseteq>\<gamma>" "cofinal(A,\<gamma>,Memrel(\<gamma>))" "cf(\<gamma>) = ordertype(A,Memrel(\<gamma>))"
    using Limit_is_Ord cf_is_ordertype by blast
  with assms
  have "cf(\<gamma>) = cf(ordertype(A,Memrel(\<gamma>)))" using cf_ordertype_cofinal by simp
  also
  have "... = cf(cf(\<gamma>))"
    using \<open>cf(\<gamma>) = ordertype(A,Memrel(\<gamma>))\<close> by simp
  finally
  show "cf(\<gamma>) = cf(cf(\<gamma>))"  .
qed

lemma cf_le_cardinal:
  assumes "Limit(\<gamma>)"
  shows "cf(\<gamma>) \<le> |\<gamma>|"
proof -
  from assms
  have \<open>Ord(\<gamma>)\<close> using Limit_is_Ord by simp
  then
  obtain f where "f \<in> surj(|\<gamma>|,\<gamma>)"
    using Ord_cardinal_eqpoll unfolding eqpoll_def bij_def by blast
  with \<open>Ord(\<gamma>)\<close>
  show ?thesis
    using Card_is_Ord[OF Card_cardinal] surj_is_cofinal
      cf_le_domain_cofinal_fun[of \<gamma>] surj_is_fun by blast
qed

lemma regular_is_Card:
  notes le_imp_subset [dest]
  assumes "Limit(\<gamma>)" "\<gamma> = cf(\<gamma>)"
  shows "Card(\<gamma>)"
proof -
  from assms
  have "|\<gamma>| \<subseteq> \<gamma>"
    using Limit_is_Ord Ord_cardinal_le by blast
  also from \<open>\<gamma> = cf(\<gamma>)\<close>
  have "\<gamma> \<subseteq> cf(\<gamma>)" by simp
  finally
  have "|\<gamma>| \<subseteq> cf(\<gamma>)" .
  with assms
  show ?thesis unfolding Card_def using cf_le_cardinal by force
qed

lemma Limit_cf: assumes "Limit(\<kappa>)" shows "Limit(cf(\<kappa>))"
  using Ord_cf[of \<kappa>, THEN Ord_cases]
    \<comment> \<open>\<^term>\<open>cf(\<kappa>)\<close> being $0$ or successor leads to contradiction\<close>
proof (cases)
  case 1
  with \<open>Limit(\<kappa>)\<close>
  show ?thesis using cf_zero_iff Limit_is_Ord by simp
next
  case (2 \<alpha>)
  moreover
  note \<open>Limit(\<kappa>)\<close>
  moreover from calculation
  have "cf(\<kappa>) = 1"
    using cf_idemp cf_succ by fastforce
  ultimately
  show ?thesis
    using succ_LimitE cf_eq_one_iff Limit_is_Ord
    by auto
qed

lemma InfCard_cf: "Limit(\<kappa>) \<Longrightarrow> InfCard(cf(\<kappa>))"
  using regular_is_Card cf_idemp Limit_cf nat_le_Limit Limit_cf
  unfolding InfCard_def by simp

lemma cf_le_cf_fun:
  notes [dest] = Limit_is_Ord
  assumes "cf(\<kappa>) \<le> \<nu>" "Limit(\<kappa>)"
  shows "\<exists>f.  f:\<nu> \<rightarrow> \<kappa>  \<and>  cf_fun(f, \<kappa>)"
proof -
  note assms
  moreover from this
  obtain h where h_cofinal_mono: "cf_fun(h,\<kappa>)"
    "h :cf(\<kappa>) \<rightarrow>\<^sub>< \<kappa>"
    "h : cf(\<kappa>) \<rightarrow> \<kappa>"
    using cofinal_mono_map_cf mono_map_is_fun by force
  moreover from calculation
  obtain g where "g \<in> inj(cf(\<kappa>), \<nu>)"
    using le_imp_lepoll by blast
  from this and calculation(2,3,5)
  obtain f where "f \<in> surj(\<nu>, cf(\<kappa>))" "f: \<nu> \<rightarrow> cf(\<kappa>)"
    using inj_imp_surj[OF _ Limit_has_0[THEN ltD]]
      surj_is_fun Limit_cf by blast
  moreover from this
  have "cf_fun(f,cf(\<kappa>))"
    using surj_is_cofinal by simp
  moreover
  note h_cofinal_mono \<open>Limit(\<kappa>)\<close>
  moreover from calculation
  have "cf_fun(h O f,\<kappa>)"
    using cf_fun_comp by blast
  moreover from calculation
  have "h O f \<in> \<nu> -> \<kappa>"
    using comp_fun by simp
  ultimately
  show ?thesis by blast
qed

lemma Limit_cofinal_fun_lt:
  notes [dest] = Limit_is_Ord
  assumes "Limit(\<kappa>)" "f: \<nu> \<rightarrow> \<kappa>" "cf_fun(f,\<kappa>)" "n\<in>\<kappa>"
  shows "\<exists>\<alpha>\<in>\<nu>. n < f`\<alpha>"
proof -
  from \<open>Limit(\<kappa>)\<close> \<open>n\<in>\<kappa>\<close>
  have "succ(n) \<in> \<kappa>"
    using Limit_has_succ[OF _ ltI, THEN ltD] by auto
  moreover
  note \<open>f: \<nu> \<rightarrow> _\<close>
  moreover from this
  have "domain(f) = \<nu>"
    using domain_of_fun by simp
  moreover
  note \<open>cf_fun(f,\<kappa>)\<close>
  ultimately
  obtain \<alpha> where "\<alpha> \<in> \<nu>" "succ(n) \<in> f`\<alpha> \<or> succ(n) = f `\<alpha>"
    using cf_funD[THEN cofinal_funD] by blast
  moreover from this
  consider (1) "succ(n) \<in> f`\<alpha>" | (2) "succ(n) = f `\<alpha>"
    by blast
  then
  have "n < f`\<alpha>"
  proof (cases)
    case 1
    moreover
    have "n \<in> succ(n)" by simp
    moreover
    note \<open>Limit(\<kappa>)\<close> \<open>f: \<nu> \<rightarrow> _\<close> \<open>\<alpha> \<in> \<nu>\<close>
    moreover from this
    have "Ord(f ` \<alpha>)"
      using apply_type[of f \<nu> "\<lambda>_. \<kappa>", THEN [2] Ord_in_Ord]
      by blast
    ultimately
    show ?thesis
      using Ord_trans[of n "succ(n)" "f ` \<alpha>"] ltI  by blast
  next
    case 2
    have "n \<in> f ` \<alpha>" by (simp add:2[symmetric])
    with \<open>Limit(\<kappa>)\<close> \<open>f: \<nu> \<rightarrow> _\<close> \<open>\<alpha> \<in> \<nu>\<close>
    show ?thesis
      using ltI
        apply_type[of f \<nu> "\<lambda>_. \<kappa>", THEN [2] Ord_in_Ord]
      by blast
  qed
  ultimately
  show ?thesis by blast
qed

context
  includes Ord_dests Aleph_dests Aleph_intros Aleph_mem_dests mono_map_rules
begin

text\<open>We end this section by calculating the cofinality of Alephs, for
the zero and limit case. The successor case depends on $\AC$.\<close>

lemma cf_nat: "cf(\<omega>) = \<omega>"
  using Limit_nat[THEN InfCard_cf] cf_le_cardinal[of \<omega>]
    Card_nat[THEN Card_cardinal_eq] le_anti_sym
  unfolding InfCard_def by auto

lemma cf_Aleph_zero: "cf(\<aleph>\<^bsub>0\<^esub>) = \<aleph>\<^bsub>0\<^esub>"
  using cf_nat unfolding Aleph_def by simp

lemma cf_Aleph_Limit:
  assumes "Limit(\<gamma>)"
  shows "cf(\<aleph>\<^bsub>\<gamma>\<^esub>) = cf(\<gamma>)"
proof -
  note \<open>Limit(\<gamma>)\<close>
  moreover from this
  have "(\<lambda>x\<in>\<gamma>. \<aleph>\<^bsub>x\<^esub>) : \<gamma> \<rightarrow> \<aleph>\<^bsub>\<gamma>\<^esub>" (is "?f : _ \<rightarrow> _")
    using lam_funtype[of _ Aleph] fun_weaken_type[of _ _ _ "\<aleph>\<^bsub>\<gamma>\<^esub>"] by blast
  moreover from \<open>Limit(\<gamma>)\<close>
  have "x \<in> y \<Longrightarrow> \<aleph>\<^bsub>x\<^esub> \<in> \<aleph>\<^bsub>y\<^esub>" if "x \<in> \<gamma>" "y \<in> \<gamma>" for x y
    using that Ord_in_Ord[of \<gamma>] Ord_trans[of _ _ \<gamma>] by blast
  ultimately
  have "?f \<in> mono_map(\<gamma>,Memrel(\<gamma>),\<aleph>\<^bsub>\<gamma>\<^esub>, Memrel(\<aleph>\<^bsub>\<gamma>\<^esub>))"
    by auto
  with  \<open>Limit(\<gamma>)\<close>
  have "?f \<in> \<langle>\<gamma>, Memrel(\<gamma>)\<rangle> \<cong> \<langle>?f``\<gamma>, Memrel(\<aleph>\<^bsub>\<gamma>\<^esub>)\<rangle>"
    using mono_map_imp_ord_iso_Memrel[of \<gamma> "\<aleph>\<^bsub>\<gamma>\<^esub>" ?f]
      Card_Aleph (* Already an intro rule, but need it explicitly *)
    by blast
  then
  have "converse(?f) \<in> \<langle>?f``\<gamma>, Memrel(\<aleph>\<^bsub>\<gamma>\<^esub>)\<rangle> \<cong> \<langle>\<gamma>, Memrel(\<gamma>)\<rangle>"
    using ord_iso_sym by simp
  with \<open>Limit(\<gamma>)\<close>
  have "ordertype(?f``\<gamma>, Memrel(\<aleph>\<^bsub>\<gamma>\<^esub>)) = \<gamma>"
    using ordertype_eq[OF _ well_ord_Memrel]
    ordertype_Memrel by auto
  moreover from \<open>Limit(\<gamma>)\<close>
  have "cofinal(?f``\<gamma>, \<aleph>\<^bsub>\<gamma>\<^esub>, Memrel(\<aleph>\<^bsub>\<gamma>\<^esub>))"
    unfolding cofinal_def
  proof (standard, intro ballI)
    fix a
    assume "a\<in>\<aleph>\<^bsub>\<gamma>\<^esub>" "\<aleph>\<^bsub>\<gamma>\<^esub> = (\<Union>i<\<gamma>. \<aleph>\<^bsub>i\<^esub>)"
    moreover from this
    obtain i where "i<\<gamma>" "a\<in>\<aleph>\<^bsub>i\<^esub>"
      by auto
    moreover from this and \<open>Limit(\<gamma>)\<close>
    have "Ord(i)" using ltD Ord_in_Ord by blast
    moreover from \<open>Limit(\<gamma>)\<close> and calculation
    have "succ(i) \<in> \<gamma>" using ltD by auto
    moreover from this and \<open>Ord(i)\<close>
    have "\<aleph>\<^bsub>i\<^esub> < \<aleph>\<^bsub>succ(i)\<^esub>"
      by (auto)
    ultimately
    have "\<langle>a,\<aleph>\<^bsub>i\<^esub>\<rangle> \<in> Memrel(\<aleph>\<^bsub>\<gamma>\<^esub>)"
      using ltD by (auto dest:Aleph_increasing)
    moreover from \<open>i<\<gamma>\<close>
    have "\<aleph>\<^bsub>i\<^esub> \<in> ?f``\<gamma>"
      using ltD apply_in_image[OF \<open>?f : _ \<rightarrow> _\<close>] by auto
    ultimately
    show "\<exists>x\<in>?f `` \<gamma>. \<langle>a, x\<rangle> \<in> Memrel(\<aleph>\<^bsub>\<gamma>\<^esub>) \<or> a = x" by blast
  qed
  moreover
  note \<open>?f: \<gamma> \<rightarrow> \<aleph>\<^bsub>\<gamma>\<^esub>\<close> \<open>Limit(\<gamma>)\<close>
  ultimately
  show "cf(\<aleph>\<^bsub>\<gamma>\<^esub>) =  cf(\<gamma>)"
    using cf_ordertype_cofinal[OF Limit_Aleph Image_sub_codomain, of \<gamma> ?f \<gamma> \<gamma> ]
      Limit_is_Ord by simp
qed

end \<comment> \<open>includes\<close>

end


(*  Title:      HOL/Nonstandard_Analysis/StarDef.thy
    Author:     Jacques D. Fleuriot and Brian Huffman
*)

section \<open>Construction of Star Types Using Ultrafilters\<close>

theory StarDef
  imports Free_Ultrafilter
begin

subsection \<open>A Free Ultrafilter over the Naturals\<close>

definition FreeUltrafilterNat :: "nat filter"  (\<open>\<U>\<close>)
  where "\<U> = (SOME U. freeultrafilter U)"

lemma freeultrafilter_FreeUltrafilterNat: "freeultrafilter \<U>"
  unfolding FreeUltrafilterNat_def
  by (simp add: freeultrafilter_Ex someI_ex)

interpretation FreeUltrafilterNat: freeultrafilter \<U>
  by (rule freeultrafilter_FreeUltrafilterNat)

subsection \<open>Definition of \<open>star\<close> type constructor\<close>

definition starrel :: "((nat \<Rightarrow> 'a) \<times> (nat \<Rightarrow> 'a)) set"
  where "starrel = {(X, Y). eventually (\<lambda>n. X n = Y n) \<U>}"

definition "star = (UNIV :: (nat \<Rightarrow> 'a) set) // starrel"

typedef 'a star = "star :: (nat \<Rightarrow> 'a) set set"
  by (auto simp: star_def intro: quotientI)

definition star_n :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a star"
  where "star_n X = Abs_star (starrel `` {X})"

theorem star_cases [case_names star_n, cases type: star]:
  obtains X where "x = star_n X"
  by (cases x) (auto simp: star_n_def star_def elim: quotientE)

lemma all_star_eq: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>X. P (star_n X))"
  by (metis star_cases)

lemma ex_star_eq: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>X. P (star_n X))"
  by (metis star_cases)

text \<open>Proving that \<^term>\<open>starrel\<close> is an equivalence relation.\<close>

lemma starrel_iff [iff]: "(X, Y) \<in> starrel \<longleftrightarrow> eventually (\<lambda>n. X n = Y n) \<U>"
  by (simp add: starrel_def)

lemma equiv_starrel: "equiv UNIV starrel"
proof (rule equivI)
  show "refl starrel" by (simp add: refl_on_def)
  show "sym starrel" by (simp add: sym_def eq_commute)
  show "trans starrel" by (intro transI) (auto elim: eventually_elim2)
qed

lemmas equiv_starrel_iff = eq_equiv_class_iff [OF equiv_starrel UNIV_I UNIV_I]

lemma starrel_in_star: "starrel``{x} \<in> star"
  by (simp add: star_def quotientI)

lemma star_n_eq_iff: "star_n X = star_n Y \<longleftrightarrow> eventually (\<lambda>n. X n = Y n) \<U>"
  by (simp add: star_n_def Abs_star_inject starrel_in_star equiv_starrel_iff)

subsection \<open>Transfer principle\<close>

text \<open>This introduction rule starts each transfer proof.\<close>
lemma transfer_start: "P \<equiv> eventually (\<lambda>n. Q) \<U> \<Longrightarrow> Trueprop P \<equiv> Trueprop Q"
  by (simp add: FreeUltrafilterNat.proper)

text \<open>Standard principles that play a central role in the transfer tactic.\<close>
definition Ifun :: "('a \<Rightarrow> 'b) star \<Rightarrow> 'a star \<Rightarrow> 'b star" (\<open>(_ \<star>/ _)\<close> [300, 301] 300)
  where "Ifun f \<equiv>
    \<lambda>x. Abs_star (\<Union>F\<in>Rep_star f. \<Union>X\<in>Rep_star x. starrel``{\<lambda>n. F n (X n)})"

lemma Ifun_congruent2: "congruent2 starrel starrel (\<lambda>F X. starrel``{\<lambda>n. F n (X n)})"
  by (auto simp add: congruent2_def equiv_starrel_iff elim!: eventually_rev_mp)

lemma Ifun_star_n: "star_n F \<star> star_n X = star_n (\<lambda>n. F n (X n))"
  by (simp add: Ifun_def star_n_def Abs_star_inverse starrel_in_star
      UN_equiv_class2 [OF equiv_starrel equiv_starrel Ifun_congruent2])

lemma transfer_Ifun: "f \<equiv> star_n F \<Longrightarrow> x \<equiv> star_n X \<Longrightarrow> f \<star> x \<equiv> star_n (\<lambda>n. F n (X n))"
  by (simp only: Ifun_star_n)

definition star_of :: "'a \<Rightarrow> 'a star"
  where "star_of x \<equiv> star_n (\<lambda>n. x)"

text \<open>Initialize transfer tactic.\<close>
ML_file \<open>transfer_principle.ML\<close>

method_setup transfer =
  \<open>Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (Transfer_Principle.transfer_tac ctxt ths))\<close>
  "transfer principle"

text \<open>Transfer introduction rules.\<close>

lemma transfer_ex [transfer_intro]:
  "(\<And>X. p (star_n X) \<equiv> eventually (\<lambda>n. P n (X n)) \<U>) \<Longrightarrow>
    \<exists>x::'a star. p x \<equiv> eventually (\<lambda>n. \<exists>x. P n x) \<U>"
  by (simp only: ex_star_eq eventually_ex)

lemma transfer_all [transfer_intro]:
  "(\<And>X. p (star_n X) \<equiv> eventually (\<lambda>n. P n (X n)) \<U>) \<Longrightarrow>
    \<forall>x::'a star. p x \<equiv> eventually (\<lambda>n. \<forall>x. P n x) \<U>"
  by (simp only: all_star_eq FreeUltrafilterNat.eventually_all_iff)

lemma transfer_not [transfer_intro]: "p \<equiv> eventually P \<U> \<Longrightarrow> \<not> p \<equiv> eventually (\<lambda>n. \<not> P n) \<U>"
  by (simp only: FreeUltrafilterNat.eventually_not_iff)

lemma transfer_conj [transfer_intro]:
  "p \<equiv> eventually P \<U> \<Longrightarrow> q \<equiv> eventually Q \<U> \<Longrightarrow> p \<and> q \<equiv> eventually (\<lambda>n. P n \<and> Q n) \<U>"
  by (simp only: eventually_conj_iff)

lemma transfer_disj [transfer_intro]:
  "p \<equiv> eventually P \<U> \<Longrightarrow> q \<equiv> eventually Q \<U> \<Longrightarrow> p \<or> q \<equiv> eventually (\<lambda>n. P n \<or> Q n) \<U>"
  by (simp only: FreeUltrafilterNat.eventually_disj_iff)

lemma transfer_imp [transfer_intro]:
  "p \<equiv> eventually P \<U> \<Longrightarrow> q \<equiv> eventually Q \<U> \<Longrightarrow> p \<longrightarrow> q \<equiv> eventually (\<lambda>n. P n \<longrightarrow> Q n) \<U>"
  by (simp only: FreeUltrafilterNat.eventually_imp_iff)

lemma transfer_iff [transfer_intro]:
  "p \<equiv> eventually P \<U> \<Longrightarrow> q \<equiv> eventually Q \<U> \<Longrightarrow> p = q \<equiv> eventually (\<lambda>n. P n = Q n) \<U>"
  by (simp only: FreeUltrafilterNat.eventually_iff_iff)

lemma transfer_if_bool [transfer_intro]:
  "p \<equiv> eventually P \<U> \<Longrightarrow> x \<equiv> eventually X \<U> \<Longrightarrow> y \<equiv> eventually Y \<U> \<Longrightarrow>
    (if p then x else y) \<equiv> eventually (\<lambda>n. if P n then X n else Y n) \<U>"
  by (simp only: if_bool_eq_conj transfer_conj transfer_imp transfer_not)

lemma transfer_eq [transfer_intro]:
  "x \<equiv> star_n X \<Longrightarrow> y \<equiv> star_n Y \<Longrightarrow> x = y \<equiv> eventually (\<lambda>n. X n = Y n) \<U>"
  by (simp only: star_n_eq_iff)

lemma transfer_if [transfer_intro]:
  "p \<equiv> eventually (\<lambda>n. P n) \<U> \<Longrightarrow> x \<equiv> star_n X \<Longrightarrow> y \<equiv> star_n Y \<Longrightarrow>
    (if p then x else y) \<equiv> star_n (\<lambda>n. if P n then X n else Y n)"
  by (rule eq_reflection) (auto simp: star_n_eq_iff transfer_not elim!: eventually_mono)

lemma transfer_fun_eq [transfer_intro]:
  "(\<And>X. f (star_n X) = g (star_n X) \<equiv> eventually (\<lambda>n. F n (X n) = G n (X n)) \<U>) \<Longrightarrow>
    f = g \<equiv> eventually (\<lambda>n. F n = G n) \<U>"
  by (simp only: fun_eq_iff transfer_all)

lemma transfer_star_n [transfer_intro]: "star_n X \<equiv> star_n (\<lambda>n. X n)"
  by (rule reflexive)

lemma transfer_bool [transfer_intro]: "p \<equiv> eventually (\<lambda>n. p) \<U>"
  by (simp add: FreeUltrafilterNat.proper)

subsection \<open>Standard elements\<close>

definition Standard :: "'a star set"
  where "Standard = range star_of"

text \<open>Transfer tactic should remove occurrences of \<^term>\<open>star_of\<close>.\<close>
setup \<open>Transfer_Principle.add_const \<^const_name>\<open>star_of\<close>\<close>

lemma star_of_inject: "star_of x = star_of y \<longleftrightarrow> x = y"
  by transfer (rule refl)

lemma Standard_star_of [simp]: "star_of x \<in> Standard"
  by (simp add: Standard_def)

subsection \<open>Internal functions\<close>

text \<open>Transfer tactic should remove occurrences of \<^term>\<open>Ifun\<close>.\<close>
setup \<open>Transfer_Principle.add_const \<^const_name>\<open>Ifun\<close>\<close>

lemma Ifun_star_of [simp]: "star_of f \<star> star_of x = star_of (f x)"
  by transfer (rule refl)

lemma Standard_Ifun [simp]: "f \<in> Standard \<Longrightarrow> x \<in> Standard \<Longrightarrow> f \<star> x \<in> Standard"
  by (auto simp add: Standard_def)

text \<open>Nonstandard extensions of functions.\<close>

definition starfun :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a star \<Rightarrow> 'b star"  (\<open>*f* _\<close> [80] 80)
  where "starfun f \<equiv> \<lambda>x. star_of f \<star> x"

definition starfun2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a star \<Rightarrow> 'b star \<Rightarrow> 'c star"  (\<open>*f2* _\<close> [80] 80)
  where "starfun2 f \<equiv> \<lambda>x y. star_of f \<star> x \<star> y"

declare starfun_def [transfer_unfold]
declare starfun2_def [transfer_unfold]

lemma starfun_star_n: "( *f* f) (star_n X) = star_n (\<lambda>n. f (X n))"
  by (simp only: starfun_def star_of_def Ifun_star_n)

lemma starfun2_star_n: "( *f2* f) (star_n X) (star_n Y) = star_n (\<lambda>n. f (X n) (Y n))"
  by (simp only: starfun2_def star_of_def Ifun_star_n)

lemma starfun_star_of [simp]: "( *f* f) (star_of x) = star_of (f x)"
  by transfer (rule refl)

lemma starfun2_star_of [simp]: "( *f2* f) (star_of x) = *f* f x"
  by transfer (rule refl)

lemma Standard_starfun [simp]: "x \<in> Standard \<Longrightarrow> starfun f x \<in> Standard"
  by (simp add: starfun_def)

lemma Standard_starfun2 [simp]: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> starfun2 f x y \<in> Standard"
  by (simp add: starfun2_def)

lemma Standard_starfun_iff:
  assumes inj: "\<And>x y. f x = f y \<Longrightarrow> x = y"
  shows "starfun f x \<in> Standard \<longleftrightarrow> x \<in> Standard"
proof
  assume "x \<in> Standard"
  then show "starfun f x \<in> Standard" by simp
next
  from inj have inj': "\<And>x y. starfun f x = starfun f y \<Longrightarrow> x = y"
    by transfer
  assume "starfun f x \<in> Standard"
  then obtain b where b: "starfun f x = star_of b"
    unfolding Standard_def ..
  then have "\<exists>x. starfun f x = star_of b" ..
  then have "\<exists>a. f a = b" by transfer
  then obtain a where "f a = b" ..
  then have "starfun f (star_of a) = star_of b" by transfer
  with b have "starfun f x = starfun f (star_of a)" by simp
  then have "x = star_of a" by (rule inj')
  then show "x \<in> Standard" by (simp add: Standard_def)
qed

lemma Standard_starfun2_iff:
  assumes inj: "\<And>a b a' b'. f a b = f a' b' \<Longrightarrow> a = a' \<and> b = b'"
  shows "starfun2 f x y \<in> Standard \<longleftrightarrow> x \<in> Standard \<and> y \<in> Standard"
proof
  assume "x \<in> Standard \<and> y \<in> Standard"
  then show "starfun2 f x y \<in> Standard" by simp
next
  have inj': "\<And>x y z w. starfun2 f x y = starfun2 f z w \<Longrightarrow> x = z \<and> y = w"
    using inj by transfer
  assume "starfun2 f x y \<in> Standard"
  then obtain c where c: "starfun2 f x y = star_of c"
    unfolding Standard_def ..
  then have "\<exists>x y. starfun2 f x y = star_of c" by auto
  then have "\<exists>a b. f a b = c" by transfer
  then obtain a b where "f a b = c" by auto
  then have "starfun2 f (star_of a) (star_of b) = star_of c" by transfer
  with c have "starfun2 f x y = starfun2 f (star_of a) (star_of b)" by simp
  then have "x = star_of a \<and> y = star_of b" by (rule inj')
  then show "x \<in> Standard \<and> y \<in> Standard" by (simp add: Standard_def)
qed

subsection \<open>Internal predicates\<close>

definition unstar :: "bool star \<Rightarrow> bool"
  where "unstar b \<longleftrightarrow> b = star_of True"

lemma unstar_star_n: "unstar (star_n P) \<longleftrightarrow> eventually P \<U>"
  by (simp add: unstar_def star_of_def star_n_eq_iff)

lemma unstar_star_of [simp]: "unstar (star_of p) = p"
  by (simp add: unstar_def star_of_inject)

text \<open>Transfer tactic should remove occurrences of \<^term>\<open>unstar\<close>.\<close>
setup \<open>Transfer_Principle.add_const \<^const_name>\<open>unstar\<close>\<close>

lemma transfer_unstar [transfer_intro]: "p \<equiv> star_n P \<Longrightarrow> unstar p \<equiv> eventually P \<U>"
  by (simp only: unstar_star_n)

definition starP :: "('a \<Rightarrow> bool) \<Rightarrow> 'a star \<Rightarrow> bool"  (\<open>*p* _\<close> [80] 80)
  where "*p* P = (\<lambda>x. unstar (star_of P \<star> x))"

definition starP2 :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a star \<Rightarrow> 'b star \<Rightarrow> bool"  (\<open>*p2* _\<close> [80] 80)
  where "*p2* P = (\<lambda>x y. unstar (star_of P \<star> x \<star> y))"

declare starP_def [transfer_unfold]
declare starP2_def [transfer_unfold]

lemma starP_star_n: "( *p* P) (star_n X) = eventually (\<lambda>n. P (X n)) \<U>"
  by (simp only: starP_def star_of_def Ifun_star_n unstar_star_n)

lemma starP2_star_n: "( *p2* P) (star_n X) (star_n Y) = (eventually (\<lambda>n. P (X n) (Y n)) \<U>)"
  by (simp only: starP2_def star_of_def Ifun_star_n unstar_star_n)

lemma starP_star_of [simp]: "( *p* P) (star_of x) = P x"
  by transfer (rule refl)

lemma starP2_star_of [simp]: "( *p2* P) (star_of x) = *p* P x"
  by transfer (rule refl)

subsection \<open>Internal sets\<close>

definition Iset :: "'a set star \<Rightarrow> 'a star set"
  where "Iset A = {x. ( *p2* (\<in>)) x A}"

lemma Iset_star_n: "(star_n X \<in> Iset (star_n A)) = (eventually (\<lambda>n. X n \<in> A n) \<U>)"
  by (simp add: Iset_def starP2_star_n)

text \<open>Transfer tactic should remove occurrences of \<^term>\<open>Iset\<close>.\<close>
setup \<open>Transfer_Principle.add_const \<^const_name>\<open>Iset\<close>\<close>

lemma transfer_mem [transfer_intro]:
  "x \<equiv> star_n X \<Longrightarrow> a \<equiv> Iset (star_n A) \<Longrightarrow> x \<in> a \<equiv> eventually (\<lambda>n. X n \<in> A n) \<U>"
  by (simp only: Iset_star_n)

lemma transfer_Collect [transfer_intro]:
  "(\<And>X. p (star_n X) \<equiv> eventually (\<lambda>n. P n (X n)) \<U>) \<Longrightarrow>
    Collect p \<equiv> Iset (star_n (\<lambda>n. Collect (P n)))"
  by (simp add: atomize_eq set_eq_iff all_star_eq Iset_star_n)

lemma transfer_set_eq [transfer_intro]:
  "a \<equiv> Iset (star_n A) \<Longrightarrow> b \<equiv> Iset (star_n B) \<Longrightarrow> a = b \<equiv> eventually (\<lambda>n. A n = B n) \<U>"
  by (simp only: set_eq_iff transfer_all transfer_iff transfer_mem)

lemma transfer_ball [transfer_intro]:
  "a \<equiv> Iset (star_n A) \<Longrightarrow> (\<And>X. p (star_n X) \<equiv> eventually (\<lambda>n. P n (X n)) \<U>) \<Longrightarrow>
    \<forall>x\<in>a. p x \<equiv> eventually (\<lambda>n. \<forall>x\<in>A n. P n x) \<U>"
  by (simp only: Ball_def transfer_all transfer_imp transfer_mem)

lemma transfer_bex [transfer_intro]:
  "a \<equiv> Iset (star_n A) \<Longrightarrow> (\<And>X. p (star_n X) \<equiv> eventually (\<lambda>n. P n (X n)) \<U>) \<Longrightarrow>
    \<exists>x\<in>a. p x \<equiv> eventually (\<lambda>n. \<exists>x\<in>A n. P n x) \<U>"
  by (simp only: Bex_def transfer_ex transfer_conj transfer_mem)

lemma transfer_Iset [transfer_intro]: "a \<equiv> star_n A \<Longrightarrow> Iset a \<equiv> Iset (star_n (\<lambda>n. A n))"
  by simp

text \<open>Nonstandard extensions of sets.\<close>

definition starset :: "'a set \<Rightarrow> 'a star set" (\<open>*s* _\<close> [80] 80)
  where "starset A = Iset (star_of A)"

declare starset_def [transfer_unfold]

lemma starset_mem: "star_of x \<in> *s* A \<longleftrightarrow> x \<in> A"
  by transfer (rule refl)

lemma starset_UNIV: "*s* (UNIV::'a set) = (UNIV::'a star set)"
  by (transfer UNIV_def) (rule refl)

lemma starset_empty: "*s* {} = {}"
  by (transfer empty_def) (rule refl)

lemma starset_insert: "*s* (insert x A) = insert (star_of x) ( *s* A)"
  by (transfer insert_def Un_def) (rule refl)

lemma starset_Un: "*s* (A \<union> B) = *s* A \<union> *s* B"
  by (transfer Un_def) (rule refl)

lemma starset_Int: "*s* (A \<inter> B) = *s* A \<inter> *s* B"
  by (transfer Int_def) (rule refl)

lemma starset_Compl: "*s* -A = -( *s* A)"
  by (transfer Compl_eq) (rule refl)

lemma starset_diff: "*s* (A - B) = *s* A - *s* B"
  by (transfer set_diff_eq) (rule refl)

lemma starset_image: "*s* (f ` A) = ( *f* f) ` ( *s* A)"
  by (transfer image_def) (rule refl)

lemma starset_vimage: "*s* (f -` A) = ( *f* f) -` ( *s* A)"
  by (transfer vimage_def) (rule refl)

lemma starset_subset: "( *s* A \<subseteq> *s* B) \<longleftrightarrow> A \<subseteq> B"
  by (transfer subset_eq) (rule refl)

lemma starset_eq: "( *s* A = *s* B) \<longleftrightarrow> A = B"
  by transfer (rule refl)

lemmas starset_simps [simp] =
  starset_mem     starset_UNIV
  starset_empty   starset_insert
  starset_Un      starset_Int
  starset_Compl   starset_diff
  starset_image   starset_vimage
  starset_subset  starset_eq

subsection \<open>Syntactic classes\<close>

instantiation star :: (zero) zero
begin
  definition star_zero_def: "0 \<equiv> star_of 0"
  instance ..
end

instantiation star :: (one) one
begin
  definition star_one_def: "1 \<equiv> star_of 1"
  instance ..
end

instantiation star :: (plus) plus
begin
  definition star_add_def: "(+) \<equiv> *f2* (+)"
  instance ..
end

instantiation star :: (times) times
begin
  definition star_mult_def: "((*)) \<equiv> *f2* ((*))"
  instance ..
end

instantiation star :: (uminus) uminus
begin
  definition star_minus_def: "uminus \<equiv> *f* uminus"
  instance ..
end

instantiation star :: (minus) minus
begin
  definition star_diff_def: "(-) \<equiv> *f2* (-)"
  instance ..
end

instantiation star :: (abs) abs
begin
  definition star_abs_def: "abs \<equiv> *f* abs"
  instance ..
end

instantiation star :: (sgn) sgn
begin
  definition star_sgn_def: "sgn \<equiv> *f* sgn"
  instance ..
end

instantiation star :: (divide) divide
begin
  definition star_divide_def:  "divide \<equiv> *f2* divide"
  instance ..
end

instantiation star :: (inverse) inverse
begin
  definition star_inverse_def: "inverse \<equiv> *f* inverse"
  instance ..
end

instance star :: (Rings.dvd) Rings.dvd ..

instantiation star :: (modulo) modulo
begin
  definition star_mod_def: "(mod) \<equiv> *f2* (mod)"
  instance ..
end

instantiation star :: (ord) ord
begin
  definition star_le_def: "(\<le>) \<equiv> *p2* (\<le>)"
  definition star_less_def: "(<) \<equiv> *p2* (<)"
  instance ..
end

lemmas star_class_defs [transfer_unfold] =
  star_zero_def     star_one_def
  star_add_def      star_diff_def     star_minus_def
  star_mult_def     star_divide_def   star_inverse_def
  star_le_def       star_less_def     star_abs_def       star_sgn_def
  star_mod_def

text \<open>Class operations preserve standard elements.\<close>

lemma Standard_zero: "0 \<in> Standard"
  by (simp add: star_zero_def)

lemma Standard_one: "1 \<in> Standard"
  by (simp add: star_one_def)

lemma Standard_add: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> x + y \<in> Standard"
  by (simp add: star_add_def)

lemma Standard_diff: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> x - y \<in> Standard"
  by (simp add: star_diff_def)

lemma Standard_minus: "x \<in> Standard \<Longrightarrow> - x \<in> Standard"
  by (simp add: star_minus_def)

lemma Standard_mult: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> x * y \<in> Standard"
  by (simp add: star_mult_def)

lemma Standard_divide: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> x / y \<in> Standard"
  by (simp add: star_divide_def)

lemma Standard_inverse: "x \<in> Standard \<Longrightarrow> inverse x \<in> Standard"
  by (simp add: star_inverse_def)

lemma Standard_abs: "x \<in> Standard \<Longrightarrow> \<bar>x\<bar> \<in> Standard"
  by (simp add: star_abs_def)

lemma Standard_mod: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> x mod y \<in> Standard"
  by (simp add: star_mod_def)

lemmas Standard_simps [simp] =
  Standard_zero  Standard_one
  Standard_add   Standard_diff    Standard_minus
  Standard_mult  Standard_divide  Standard_inverse
  Standard_abs   Standard_mod

text \<open>\<^term>\<open>star_of\<close> preserves class operations.\<close>

lemma star_of_add: "star_of (x + y) = star_of x + star_of y"
  by transfer (rule refl)

lemma star_of_diff: "star_of (x - y) = star_of x - star_of y"
  by transfer (rule refl)

lemma star_of_minus: "star_of (-x) = - star_of x"
  by transfer (rule refl)

lemma star_of_mult: "star_of (x * y) = star_of x * star_of y"
  by transfer (rule refl)

lemma star_of_divide: "star_of (x / y) = star_of x / star_of y"
  by transfer (rule refl)

lemma star_of_inverse: "star_of (inverse x) = inverse (star_of x)"
  by transfer (rule refl)

lemma star_of_mod: "star_of (x mod y) = star_of x mod star_of y"
  by transfer (rule refl)

lemma star_of_abs: "star_of \<bar>x\<bar> = \<bar>star_of x\<bar>"
  by transfer (rule refl)

text \<open>\<^term>\<open>star_of\<close> preserves numerals.\<close>

lemma star_of_zero: "star_of 0 = 0"
  by transfer (rule refl)

lemma star_of_one: "star_of 1 = 1"
  by transfer (rule refl)

text \<open>\<^term>\<open>star_of\<close> preserves orderings.\<close>

lemma star_of_less: "(star_of x < star_of y) = (x < y)"
by transfer (rule refl)

lemma star_of_le: "(star_of x \<le> star_of y) = (x \<le> y)"
by transfer (rule refl)

lemma star_of_eq: "(star_of x = star_of y) = (x = y)"
by transfer (rule refl)

text \<open>As above, for \<open>0\<close>.\<close>

lemmas star_of_0_less = star_of_less [of 0, simplified star_of_zero]
lemmas star_of_0_le   = star_of_le   [of 0, simplified star_of_zero]
lemmas star_of_0_eq   = star_of_eq   [of 0, simplified star_of_zero]

lemmas star_of_less_0 = star_of_less [of _ 0, simplified star_of_zero]
lemmas star_of_le_0   = star_of_le   [of _ 0, simplified star_of_zero]
lemmas star_of_eq_0   = star_of_eq   [of _ 0, simplified star_of_zero]

text \<open>As above, for \<open>1\<close>.\<close>

lemmas star_of_1_less = star_of_less [of 1, simplified star_of_one]
lemmas star_of_1_le   = star_of_le   [of 1, simplified star_of_one]
lemmas star_of_1_eq   = star_of_eq   [of 1, simplified star_of_one]

lemmas star_of_less_1 = star_of_less [of _ 1, simplified star_of_one]
lemmas star_of_le_1   = star_of_le   [of _ 1, simplified star_of_one]
lemmas star_of_eq_1   = star_of_eq   [of _ 1, simplified star_of_one]

lemmas star_of_simps [simp] =
  star_of_add     star_of_diff    star_of_minus
  star_of_mult    star_of_divide  star_of_inverse
  star_of_mod     star_of_abs
  star_of_zero    star_of_one
  star_of_less    star_of_le      star_of_eq
  star_of_0_less  star_of_0_le    star_of_0_eq
  star_of_less_0  star_of_le_0    star_of_eq_0
  star_of_1_less  star_of_1_le    star_of_1_eq
  star_of_less_1  star_of_le_1    star_of_eq_1

subsection \<open>Ordering and lattice classes\<close>

instance star :: (order) order
proof
  show "\<And>x y::'a star. (x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by transfer (rule less_le_not_le)
  show "\<And>x::'a star. x \<le> x"
    by transfer (rule order_refl)
  show "\<And>x y z::'a star. \<lbrakk>x \<le> y; y \<le> z\<rbrakk> \<Longrightarrow> x \<le> z"
    by transfer (rule order_trans)
  show "\<And>x y::'a star. \<lbrakk>x \<le> y; y \<le> x\<rbrakk> \<Longrightarrow> x = y"
    by transfer (rule order_antisym)
qed

instantiation star :: (semilattice_inf) semilattice_inf
begin
  definition star_inf_def [transfer_unfold]: "inf \<equiv> *f2* inf"
  instance by (standard; transfer) auto
end

instantiation star :: (semilattice_sup) semilattice_sup
begin
  definition star_sup_def [transfer_unfold]: "sup \<equiv> *f2* sup"
  instance by (standard; transfer) auto
end

instance star :: (lattice) lattice ..

instance star :: (distrib_lattice) distrib_lattice
  by (standard; transfer) (auto simp add: sup_inf_distrib1)

lemma Standard_inf [simp]: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> inf x y \<in> Standard"
  by (simp add: star_inf_def)

lemma Standard_sup [simp]: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> sup x y \<in> Standard"
  by (simp add: star_sup_def)

lemma star_of_inf [simp]: "star_of (inf x y) = inf (star_of x) (star_of y)"
  by transfer (rule refl)

lemma star_of_sup [simp]: "star_of (sup x y) = sup (star_of x) (star_of y)"
  by transfer (rule refl)

instance star :: (linorder) linorder
  by (intro_classes, transfer, rule linorder_linear)

lemma star_max_def [transfer_unfold]: "max = *f2* max"
  unfolding max_def
  by (intro ext, transfer, simp)

lemma star_min_def [transfer_unfold]: "min = *f2* min"
  unfolding min_def
  by (intro ext, transfer, simp)

lemma Standard_max [simp]: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> max x y \<in> Standard"
  by (simp add: star_max_def)

lemma Standard_min [simp]: "x \<in> Standard \<Longrightarrow> y \<in> Standard \<Longrightarrow> min x y \<in> Standard"
  by (simp add: star_min_def)

lemma star_of_max [simp]: "star_of (max x y) = max (star_of x) (star_of y)"
  by transfer (rule refl)

lemma star_of_min [simp]: "star_of (min x y) = min (star_of x) (star_of y)"
  by transfer (rule refl)

subsection \<open>Ordered group classes\<close>

instance star :: (semigroup_add) semigroup_add
  by (intro_classes, transfer, rule add.assoc)

instance star :: (ab_semigroup_add) ab_semigroup_add
  by (intro_classes, transfer, rule add.commute)

instance star :: (semigroup_mult) semigroup_mult
  by (intro_classes, transfer, rule mult.assoc)

instance star :: (ab_semigroup_mult) ab_semigroup_mult
  by (intro_classes, transfer, rule mult.commute)

instance star :: (comm_monoid_add) comm_monoid_add
  by (intro_classes, transfer, rule comm_monoid_add_class.add_0)

instance star :: (monoid_mult) monoid_mult
  apply intro_classes
   apply (transfer, rule mult_1_left)
  apply (transfer, rule mult_1_right)
  done

instance star :: (power) power ..

instance star :: (comm_monoid_mult) comm_monoid_mult
  by (intro_classes, transfer, rule mult_1)

instance star :: (cancel_semigroup_add) cancel_semigroup_add
  apply intro_classes
   apply (transfer, erule add_left_imp_eq)
  apply (transfer, erule add_right_imp_eq)
  done

instance star :: (cancel_ab_semigroup_add) cancel_ab_semigroup_add
  by intro_classes (transfer, simp add: diff_diff_eq)+

instance star :: (cancel_comm_monoid_add) cancel_comm_monoid_add ..

instance star :: (ab_group_add) ab_group_add
  apply intro_classes
   apply (transfer, rule left_minus)
  apply (transfer, rule diff_conv_add_uminus)
  done

instance star :: (ordered_ab_semigroup_add) ordered_ab_semigroup_add
  by (intro_classes, transfer, rule add_left_mono)

instance star :: (ordered_cancel_ab_semigroup_add) ordered_cancel_ab_semigroup_add ..

instance star :: (ordered_ab_semigroup_add_imp_le) ordered_ab_semigroup_add_imp_le
  by (intro_classes, transfer, rule add_le_imp_le_left)

instance star :: (ordered_comm_monoid_add) ordered_comm_monoid_add ..
instance star :: (ordered_ab_semigroup_monoid_add_imp_le) ordered_ab_semigroup_monoid_add_imp_le ..
instance star :: (ordered_cancel_comm_monoid_add) ordered_cancel_comm_monoid_add ..
instance star :: (ordered_ab_group_add) ordered_ab_group_add ..

instance star :: (ordered_ab_group_add_abs) ordered_ab_group_add_abs
  by intro_classes (transfer, simp add: abs_ge_self abs_leI abs_triangle_ineq)+

instance star :: (linordered_cancel_ab_semigroup_add) linordered_cancel_ab_semigroup_add ..

subsection \<open>Ring and field classes\<close>

instance star :: (semiring) semiring
  by (intro_classes; transfer) (fact distrib_right distrib_left)+

instance star :: (semiring_0) semiring_0
  by (intro_classes; transfer) simp_all

instance star :: (semiring_0_cancel) semiring_0_cancel ..

instance star :: (comm_semiring) comm_semiring
  by (intro_classes; transfer) (fact distrib_right)

instance star :: (comm_semiring_0) comm_semiring_0 ..
instance star :: (comm_semiring_0_cancel) comm_semiring_0_cancel ..

instance star :: (zero_neq_one) zero_neq_one
  by (intro_classes; transfer) (fact zero_neq_one)

instance star :: (semiring_1) semiring_1 ..
instance star :: (comm_semiring_1) comm_semiring_1 ..

declare dvd_def [transfer_refold]

instance star :: (comm_semiring_1_cancel) comm_semiring_1_cancel
  by (intro_classes; transfer) (fact right_diff_distrib')

instance star :: (semiring_no_zero_divisors) semiring_no_zero_divisors
  by (intro_classes; transfer) (fact no_zero_divisors)

instance star :: (semiring_1_no_zero_divisors) semiring_1_no_zero_divisors ..

instance star :: (semiring_no_zero_divisors_cancel) semiring_no_zero_divisors_cancel
  by (intro_classes; transfer) simp_all

instance star :: (semiring_1_cancel) semiring_1_cancel ..
instance star :: (ring) ring ..
instance star :: (comm_ring) comm_ring ..
instance star :: (ring_1) ring_1 ..
instance star :: (comm_ring_1) comm_ring_1 ..
instance star :: (semidom) semidom ..

instance star :: (semidom_divide) semidom_divide
  by (intro_classes; transfer) simp_all

instance star :: (ring_no_zero_divisors) ring_no_zero_divisors ..
instance star :: (ring_1_no_zero_divisors) ring_1_no_zero_divisors ..
instance star :: (idom) idom ..
instance star :: (idom_divide) idom_divide ..

instance star :: (division_ring) division_ring
  by (intro_classes; transfer) (simp_all add: divide_inverse)

instance star :: (field) field
  by (intro_classes; transfer) (simp_all add: divide_inverse)

instance star :: (ordered_semiring) ordered_semiring
  by (intro_classes; transfer) (fact mult_left_mono mult_right_mono)+

instance star :: (ordered_cancel_semiring) ordered_cancel_semiring ..

instance star :: (linordered_semiring_strict) linordered_semiring_strict
  by (intro_classes; transfer) (fact mult_strict_left_mono mult_strict_right_mono)+

instance star :: (ordered_comm_semiring) ordered_comm_semiring
  by (intro_classes; transfer) (fact mult_left_mono)

instance star :: (ordered_cancel_comm_semiring) ordered_cancel_comm_semiring ..

instance star :: (linordered_comm_semiring_strict) linordered_comm_semiring_strict
  by (intro_classes; transfer) (fact mult_strict_left_mono)

instance star :: (ordered_ring) ordered_ring ..

instance star :: (ordered_ring_abs) ordered_ring_abs
  by (intro_classes; transfer) (fact abs_eq_mult)

instance star :: (abs_if) abs_if
  by (intro_classes; transfer) (fact abs_if)

instance star :: (linordered_ring_strict) linordered_ring_strict ..
instance star :: (ordered_comm_ring) ordered_comm_ring ..

instance star :: (linordered_semidom) linordered_semidom
  by (intro_classes; transfer) (fact zero_less_one le_add_diff_inverse2)+

instance star :: (linordered_idom) linordered_idom
  by (intro_classes; transfer) (fact sgn_if)

instance star :: (linordered_field) linordered_field ..

instance star :: (algebraic_semidom) algebraic_semidom ..

instantiation star :: (normalization_semidom) normalization_semidom
begin

definition unit_factor_star :: "'a star \<Rightarrow> 'a star"
  where [transfer_unfold]: "unit_factor_star = *f* unit_factor"

definition normalize_star :: "'a star \<Rightarrow> 'a star"
  where [transfer_unfold]: "normalize_star = *f* normalize"

instance
  by standard (transfer; simp add: is_unit_unit_factor unit_factor_mult)+

end

instance star :: (semidom_modulo) semidom_modulo
  by standard (transfer; simp)

subsection \<open>Power\<close>

lemma star_power_def [transfer_unfold]: "(^) \<equiv> \<lambda>x n. ( *f* (\<lambda>x. x ^ n)) x"
proof (rule eq_reflection, rule ext, rule ext)
  show "x ^ n = ( *f* (\<lambda>x. x ^ n)) x" for n :: nat and x :: "'a star"
  proof (induct n arbitrary: x)
    case 0
    have "\<And>x::'a star. ( *f* (\<lambda>x. 1)) x = 1"
      by transfer simp
    then show ?case by simp
  next
    case (Suc n)
    have "\<And>x::'a star. x * ( *f* (\<lambda>x::'a. x ^ n)) x = ( *f* (\<lambda>x::'a. x * x ^ n)) x"
      by transfer simp
    with Suc show ?case by simp
  qed
qed

lemma Standard_power [simp]: "x \<in> Standard \<Longrightarrow> x ^ n \<in> Standard"
  by (simp add: star_power_def)

lemma star_of_power [simp]: "star_of (x ^ n) = star_of x ^ n"
  by transfer (rule refl)

subsection \<open>Number classes\<close>

instance star :: (numeral) numeral ..

lemma star_numeral_def [transfer_unfold]: "numeral k = star_of (numeral k)"
  by (induct k) (simp_all only: numeral.simps star_of_one star_of_add)

lemma Standard_numeral [simp]: "numeral k \<in> Standard"
  by (simp add: star_numeral_def)

lemma star_of_numeral [simp]: "star_of (numeral k) = numeral k"
  by transfer (rule refl)

lemma star_of_nat_def [transfer_unfold]: "of_nat n = star_of (of_nat n)"
  by (induct n) simp_all

lemmas star_of_compare_numeral [simp] =
  star_of_less [of "numeral k", simplified star_of_numeral]
  star_of_le   [of "numeral k", simplified star_of_numeral]
  star_of_eq   [of "numeral k", simplified star_of_numeral]
  star_of_less [of _ "numeral k", simplified star_of_numeral]
  star_of_le   [of _ "numeral k", simplified star_of_numeral]
  star_of_eq   [of _ "numeral k", simplified star_of_numeral]
  star_of_less [of "- numeral k", simplified star_of_numeral]
  star_of_le   [of "- numeral k", simplified star_of_numeral]
  star_of_eq   [of "- numeral k", simplified star_of_numeral]
  star_of_less [of _ "- numeral k", simplified star_of_numeral]
  star_of_le   [of _ "- numeral k", simplified star_of_numeral]
  star_of_eq   [of _ "- numeral k", simplified star_of_numeral] for k

lemma Standard_of_nat [simp]: "of_nat n \<in> Standard"
  by (simp add: star_of_nat_def)

lemma star_of_of_nat [simp]: "star_of (of_nat n) = of_nat n"
  by transfer (rule refl)

lemma star_of_int_def [transfer_unfold]: "of_int z = star_of (of_int z)"
  by (rule int_diff_cases [of z]) simp

lemma Standard_of_int [simp]: "of_int z \<in> Standard"
  by (simp add: star_of_int_def)

lemma star_of_of_int [simp]: "star_of (of_int z) = of_int z"
  by transfer (rule refl)

instance star :: (semiring_char_0) semiring_char_0
proof
  have "inj (star_of :: 'a \<Rightarrow> 'a star)"
    by (rule injI) simp
  then have "inj (star_of \<circ> of_nat :: nat \<Rightarrow> 'a star)"
    using inj_of_nat by (rule inj_compose)
  then show "inj (of_nat :: nat \<Rightarrow> 'a star)"
    by (simp add: comp_def)
qed

instance star :: (ring_char_0) ring_char_0 ..

subsection \<open>Finite class\<close>

lemma starset_finite: "finite A \<Longrightarrow> *s* A = star_of ` A"
  by (erule finite_induct) simp_all

instance star :: (finite) finite
proof intro_classes
  show "finite (UNIV::'a star set)"
    by (metis starset_UNIV finite finite_imageI starset_finite)
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_bin_plus_assoc
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

theorem property0 :
  "((plus x (plus y z)) = (plus (plus x y) z))"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_NStoogeSortSorts
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun reverse :: "'a list => 'a list" where
"reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
"minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

(*fun did not finish the proof*)
function third :: "Nat => Nat" where
"third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
"length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
"le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun ordered :: "Nat list => bool" where
"ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((le z y2) & (ordered (cons2 y2 xs)))"

fun sort2 :: "Nat => Nat => Nat list" where
"sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
"take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun drop :: "Nat => 'a list => 'a list" where
"drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function nstooge1sort2 :: "Nat list => Nat list"
         and nstoogesort :: "Nat list => Nat list"
         and nstooge1sort1 :: "Nat list => Nat list" where
"nstooge1sort2 y =
   (case splitAt (third (length y)) (reverse y) of
      pair2 ys2 zs2 => x (nstoogesort zs2) (reverse ys2))"
| "nstoogesort (nil2) = nil2"
| "nstoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge1sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort zs1))"
by pat_completeness auto

theorem property0 :
  "ordered (nstoogesort xs)"
  oops

end


theory Topped
  imports Main
begin

datatype 'a top = Top | NotTop 'a

abbreviation bind :: "('a \<Rightarrow> 'b top) \<Rightarrow> 'a top \<Rightarrow> 'b top" (infixr "\<hookleftarrow>" 56)  where
  "bind f x \<equiv> case x of Top \<Rightarrow> Top | NotTop x \<Rightarrow> f x"

lemma top_left_id: "f \<hookleftarrow> NotTop x = f x"
  by simp

lemma top_right_id: "NotTop \<hookleftarrow> x = x"
  by (cases x) auto

lemma top_assoc: "g \<hookleftarrow> f \<hookleftarrow> x = (\<lambda>x. g \<hookleftarrow> (f x)) \<hookleftarrow> x"
  by (cases x) auto

instantiation top :: (ord) ord
begin
  definition less_eq_top :: "'a top \<Rightarrow> 'a top \<Rightarrow> bool" where
    "x \<le> y \<equiv> case y of Top \<Rightarrow> True | NotTop y \<Rightarrow> case x of Top \<Rightarrow> False | NotTop x \<Rightarrow> x \<le> y"

  definition less_top :: "'a top \<Rightarrow> 'a top \<Rightarrow> bool" where
    "less_top x y \<equiv> x \<le> y \<and> \<not> (y \<le> x)"

  instance by default
end

instance top :: (order) order
proof
  fix x y z :: "'a top"
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (simp add: less_top_def)
  show "x \<le> x"
    by (cases x) (auto simp add: less_eq_top_def)
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    apply (cases x)
    apply (cases y, cases z, (force simp add: less_eq_top_def)+)
    apply (cases y, cases z, (force simp add: less_eq_top_def)+)
    by (cases z, (force simp add: less_eq_top_def)+)
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x) (cases y, (force simp add: less_eq_top_def)+)+
qed

lemma [simp, intro!]: "x \<le> Top"
  by (simp add: less_eq_top_def)

lemma NotTop_mono: "x \<le> y \<Longrightarrow> NotTop x \<le> NotTop y"
  by (auto simp add: less_eq_top_def)

lemma [simp]: "NotTop x \<le> NotTop y \<longleftrightarrow> x \<le> y"
  by (auto simp add: less_eq_top_def)

instantiation top :: (lattice) lattice
begin
  definition sup_top :: "'a top \<Rightarrow> 'a top \<Rightarrow> 'a top" where
    "sup_top x y \<equiv> case x of Top \<Rightarrow> Top | NotTop x \<Rightarrow> (case y of Top \<Rightarrow> Top | NotTop y \<Rightarrow> NotTop (sup x y))"

  definition inf_top :: "'a top \<Rightarrow> 'a top \<Rightarrow> 'a top" where
    "inf_top x y \<equiv> case x of Top \<Rightarrow> y | NotTop x \<Rightarrow> (case y of Top \<Rightarrow> NotTop x | NotTop y \<Rightarrow> NotTop (inf x y))"

  lemma [simp]: "inf Top y = y"
    by (simp add: inf_top_def)

  lemma [simp]: "inf x Top = x"
    by (cases x) (simp_all add: inf_top_def)

  lemma [simp]: "inf (NotTop x) (NotTop y) = NotTop (inf x y)"
    by (simp add: inf_top_def)

  lemma [simp]: "sup Top y = Top"
    by (simp add: sup_top_def)

  lemma [simp]: "sup x Top = Top"
    by (cases x) (simp_all add: sup_top_def)

  lemma [simp]: "sup (NotTop x) (NotTop y) = NotTop (sup x y)"
    by (simp add: sup_top_def)

  instance
  proof
    fix x y z :: "'a top"
    show "inf x y \<le> x"
      by (simp add: inf_top_def, cases x, simp, cases y, auto)
    show "inf x y \<le> y"
      by (simp add: inf_top_def, cases x, simp, cases y, auto)
    show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> inf y z"
      by (cases x, simp, cases y, simp, cases z, auto)
    show "x \<le> sup x y"
      by (cases x, simp, cases y, auto)
    show "y \<le> sup x y"
      by (cases x, simp, cases y, auto)
    show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> sup y z \<le> x"
      by (cases x, simp, cases y, simp, cases z, auto)
  qed
end

instantiation top :: (complete_lattice) complete_lattice
begin
  definition Inf_top :: "'a top set \<Rightarrow> 'a top" where "Inf_top X \<equiv> if X \<subseteq> {Top} then Top else NotTop (Inf {x. NotTop x \<in> X})"

  definition Sup_top :: "'a top set \<Rightarrow> 'a top" where "Sup_top X \<equiv> if Top \<in> X then Top else NotTop (Sup {x. NotTop x \<in> X})"

  definition top_top :: "'a top" where "top_top = Top"

  definition bot_top :: "'a top" where "bot_top = NotTop bot"

  instance
  proof
    fix a :: "'a top"
    show "a \<le> top"
      by (cases a) (auto simp add: top_top_def less_eq_top_def)
    show "bot \<le> a"
      by (cases a) (auto simp add: bot_top_def less_eq_top_def)
  next
    fix x :: "'a top" and A :: "'a top set"
    assume xA: "x \<in> A"
    show "Inf A \<le> x" using xA
      by (cases x) (auto intro: Inf_lower simp: Inf_top_def)
    show "x \<le> Sup A" using xA
      by (cases x) (auto intro: Sup_upper simp add: Sup_top_def less_eq_top_def)
  next
    fix z :: "'a top" and A :: "'a top set"
    assume "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
    thus "z \<le> Inf A"
      apply (cases z)
      apply (auto simp add: Inf_top_def)
      by (metis (lifting, no_types) le_Inf_iff less_eq_top_def mem_Collect_eq top.simps(5))
  next
    fix z :: "'a top" and A :: "'a top set"
    assume "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
    thus "Sup A \<le> z"
      apply (cases z)
      apply (auto intro!: Sup_least simp add: Sup_top_def less_eq_top_def)
      apply (metis top.simps(4))
      by (metis (full_types) top.simps(5))
  qed
end

lemma top_bind [simp]: "f \<hookleftarrow> top = top" by (simp add: top_top_def)

lemma [simp]: "NotTop x = bot \<longleftrightarrow> x = {}"
  by (simp add: bot_top_def)

lemmas Top_top = top_top_def[symmetric]

end