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{apunte_st} 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)"

txt\<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)
  (* Proof that \<^term>\<open>fun_factor\<close> respects membership *)
  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
  (* Proof of type *)
  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
      (* Proof that f O ?g respects membership *)
  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_range f_type
    unfolding fun_factor_def by auto
qed

end (* cofinal_factor *)

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_range 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_range 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_range 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)
  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)
      (********************************************************)
  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 (* includes *)

end


(*  Title:       Utilities for Lambda-Free Orders
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Utilities for Lambda-Free Orders\<close>

theory Lambda_Free_Util
imports "HOL-Library.Extended_Nat" "HOL-Library.Multiset_Order"
begin

text \<open>
This theory gathers various lemmas that likely belong elsewhere in Isabelle or
the \emph{Archive of Formal Proofs}. Most (but certainly not all) of them are
used to formalize orders on \<open>\<lambda>\<close>-free higher-order terms.
\<close>

hide_const (open) Complex.arg

subsection \<open>Finite Sets\<close>

lemma finite_set_fold_singleton[simp]: "Finite_Set.fold f z {x} = f x z"
proof -
  have "fold_graph f z {x} (f x z)"
    by (auto intro: fold_graph.intros)
  moreover
  {
    fix X y
    have "fold_graph f z X y \<Longrightarrow> (X = {} \<longrightarrow> y = z) \<and> (X = {x} \<longrightarrow> y = f x z)"
      by (induct rule: fold_graph.induct) auto
  }
  ultimately have "(THE y. fold_graph f z {x} y) = f x z"
    by blast
  thus ?thesis
    by (simp add: Finite_Set.fold_def)
qed

subsection \<open>Function Power\<close>

lemma funpow_lesseq_iter:
  fixes f :: "('a::order) \<Rightarrow> 'a"
  assumes mono: "\<And>k. k \<le> f k" and m_le_n: "m \<le> n"
  shows "(f ^^ m) k \<le> (f ^^ n) k"
  using m_le_n by (induct n) (fastforce simp: le_Suc_eq intro: mono order_trans)+

lemma funpow_less_iter:
  fixes f :: "('a::order) \<Rightarrow> 'a"
  assumes mono: "\<And>k. k < f k" and m_lt_n: "m < n"
  shows "(f ^^ m) k < (f ^^ n) k"
  using m_lt_n by (induct n) (auto, blast intro: mono less_trans dest: less_antisym)

subsection \<open>Least Operator\<close>

lemma Least_eq[simp]: "(LEAST y. y = x) = x" and "(LEAST y. x = y) = x" for x :: "'a::order"
  by (blast intro: Least_equality)+

lemma Least_in_nonempty_set_imp_ex:
  fixes f :: "'b \<Rightarrow> ('a::wellorder)"
  assumes
    A_nemp: "A \<noteq> {}" and
    P_least: "P (LEAST y. \<exists>x \<in> A. y = f x)"
  shows "\<exists>x \<in> A. P (f x)"
proof -
  obtain a where a: "a \<in> A"
    using A_nemp by fast
  have "\<exists>x. x \<in> A \<and> (LEAST y. \<exists>x. x \<in> A \<and> y = f x) = f x"
    by (rule LeastI[of _ "f a"]) (fast intro: a)
  thus ?thesis
    by (metis P_least)
qed

lemma Least_eq_0_enat: "P 0 \<Longrightarrow> (LEAST x :: enat. P x) = 0"
  by (simp add: Least_equality)

subsection \<open>Antisymmetric Relations\<close>

lemma irrefl_trans_imp_antisym: "irrefl r \<Longrightarrow> trans r \<Longrightarrow> antisym r"
  unfolding irrefl_def trans_def antisym_def by fast

lemma irreflp_transp_imp_antisymP: "irreflp p \<Longrightarrow> transp p \<Longrightarrow> antisymp p"
  by (fact irrefl_trans_imp_antisym [to_pred])

subsection \<open>Acyclic Relations\<close>

lemma finite_nonempty_ex_succ_imp_cyclic:
  assumes
    fin: "finite A" and
    nemp: "A \<noteq> {}" and
    ex_y: "\<forall>x \<in> A. \<exists>y \<in> A. (y, x) \<in> r"
  shows "\<not> acyclic r"
proof -
  let ?R = "{(x, y). x \<in> A \<and> y \<in> A \<and> (x, y) \<in> r}"

  have R_sub_r: "?R \<subseteq> r"
    by auto

  have "?R \<subseteq> A \<times> A"
    by auto
  hence fin_R: "finite ?R"
    by (auto intro: fin dest!: infinite_super)

  have "\<not> acyclic ?R"
    by (rule notI, drule finite_acyclic_wf[OF fin_R], unfold wf_eq_minimal, drule spec[of _ A],
      use ex_y nemp in blast)
  thus ?thesis
    using R_sub_r acyclic_subset by auto
qed

subsection \<open>Reflexive, Transitive Closure\<close>

lemma relcomp_subset_left_imp_relcomp_trancl_subset_left:
  assumes sub: "R O S \<subseteq> R"
  shows "R O S\<^sup>* \<subseteq> R"
proof
  fix x
  assume "x \<in> R O S\<^sup>*"
  then obtain n where "x \<in> R O S ^^ n"
    using rtrancl_imp_relpow by fastforce
  thus "x \<in> R"
  proof (induct n)
    case (Suc m)
    thus ?case
      by (metis (no_types) O_assoc inf_sup_ord(3) le_iff_sup relcomp_distrib2 relpow.simps(2)
        relpow_commute sub subsetCE)
  qed auto
qed

lemma f_chain_in_rtrancl:
  assumes m_le_n: "m \<le> n" and f_chain: "\<forall>i \<in> {m..<n}. (f i, f (Suc i)) \<in> R"
  shows "(f m, f n) \<in> R\<^sup>*"
proof (rule relpow_imp_rtrancl, rule relpow_fun_conv[THEN iffD2], intro exI conjI)
  let ?g = "\<lambda>i. f (m + i)"
  let ?k = "n - m"

  show "?g 0 = f m"
    by simp
  show "?g ?k = f n"
    using m_le_n by force
  show "(\<forall>i < ?k. (?g i, ?g (Suc i)) \<in> R)"
    by (simp add: f_chain)
qed

lemma f_rev_chain_in_rtrancl:
  assumes m_le_n: "m \<le> n" and f_chain: "\<forall>i \<in> {m..<n}. (f (Suc i), f i) \<in> R"
  shows "(f n, f m) \<in> R\<^sup>*"
  by (rule f_chain_in_rtrancl[OF m_le_n, of "\<lambda>i. f (n + m - i)", simplified])
    (metis f_chain le_add_diff Suc_diff_Suc Suc_leI atLeastLessThan_iff diff_Suc_diff_eq1 diff_less
      le_add1 less_le_trans zero_less_Suc)

subsection \<open>Well-Founded Relations\<close>

lemma wf_app: "wf r \<Longrightarrow> wf {(x, y). (f x, f y) \<in> r}"
  unfolding wf_eq_minimal by (intro allI, drule spec[of _ "f ` Q" for Q]) fast

lemma wfP_app: "wfP p \<Longrightarrow> wfP (\<lambda>x y. p (f x) (f y))"
  unfolding wfP_def by (rule wf_app[of "{(x, y). p x y}" f, simplified])

lemma wf_exists_minimal:
  assumes wf: "wf r" and Q: "Q x"
  shows "\<exists>x. Q x \<and> (\<forall>y. (f y, f x) \<in> r \<longrightarrow> \<not> Q y)"
  using wf_eq_minimal[THEN iffD1, OF wf_app[OF wf], rule_format, of _ "{x. Q x}", simplified, OF Q]
  by blast

lemma wfP_exists_minimal:
  assumes wf: "wfP p" and Q: "Q x"
  shows "\<exists>x. Q x \<and> (\<forall>y. p (f y) (f x) \<longrightarrow> \<not> Q y)"
  by (rule wf_exists_minimal[of "{(x, y). p x y}" Q x, OF wf[unfolded wfP_def] Q, simplified])

lemma finite_irrefl_trans_imp_wf: "finite r \<Longrightarrow> irrefl r \<Longrightarrow> trans r \<Longrightarrow> wf r"
  by (erule finite_acyclic_wf) (simp add: acyclic_irrefl)

lemma finite_irreflp_transp_imp_wfp:
  "finite {(x, y). p x y} \<Longrightarrow> irreflp p \<Longrightarrow> transp p \<Longrightarrow> wfP p"
  using finite_irrefl_trans_imp_wf[of "{(x, y). p x y}"]
  unfolding wfP_def transp_def irreflp_def trans_def irrefl_def mem_Collect_eq prod.case
  by assumption

lemma wf_infinite_down_chain_compatible:
  assumes
    wf_R: "wf R" and
    inf_chain_RS: "\<forall>i. (f (Suc i), f i) \<in> R \<union> S" and
    O_subset: "R O S \<subseteq> R"
  shows "\<exists>k. \<forall>i. (f (Suc (i + k)), f (i + k)) \<in> S"
proof (rule ccontr)
  assume "\<nexists>k. \<forall>i. (f (Suc (i + k)), f (i + k)) \<in> S"
  hence "\<forall>k. \<exists>i. (f (Suc (i + k)), f (i + k)) \<notin> S"
    by blast
  hence "\<forall>k. \<exists>i > k. (f (Suc i), f i) \<notin> S"
    by (metis add.commute add_Suc less_add_Suc1)
  hence "\<forall>k. \<exists>i > k. (f (Suc i), f i) \<in> R"
    using inf_chain_RS by blast
  hence "\<exists>i > k. (f (Suc i), f i) \<in> R \<and> (\<forall>j > k. (f (Suc j), f j) \<in> R \<longrightarrow> j \<ge> i)" for k
    using wf_eq_minimal[THEN iffD1, OF wf_less, rule_format,
      of _ "{i. i > k \<and> (f (Suc i), f i) \<in> R}", simplified]
    by (meson not_less)
  then obtain j_of where
    j_of_gt: "\<And>k. j_of k > k" and
    j_of_in_R: "\<And>k. (f (Suc (j_of k)), f (j_of k)) \<in> R" and
    j_of_min: "\<And>k. \<forall>j > k. (f (Suc j), f j) \<in> R \<longrightarrow> j \<ge> j_of k"
    by moura

  have j_of_min_s: "\<And>k j. j > k \<Longrightarrow> j < j_of k \<Longrightarrow> (f (Suc j), f j) \<in> S"
    using j_of_min inf_chain_RS by fastforce

  define g :: "nat \<Rightarrow> 'a" where "\<And>k. g k = f (Suc ((j_of ^^ k) 0))"

  have between_g[simplified]: "(f ((j_of ^^ (Suc i)) 0), f (Suc ((j_of ^^ i) 0))) \<in> S\<^sup>*" for i
  proof (rule f_rev_chain_in_rtrancl; clarify?)
    show "Suc ((j_of ^^ i) 0) \<le> (j_of ^^ Suc i) 0"
      using j_of_gt by (simp add: Suc_leI)
  next
    fix ia
    assume ia: "ia \<in> {Suc ((j_of ^^ i) 0)..<(j_of ^^ Suc i) 0}"
    have ia_gt: "ia > (j_of ^^ i) 0"
      using ia by auto
    have ia_lt: "ia < j_of ((j_of ^^ i) 0)"
      using ia by auto
    show "(f (Suc ia), f ia) \<in> S"
      by (rule j_of_min_s[OF ia_gt ia_lt])
  qed

  have "\<And>i. (g (Suc i), g i) \<in> R"
    unfolding g_def funpow.simps comp_def
    by (rule subsetD[OF relcomp_subset_left_imp_relcomp_trancl_subset_left[OF O_subset]])
      (rule relcompI[OF j_of_in_R between_g])
  moreover have "\<forall>f. \<exists>i. (f (Suc i), f i) \<notin> R"
    using wf_R[unfolded wf_iff_no_infinite_down_chain] by blast
  ultimately show False
    by blast
qed

subsection \<open>Wellorders\<close>

lemma (in wellorder) exists_minimal:
  fixes x :: 'a
  assumes "P x"
  shows "\<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> y \<ge> x)"
  using assms by (auto intro: LeastI Least_le)

subsection \<open>Lists\<close>

lemma rev_induct2[consumes 1, case_names Nil snoc]:
  "length xs = length ys \<Longrightarrow> P [] [] \<Longrightarrow>
   (\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (xs @ [x]) (ys @ [y])) \<Longrightarrow> P xs ys"
proof (induct xs arbitrary: ys rule: rev_induct)
  case (snoc x xs ys)
  thus ?case
    by (induct ys rule: rev_induct) simp_all
qed auto

lemma in_lists_iff_set: "xs \<in> lists A \<longleftrightarrow> set xs \<subseteq> A"
  by fast

lemma butlast_append_Cons[simp]: "butlast (xs @ y # ys) = xs @ butlast (y # ys)"
  using butlast_append[of xs "y # ys", simplified] by simp

lemma rev_in_lists[simp]: "rev xs \<in> lists A \<longleftrightarrow> xs \<in> lists A"
  by auto

lemma hd_le_sum_list:
  fixes xs :: "'a::ordered_ab_semigroup_monoid_add_imp_le list"
  assumes "xs \<noteq> []" and "\<forall>i < length xs. xs ! i \<ge> 0"
  shows "hd xs \<le> sum_list xs"
  using assms
  by (induct xs rule: rev_induct, simp_all,
    metis add_cancel_right_left add_increasing2 hd_append2 lessI less_SucI list.sel(1) nth_append
      nth_append_length order_refl self_append_conv2 sum_list.Nil)

lemma sum_list_ge_length_times:
  fixes a :: "'a::{ordered_ab_semigroup_add,semiring_1}"
  assumes "\<forall>i < length xs. xs ! i \<ge> a"
  shows "sum_list xs \<ge> of_nat (length xs) * a"
  using assms
proof (induct xs)
  case (Cons x xs)
  note ih = this(1) and xxs_i_ge_a = this(2)

  have xs_i_ge_a: "\<forall>i < length xs. xs ! i \<ge> a"
    using xxs_i_ge_a by auto

  have "x \<ge> a"
    using xxs_i_ge_a by auto
  thus ?case
    using ih[OF xs_i_ge_a] by (simp add: ring_distribs ordered_ab_semigroup_add_class.add_mono)
qed auto

lemma zip_append_0_upt:
  "zip (xs @ ys) [0..<length xs + length ys] =
   zip xs [0..<length xs] @ zip ys [length xs..<length xs + length ys]"
proof (induct ys arbitrary: xs)
  case (Cons y ys)
  note ih = this
  show ?case
    using ih[of "xs @ [y]"] by (simp, cases ys, simp, simp add: upt_rec)
qed auto

lemma zip_eq_butlast_last:
  assumes len_gt0: "length xs > 0" and len_eq: "length xs = length ys"
  shows "zip xs ys = zip (butlast xs) (butlast ys) @ [(last xs, last ys)]"
  using len_eq len_gt0 by (induct rule: list_induct2) auto

subsection \<open>Extended Natural Numbers\<close>

lemma the_enat_0[simp]: "the_enat 0 = 0"
  by (simp add: zero_enat_def)

lemma the_enat_1[simp]: "the_enat 1 = 1"
  by (simp add: one_enat_def)

lemma enat_le_minus_1_imp_lt: "m \<le> n - 1 \<Longrightarrow> n \<noteq> \<infinity> \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> m < n" for m n :: enat
  by (cases m; cases n; simp add: zero_enat_def one_enat_def)

lemma enat_diff_diff_eq: "k - m - n = k - (m + n)" for k m n :: enat
  by (cases k; cases m; cases n) auto

lemma enat_the_enat_iden[simp]: "n \<noteq> \<infinity> \<Longrightarrow> enat (the_enat n) = n"
  by auto

lemma the_enat_minus_nat: "m \<noteq> \<infinity> \<Longrightarrow> the_enat (m - enat n) = the_enat m - n"
  by auto

lemma enat_the_enat_le: "enat (the_enat x) \<le> x"
  by (cases x; simp)

lemma enat_the_enat_minus_le: "enat (the_enat (x - y)) \<le> x"
  by (cases x; cases y; simp)

lemma enat_le_imp_minus_le: "k \<le> m \<Longrightarrow> k - n \<le> m" for k m n :: enat
  by (metis Groups.add_ac(2) enat_diff_diff_eq enat_ord_simps(3) enat_sub_add_same
    enat_the_enat_iden enat_the_enat_minus_le idiff_0_right idiff_infinity idiff_infinity_right
    order_trans_rules(23) plus_enat_simps(3))

lemma add_diff_assoc2_enat: "m \<ge> n \<Longrightarrow> m - n + p = m + p - n" for m n p :: enat
  by (cases m; cases n; cases p; auto)

lemma enat_mult_minus_distrib: "enat x * (y - z) = enat x * y - enat x * z"
  by (cases y; cases z; auto simp: enat_0 right_diff_distrib')

subsection \<open>Multisets\<close>

lemma add_mset_lt_left_lt: "a < b \<Longrightarrow> add_mset a A < add_mset b A"
  unfolding less_multiset\<^sub>H\<^sub>O by auto

lemma add_mset_le_left_le: "a \<le> b \<Longrightarrow> add_mset a A \<le> add_mset b A" for a :: "'a :: linorder"
  unfolding less_multiset\<^sub>H\<^sub>O by auto

lemma add_mset_lt_right_lt: "A < B \<Longrightarrow> add_mset a A < add_mset a B"
  unfolding less_multiset\<^sub>H\<^sub>O by auto

lemma add_mset_le_right_le: "A \<le> B \<Longrightarrow> add_mset a A \<le> add_mset a B"
  unfolding less_multiset\<^sub>H\<^sub>O by auto

lemma add_mset_lt_lt_lt:
  assumes a_lt_b: "a < b" and A_le_B: "A < B"
  shows "add_mset a A < add_mset b B"
  by (rule less_trans[OF add_mset_lt_left_lt[OF a_lt_b] add_mset_lt_right_lt[OF A_le_B]])

lemma add_mset_lt_lt_le: "a < b \<Longrightarrow> A \<le> B \<Longrightarrow> add_mset a A < add_mset b B"
  using add_mset_lt_lt_lt le_neq_trans by fastforce

lemma add_mset_le_le_le:
  fixes a :: "'a :: linorder"
  assumes a_le_b: "a \<le> b" and A_le_B: "A \<le> B"
  shows "add_mset a A \<le> add_mset b B"
  by (rule order.trans[OF add_mset_le_left_le[OF a_le_b] add_mset_le_right_le[OF A_le_B]])

declare filter_eq_replicate_mset [simp] image_mset_subseteq_mono [intro]

lemma nonempty_subseteq_mset_eq_singleton: "M \<noteq> {#} \<Longrightarrow> M \<subseteq># {#x#} \<Longrightarrow> M = {#x#}"
  by (cases M) (auto dest: subset_mset.diff_add)

lemma nonempty_subseteq_mset_iff_singleton: "(M \<noteq> {#} \<and> M \<subseteq># {#x#} \<and> P) \<longleftrightarrow> M = {#x#} \<and> P"
  by (cases M) (auto dest: subset_mset.diff_add)

lemma count_gt_imp_in_mset[intro]: "count M x > n \<Longrightarrow> x \<in># M"
  using count_greater_zero_iff by fastforce

lemma size_lt_imp_ex_count_lt: "size M < size N \<Longrightarrow> \<exists>x \<in># N. count M x < count N x"
  by (metis count_eq_zero_iff leD not_le_imp_less not_less_zero size_mset_mono subseteq_mset_def)

lemma filter_filter_mset[simp]: "{#x \<in># {#x \<in># M. Q x#}. P x#} = {#x \<in># M. P x \<and> Q x#}"
  by (induct M) auto

lemma size_filter_ne_elem: "x \<in># M \<Longrightarrow> size {#y \<in># M. y \<noteq> x#} < size M"
  by (simp add: size_filter_unsat_elem[of x M "\<lambda>y. y \<noteq> x"])

lemma size_eq_ex_count_lt:
  assumes
    sz_m_eq_n: "size M = size N" and
    m_eq_n: "M \<noteq> N"
  shows "\<exists>x. count M x < count N x"
proof -
  obtain x where "count M x \<noteq> count N x"
    using m_eq_n by (meson multiset_eqI)
  moreover
  {
    assume "count M x < count N x"
    hence ?thesis
      by blast
  }
  moreover
  {
    assume cnt_x: "count M x > count N x"

    have "size {#y \<in># M. y = x#} + size {#y \<in># M. y \<noteq> x#} =
      size {#y \<in># N. y = x#} + size {#y \<in># N. y \<noteq> x#}"
      using sz_m_eq_n multiset_partition by (metis size_union)
    hence sz_m_minus_x: "size {#y \<in># M. y \<noteq> x#} < size {#y \<in># N. y \<noteq> x#}"
      using cnt_x by simp
    then obtain y where "count {#y \<in># M. y \<noteq> x#} y < count {#y \<in># N. y \<noteq> x#} y"
      using size_lt_imp_ex_count_lt[OF sz_m_minus_x] by blast
    hence "count M y < count N y"
      by (metis count_filter_mset less_asym)
    hence ?thesis
      by blast
  }
  ultimately show ?thesis
    by fastforce
qed

  let ?Ma = "{#y \<in># M. y \<noteq> x#}"
  let ?Mb = "{#y \<in># M. y = x#}"
  let ?Na = "{#y \<in># N. y \<noteq> x#}"
  let ?Nb = "{#y \<in># N. y = x#}"

  have m_part: "M = ?Mb + ?Ma" and n_part: "N = ?Nb + ?Na"
    using multiset_partition by blast+

  have f_eq_ma_na: "F = set_mset ?Ma \<union> set_mset ?Na"
    using x_f_eq_m_n x_ni_f by auto

  show ?case
  proof (cases "count (image_mset f ?Ma) b < count (image_mset f ?Na) b")
    case cnt_ba: True
    obtain xa where "f xa = b" and "count ?Ma xa < count ?Na xa"
      using ih[OF f_eq_ma_na cnt_ba] by blast
    thus ?thesis
      by (metis count_filter_mset not_less0)
  next
    case cnt_ba: False
    have fx_eq_b: "f x = b"
      using cnt_b cnt_ba by (subst (asm) m_part, subst (asm) n_part, auto, presburger)
    moreover have "count M x < count N x"
      using cnt_b cnt_ba by (subst (asm) m_part, subst (asm) n_part, auto simp: fx_eq_b)
    ultimately show ?thesis
      by blast
  qed
qed auto

lemma count_image_mset_lt_imp_lt:
  assumes cnt_b: "count (image_mset f M) b < count (image_mset f N) b"
  shows "\<exists>x. f x = b \<and> count M x < count N x"
  by (rule count_image_mset_lt_imp_lt_raw[of "set_mset M \<union> set_mset N", OF _ refl cnt_b]) auto

lemma count_image_mset_le_imp_lt_raw:
  assumes
    "finite A" and
    "A = set_mset M \<union> set_mset N" and
    "count (image_mset f M) (f a) + count N a < count (image_mset f N) (f a) + count M a"
  shows "\<exists>b. f b = f a \<and> count M b < count N b"
  using assms
proof (induct A arbitrary: M N rule: finite_induct)
  case (insert x F)
  note fin = this(1) and x_ni_f = this(2) and ih = this(3) and x_f_eq_m_n = this(4) and
    cnt_lt = this(5)

  let ?Ma = "{#y \<in># M. y \<noteq> x#}"
  let ?Mb = "{#y \<in># M. y = x#}"
  let ?Na = "{#y \<in># N. y \<noteq> x#}"
  let ?Nb = "{#y \<in># N. y = x#}"

  have m_part: "M = ?Mb + ?Ma" and n_part: "N = ?Nb + ?Na"
    using multiset_partition by blast+

  have f_eq_ma_na: "F = set_mset ?Ma \<union> set_mset ?Na"
    using x_f_eq_m_n x_ni_f by auto

  show ?case
  proof (cases "f x = f a")
    case fx_ne_fa: False

    have cnt_fma_fa: "count (image_mset f ?Ma) (f a) = count (image_mset f M) (f a)"
      using fx_ne_fa by (subst (2) m_part) auto
    have cnt_fna_fa: "count (image_mset f ?Na) (f a) = count (image_mset f N) (f a)"
      using fx_ne_fa by (subst (2) n_part) auto
    have cnt_ma_a: "count ?Ma a = count M a"
      using fx_ne_fa by (subst (2) m_part) auto
    have cnt_na_a: "count ?Na a = count N a"
      using fx_ne_fa by (subst (2) n_part) auto

    obtain b where fb_eq_fa: "f b = f a" and cnt_b: "count ?Ma b < count ?Na b"
      using ih[OF f_eq_ma_na] cnt_lt unfolding cnt_fma_fa cnt_fna_fa cnt_ma_a cnt_na_a by blast
    have fx_ne_fb: "f x \<noteq> f b"
      using fb_eq_fa fx_ne_fa by simp

    have cnt_ma_b: "count ?Ma b = count M b"
      using fx_ne_fb by (subst (2) m_part) auto
    have cnt_na_b: "count ?Na b = count N b"
      using fx_ne_fb by (subst (2) n_part) auto

    show ?thesis
      using fb_eq_fa cnt_b unfolding cnt_ma_b cnt_na_b by blast
  next
    case fx_eq_fa: True
    show ?thesis
    proof (cases "x = a")
      case x_eq_a: True
      have "count (image_mset f ?Ma) (f a) + count ?Na a
        < count (image_mset f ?Na) (f a) + count ?Ma a"
        using cnt_lt x_eq_a by (subst (asm) (1 2) m_part, subst (asm) (1 2) n_part, auto)
      thus ?thesis
        using ih[OF f_eq_ma_na] by (metis count_filter_mset nat_neq_iff)
    next
      case x_ne_a: False
      show ?thesis
      proof (cases "count M x < count N x")
        case True
        thus ?thesis
          using fx_eq_fa by blast
     next
        case False
        hence cnt_x: "count M x \<ge> count N x"
          by fastforce
        have "count M x + count (image_mset f ?Ma) (f a) + count ?Na a
          < count N x + count (image_mset f ?Na) (f a) + count ?Ma a"
          using cnt_lt x_ne_a fx_eq_fa by (subst (asm) (1 2) m_part, subst (asm) (1 2) n_part, auto)
        hence "count (image_mset f ?Ma) (f a) + count ?Na a
          < count (image_mset f ?Na) (f a) + count ?Ma a"
          using cnt_x by linarith
        thus ?thesis
          using ih[OF f_eq_ma_na] by (metis count_filter_mset nat_neq_iff)
      qed
    qed
  qed
qed auto

lemma count_image_mset_le_imp_lt:
  assumes
    "count (image_mset f M) (f a) \<le> count (image_mset f N) (f a)" and
    "count M a > count N a"
  shows "\<exists>b. f b = f a \<and> count M b < count N b"
  using assms by (auto intro: count_image_mset_le_imp_lt_raw[of "set_mset M \<union> set_mset N"])

lemma Max_in_mset: "M \<noteq> {#} \<Longrightarrow> Max_mset M \<in># M"
  by simp

lemma Max_lt_imp_lt_mset:
  assumes n_nemp: "N \<noteq> {#}" and max: "Max_mset M < Max_mset N" (is "?max_M < ?max_N")
  shows "M < N"
proof (cases "M = {#}")
  case m_nemp: False

  have max_n_in_n: "?max_N \<in># N"
    using n_nemp by simp
  have max_n_nin_m: "?max_N \<notin># M"
    using max Max_ge leD by auto

  have "M \<noteq> N"
    using max by auto
  moreover
  {
    fix y
    assume "count N y < count M y"
    hence "y \<in># M"
      by blast
    hence "?max_M \<ge> y"
      by simp
    hence "?max_N > y"
      using max by auto
    hence "\<exists>x > y. count M x < count N x"
      using max_n_nin_m max_n_in_n by fastforce
  }
  ultimately show ?thesis
    unfolding less_multiset\<^sub>H\<^sub>O by blast
qed (auto simp: n_nemp)

lemma fold_mset_singleton[simp]: "fold_mset f z {#x#} = f x z"
  by (simp add: fold_mset_def)

end


(*  Title       : HLog.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 2000,2001 University of Edinburgh
*)

section{*Logarithms: Non-Standard Version*}

theory HLog
imports HTranscendental
begin

(* should be in NSA.ML *)
lemma epsilon_ge_zero [simp]: "0 \<le> epsilon"
by (simp add: epsilon_def star_n_zero_num star_n_le)

lemma hpfinite_witness: "epsilon : {x. 0 \<le> x & x : HFinite}"
by auto

definition
  powhr  :: "[hypreal,hypreal] => hypreal"     (infixr "powhr" 80) where
  [transfer_unfold]: "x powhr a = starfun2 (op powr) x a"

definition
  hlog :: "[hypreal,hypreal] => hypreal" where
  [transfer_unfold]: "hlog a x = starfun2 log a x"

lemma powhr: "(star_n X) powhr (star_n Y) = star_n (%n. (X n) powr (Y n))"
by (simp add: powhr_def starfun2_star_n)

lemma powhr_one_eq_one [simp]: "!!a. 1 powhr a = 1"
by (transfer, simp)

lemma powhr_mult:
  "!!a x y. [| 0 < x; 0 < y |] ==> (x * y) powhr a = (x powhr a) * (y powhr a)"
by (transfer, rule powr_mult)

lemma powhr_gt_zero [simp]: "!!a x. 0 < x powhr a"
by (transfer, simp)

lemma powhr_not_zero [simp]: "x powhr a \<noteq> 0"
by (metis less_numeral_extra(3) powhr_gt_zero)

lemma powhr_divide:
  "!!a x y. [| 0 < x; 0 < y |] ==> (x / y) powhr a = (x powhr a)/(y powhr a)"
by (transfer, rule powr_divide)

lemma powhr_add: "!!a b x. x powhr (a + b) = (x powhr a) * (x powhr b)"
by (transfer, rule powr_add)

lemma powhr_powhr: "!!a b x. (x powhr a) powhr b = x powhr (a * b)"
by (transfer, rule powr_powr)

lemma powhr_powhr_swap: "!!a b x. (x powhr a) powhr b = (x powhr b) powhr a"
by (transfer, rule powr_powr_swap)

lemma powhr_minus: "!!a x. x powhr (-a) = inverse (x powhr a)"
by (transfer, rule powr_minus)

lemma powhr_minus_divide: "x powhr (-a) = 1/(x powhr a)"
by (simp add: divide_inverse powhr_minus)

lemma powhr_less_mono: "!!a b x. [| a < b; 1 < x |] ==> x powhr a < x powhr b"
by (transfer, simp)

lemma powhr_less_cancel: "!!a b x. [| x powhr a < x powhr b; 1 < x |] ==> a < b"
by (transfer, simp)

lemma powhr_less_cancel_iff [simp]:
     "1 < x ==> (x powhr a < x powhr b) = (a < b)"
by (blast intro: powhr_less_cancel powhr_less_mono)

lemma powhr_le_cancel_iff [simp]:
     "1 < x ==> (x powhr a \<le> x powhr b) = (a \<le> b)"
by (simp add: linorder_not_less [symmetric])

lemma hlog:
     "hlog (star_n X) (star_n Y) =
      star_n (%n. log (X n) (Y n))"
by (simp add: hlog_def starfun2_star_n)

lemma hlog_starfun_ln: "!!x. ( *f* ln) x = hlog (( *f* exp) 1) x"
by (transfer, rule log_ln)

lemma powhr_hlog_cancel [simp]:
     "!!a x. [| 0 < a; a \<noteq> 1; 0 < x |] ==> a powhr (hlog a x) = x"
by (transfer, simp)

lemma hlog_powhr_cancel [simp]:
     "!!a y. [| 0 < a; a \<noteq> 1 |] ==> hlog a (a powhr y) = y"
by (transfer, simp)

lemma hlog_mult:
     "!!a x y. [| 0 < a; a \<noteq> 1; 0 < x; 0 < y  |]
      ==> hlog a (x * y) = hlog a x + hlog a y"
by (transfer, rule log_mult)

lemma hlog_as_starfun:
     "!!a x. [| 0 < a; a \<noteq> 1 |] ==> hlog a x = ( *f* ln) x / ( *f* ln) a"
by (transfer, simp add: log_def)

lemma hlog_eq_div_starfun_ln_mult_hlog:
     "!!a b x. [| 0 < a; a \<noteq> 1; 0 < b; b \<noteq> 1; 0 < x |]
      ==> hlog a x = (( *f* ln) b/( *f*ln) a) * hlog b x"
by (transfer, rule log_eq_div_ln_mult_log)

lemma powhr_as_starfun: "!!a x. x powhr a = ( *f* exp) (a * ( *f* ln) x)"
by (transfer, simp add: powr_def)

lemma HInfinite_powhr:
     "[| x : HInfinite; 0 < x; a : HFinite - Infinitesimal;
         0 < a |] ==> x powhr a : HInfinite"
apply (auto intro!: starfun_ln_ge_zero starfun_ln_HInfinite HInfinite_HFinite_not_Infinitesimal_mult2 starfun_exp_HInfinite
       simp add: order_less_imp_le HInfinite_gt_zero_gt_one powhr_as_starfun zero_le_mult_iff)
done

lemma hlog_hrabs_HInfinite_Infinitesimal:
     "[| x : HFinite - Infinitesimal; a : HInfinite; 0 < a |]
      ==> hlog a (abs x) : Infinitesimal"
apply (frule HInfinite_gt_zero_gt_one)
apply (auto intro!: starfun_ln_HFinite_not_Infinitesimal
            HInfinite_inverse_Infinitesimal Infinitesimal_HFinite_mult2
        simp add: starfun_ln_HInfinite not_Infinitesimal_not_zero
          hlog_as_starfun divide_inverse)
done

lemma hlog_HInfinite_as_starfun:
     "[| a : HInfinite; 0 < a |] ==> hlog a x = ( *f* ln) x / ( *f* ln) a"
by (rule hlog_as_starfun, auto)

lemma hlog_one [simp]: "!!a. hlog a 1 = 0"
by (transfer, simp)

lemma hlog_eq_one [simp]: "!!a. [| 0 < a; a \<noteq> 1 |] ==> hlog a a = 1"
by (transfer, rule log_eq_one)

lemma hlog_inverse:
     "[| 0 < a; a \<noteq> 1; 0 < x |] ==> hlog a (inverse x) = - hlog a x"
apply (rule add_left_cancel [of "hlog a x", THEN iffD1])
apply (simp add: hlog_mult [symmetric])
done

lemma hlog_divide:
     "[| 0 < a; a \<noteq> 1; 0 < x; 0 < y|] ==> hlog a (x/y) = hlog a x - hlog a y"
by (simp add: hlog_mult hlog_inverse divide_inverse)

lemma hlog_less_cancel_iff [simp]:
     "!!a x y. [| 1 < a; 0 < x; 0 < y |] ==> (hlog a x < hlog a y) = (x < y)"
by (transfer, simp)

lemma hlog_le_cancel_iff [simp]:
     "[| 1 < a; 0 < x; 0 < y |] ==> (hlog a x \<le> hlog a y) = (x \<le> y)"
by (simp add: linorder_not_less [symmetric])

end


(*  Author:     Tobias Nipkow
*)

header {* More Rotation *}

theory Rotation
imports ListAux PlaneGraphIso
begin

definition rotate_to :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"rotate_to vs v \<equiv>  v # snd (splitAt v vs) @ fst (splitAt v vs)"

definition rotate_min :: "nat list \<Rightarrow> nat list" where
"rotate_min vs \<equiv> rotate_to vs (min_list vs)"

lemma cong_rotate_to:
 "x \<in> set xs \<Longrightarrow> xs \<cong> rotate_to xs x"
proof -
  assume x: "x \<in> set xs"
  hence ls1: "xs = fst (splitAt x xs) @ x # snd (splitAt x xs)" by (auto dest: splitAt_ram)
  def i \<equiv> "length(fst(splitAt x xs))"
  hence "i < length((fst(splitAt x xs)) @ [x] @ snd(splitAt x xs))" by auto
  with ls1 have i_len: "i < length xs" by auto
  hence ls2: "xs = take i xs @ xs!i # drop (Suc i) xs" by (auto intro: id_take_nth_drop)
  from i_len have "length (take i xs) = i" by auto
  with i_def have len_eq: "length(take i xs) = length(fst(splitAt x xs))" by auto
  moreover
  from ls1 ls2 have eq: "take i xs @ xs!i # drop (Suc i) xs = fst(splitAt x xs) @ x # snd(splitAt x xs)" by simp
  ultimately have
    v_simp: "x = xs!i" and
    take_i: "fst(splitAt x xs) = take i xs" and
    drop_i': "snd(splitAt x xs) = drop (Suc i) xs" by auto
  from i_len have ls3: "xs = take i xs @ drop i xs" by auto
  with take_i have eq: "xs = fst(splitAt x xs) @ drop i xs" by auto
  with ls1 have "fst(splitAt x xs) @ drop i xs = fst(splitAt x xs) @ x # snd(splitAt x xs)" by auto
  then have drop_i: "drop i xs = x # snd(splitAt x xs)" by auto
  have "rotate i xs = drop (i mod length xs) xs @ take (i mod length xs) xs" by (rule rotate_drop_take)
  with i_len have "rotate i xs = drop i xs @ take i xs" by auto
  with take_i drop_i have "rotate i xs = (x # snd(splitAt x xs)) @ fst(splitAt x xs)" by auto
  thus ?thesis apply (auto simp: congs_def rotate_to_def) apply (rule exI) apply (rule sym) .
qed

lemma face_cong_if_norm_eq:
 "\<lbrakk> rotate_min xs = rotate_min ys; xs \<noteq> []; ys \<noteq> [] \<rbrakk> \<Longrightarrow> xs \<cong> ys"
apply(simp add:rotate_min_def)
apply(subgoal_tac "xs \<cong> rotate_to xs (Min (set xs))")
 apply(subgoal_tac "ys \<cong> rotate_to ys (Min (set ys))")
  apply(simp) apply(blast intro:congs_sym congs_trans)
 apply(simp add: cong_rotate_to)
apply(drule sym)
apply(simp add: cong_rotate_to)
done

lemma norm_eq_if_face_cong:
  "\<lbrakk> xs \<cong> ys; distinct xs; xs \<noteq> [] \<rbrakk> \<Longrightarrow> rotate_min xs = rotate_min ys"
by(auto simp:congs_def rotate_min_def rotate_to_def
  splitAt_rotate_pair_conv insert_absorb)

lemma norm_eq_iff_face_cong:
 "\<lbrakk> distinct xs; xs \<noteq> []; ys \<noteq> [] \<rbrakk> \<Longrightarrow>
  (rotate_min xs = rotate_min ys) = (xs \<cong> ys)"
by(blast intro: face_cong_if_norm_eq norm_eq_if_face_cong)

lemma inj_on_rotate_min_iff:
assumes "\<forall>vs \<in> A. distinct vs"  "[] \<notin> A"
shows "inj_on rotate_min A = inj_on (\<lambda>vs. {vs}//{\<cong>}) A"
proof -
  { fix xs ys assume xs: "xs \<in> A" and ys : "ys \<in> A"
    hence "xs \<noteq> [] \<and> ys \<noteq> []" using assms(2) by blast
    hence "(rotate_min xs = rotate_min ys) = (xs \<cong> ys)"
      using xs assms(1)
      by(simp add: singleton_list_cong_eq_iff norm_eq_iff_face_cong)
  } thus ?thesis by(simp add:inj_on_def)
qed

end


(* Title:     MiniML/MiniML.thy
   Author:    Dieter Nazareth, Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
*)

section "MiniML with type inference rules"

theory MiniML
imports Generalize
begin

\<comment> \<open>expressions\<close>
datatype
  expr = Var nat | Abs expr | App expr expr | LET expr expr

\<comment> \<open>type inference rules\<close>
inductive
  has_type :: "[ctxt, expr, typ] => bool"
                  ("((_) \<turnstile>/ (_) :: (_))" [60,0,60] 60)
where
  VarI: "[| n < length A; t <| A!n |] ==> A \<turnstile> Var n :: t"
| AbsI: "[| (mk_scheme t1)#A \<turnstile> e :: t2 |] ==> A \<turnstile> Abs e :: t1 -> t2"
| AppI: "[| A \<turnstile> e1 :: t2 -> t1; A \<turnstile> e2 :: t2 |]
         ==> A \<turnstile> App e1 e2 :: t1"
| LETI: "[| A \<turnstile> e1 :: t1; (gen A t1)#A \<turnstile> e2 :: t |] ==> A \<turnstile> LET e1 e2 :: t"

declare has_type.intros [simp]
declare Un_upper1 [simp] Un_upper2 [simp]
declare is_bound_typ_instance_closed_subst [simp]

lemma s'_t_equals_s_t[simp]:
  "\<And>t::typ. $(\<lambda>n. if n : (free_tv A) Un (free_tv t) then (S n) else (TVar n)) t = $S t"
apply (rule typ_substitutions_only_on_free_variables)
apply (simp add: Ball_def)
done

lemma s'_a_equals_s_a [simp]:
  "\<And>A::type_scheme list. $(\<lambda>n. if n : (free_tv A) Un (free_tv t) then (S n) else (TVar n)) A = $S A"
apply (rule scheme_list_substitutions_only_on_free_variables)
apply (simp add: Ball_def)
done

lemma replace_s_by_s':
 "$(\<lambda>n. if n : (free_tv A) Un (free_tv t) then S n else TVar n) A \<turnstile>
     e :: $(\<lambda>n. if n : (free_tv A) Un (free_tv t) then S n else TVar n) t
  \<Longrightarrow> $S A \<turnstile> e :: $S t"
apply (rule_tac P = "\<lambda>A. A \<turnstile> e :: $S t" in ssubst)
apply (rule s'_a_equals_s_a [symmetric])
apply (rule_tac P = "\<lambda>t. $ (\<lambda>n. if n : free_tv A Un free_tv (t2 S) then S n else TVar n) A \<turnstile> e :: t" for t2 in ssubst)
apply (rule s'_t_equals_s_t [symmetric])
apply simp
done

lemma alpha_A':
  "\<And>A::type_scheme list. $ (\<lambda>x. TVar (if x : free_tv A then x else n + x)) A = $ id_subst A"
apply (rule scheme_list_substitutions_only_on_free_variables)
apply (simp add: id_subst_def)
done

lemma alpha_A:
  "\<And>A::type_scheme list. $ (\<lambda>x. TVar (if x : free_tv A then x else n + x)) A = A"
apply (rule alpha_A' [THEN ssubst])
apply simp
done

lemma S_o_alpha_typ:
  "$ (S \<circ> alpha) (t::typ) = $ S ($ (\<lambda>x. TVar (alpha x)) t)"
apply (induct_tac "t")
apply (simp_all)
done

lemma S_o_alpha_typ':
  "$ (\<lambda>u. (S \<circ> alpha) u) (t::typ) = $ S ($ (\<lambda>x. TVar (alpha x)) t)"
apply (induct_tac "t")
apply (simp_all)
done

lemma S_o_alpha_type_scheme:
  "$ (S \<circ> alpha) (sch::type_scheme) = $ S ($ (\<lambda>x. TVar (alpha x)) sch)"
apply (induct_tac "sch")
apply (simp_all)
done

lemma S_o_alpha_type_scheme_list:
  "$ (S \<circ> alpha) (A::type_scheme list) = $ S ($ (\<lambda>x. TVar (alpha x)) A)"
apply (induct_tac "A")
apply (simp_all)
apply (rule S_o_alpha_type_scheme [unfolded o_def])
done

lemma S'_A_eq_S'_alpha_A: "\<And>A::type_scheme list.
      $ (\<lambda>n. if n : free_tv A Un free_tv t then S n else TVar n) A =
      $ ((\<lambda>x. if x : free_tv A Un free_tv t then S x else TVar x) \<circ>
         (\<lambda>x. if x : free_tv A then x else n + x)) A"
apply (subst S_o_alpha_type_scheme_list)
apply (subst alpha_A)
apply (rule refl)
done

lemma dom_S':
 "dom (\<lambda>n. if n : free_tv A Un free_tv t then S n else TVar n) \<subseteq>
  free_tv A Un free_tv t"
apply (unfold free_tv_subst dom_def)
apply (simp (no_asm))
apply fast
done

lemma cod_S':
  "\<And>(A::type_scheme list) (t::typ).
   cod (\<lambda>n. if n : free_tv A Un free_tv t then S n else TVar n) \<subseteq>
   free_tv ($ S A) Un free_tv ($ S t)"
apply (unfold free_tv_subst cod_def subset_eq)
apply (rule ballI)
apply (erule UN_E)
apply (drule dom_S' [THEN subsetD])
apply simp
apply (fast dest: free_tv_of_substitutions_extend_to_scheme_lists intro: free_tv_of_substitutions_extend_to_types [THEN subsetD])
done

lemma free_tv_S':
 "\<And>(A::type_scheme list) (t::typ).
  free_tv (\<lambda>n. if n : free_tv A Un free_tv t then S n else TVar n) \<subseteq>
  free_tv A Un free_tv ($ S A) Un free_tv t Un free_tv ($ S t)"
apply (unfold free_tv_subst)
apply (fast dest: dom_S' [THEN subsetD] cod_S' [THEN subsetD])
done

lemma free_tv_alpha: "\<And>t1::typ.
      (free_tv ($ (\<lambda>x. TVar (if x : free_tv A then x else n + x)) t1) - free_tv A) \<subseteq>
          {x. \<exists>y. x = n + y}"
apply (induct_tac "t1")
apply (simp (no_asm))
apply fast
apply (simp (no_asm))
apply fast
done

lemma new_tv_Int_free_tv_empty_type: "\<And>t::typ. new_tv n t \<Longrightarrow> {x. \<exists>y. x = n + y} \<inter> free_tv t = {}"
apply safe
apply (cut_tac le_add1)
apply (drule new_tv_le)
apply assumption
apply (rotate_tac 1)
apply (drule new_tv_not_free_tv)
apply fast
done

lemma new_tv_Int_free_tv_empty_scheme:
  "\<And>sch::type_scheme. new_tv n sch \<Longrightarrow> {x. \<exists>y. x = n + y} \<inter> free_tv sch = {}"
apply safe
apply (cut_tac le_add1)
apply (drule new_tv_le)
apply assumption
apply (rotate_tac 1)
apply (drule new_tv_not_free_tv)
apply fast
done

lemma new_tv_Int_free_tv_empty_scheme_list:
  "\<forall>A::type_scheme list. new_tv n A \<longrightarrow> {x. \<exists>y. x = n + y} \<inter> free_tv A = {}"
apply (rule allI)
apply (induct_tac "A")
apply (simp (no_asm))
apply (simp (no_asm))
apply (fast dest: new_tv_Int_free_tv_empty_scheme)
done

lemma gen_t_le_gen_alpha_t [rule_format (no_asm)]:
   "new_tv n A \<longrightarrow> gen A t \<le> gen A ($ (\<lambda>x. TVar (if x : free_tv A then x else n + x)) t)"
apply (unfold le_type_scheme_def is_bound_typ_instance)
apply (intro strip)
apply (erule exE)
apply (hypsubst)
apply (rule_tac x = " (\<lambda>x. S (if n \<le> x then x - n else x))" in exI)
apply (induct_tac t)
apply (simp (no_asm))
apply (rename_tac nat)
apply (case_tac "nat : free_tv A")
apply (simp (no_asm_simp))
apply (subgoal_tac "n \<le> n + nat")
apply (drule new_tv_le)
apply assumption
apply (drule new_tv_not_free_tv)
apply (drule new_tv_not_free_tv)
apply (simp (no_asm_simp) add: diff_add_inverse)
apply (simp (no_asm))
apply (simp (no_asm_simp))
done

declare has_type.intros [intro!]

lemma has_type_le_env [rule_format (no_asm)]: "A \<turnstile> e::t \<Longrightarrow> \<forall>B. A \<le> B \<longrightarrow> B \<turnstile> e::t"
apply (erule has_type.induct)
   apply (simp (no_asm) add: le_env_def)
   apply (fastforce elim: bound_typ_instance_trans)
  apply simp
 apply fast
apply (slow elim: le_env_free_tv [THEN free_tv_subset_gen_le])
done

\<comment> \<open>@{text has_type} is closed w.r.t. substitution\<close>
lemma has_type_cl_sub: "A \<turnstile> e :: t \<Longrightarrow> \<forall>S. $S A \<turnstile> e :: $S t"
apply (erule has_type.induct)
(* case VarI *)
   apply (rule allI)
   apply (rule has_type.VarI)
    apply (simp add: app_subst_list)
   apply (simp (no_asm_simp) add: app_subst_list)
  (* case AbsI *)
  apply (rule allI)
  apply (simp (no_asm))
  apply (rule has_type.AbsI)
  apply simp
 (* case AppI *)
 apply (rule allI)
 apply (rule has_type.AppI)
  apply simp
  apply (erule spec)
 apply (erule spec)
(* case LetI *)
apply (rule allI)
apply (rule replace_s_by_s')
apply (cut_tac A = "$ S A" and A' = "A" and t = "t" and t' = "$ S t" in ex_fresh_variable)
apply (erule exE)
apply (erule conjE)+
apply (rule_tac ?t1.0 = "$ ((\<lambda>x. if x : free_tv A Un free_tv t then S x else TVar x) \<circ> (\<lambda>x. if x : free_tv A then x else n + x)) t1" in has_type.LETI)
 apply (drule_tac x = " (\<lambda>x. if x : free_tv A Un free_tv t then S x else TVar x) \<circ> (\<lambda>x. if x : free_tv A then x else n + x) " in spec)
 apply (subst S'_A_eq_S'_alpha_A)
 apply assumption
apply (subst S_o_alpha_typ)
apply (subst gen_subst_commutes)
 apply (rule subset_antisym)
  apply (rule subsetI)
  apply (erule IntE)
  apply (drule free_tv_S' [THEN subsetD])
  apply (drule free_tv_alpha [THEN subsetD])
  apply (simp)
  apply (erule exE)
  apply (hypsubst)
  apply (subgoal_tac "new_tv (n + y) ($ S A) ")
   apply (subgoal_tac "new_tv (n + y) ($ S t) ")
    apply (subgoal_tac "new_tv (n + y) A")
     apply (subgoal_tac "new_tv (n + y) t")
      apply (drule new_tv_not_free_tv)+
      apply fast
     apply (rule new_tv_le) prefer 2 apply assumption apply simp
    apply (rule new_tv_le) prefer 2 apply assumption apply simp
   apply (rule new_tv_le) prefer 2 apply assumption apply simp
  apply (rule new_tv_le) prefer 2 apply assumption apply simp
 apply fast
apply (rule has_type_le_env)
 apply (drule spec)
 apply (drule spec)
 apply assumption
apply (rule app_subst_Cons [THEN subst])
apply (rule S_compatible_le_scheme_lists)
apply (simp (no_asm_simp))
done

end


theory Llist_of_stream_siterates2
    imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")

primcorec llist_of_stream2 :: "'a Stream \<Rightarrow> 'a Llist"
  where "llist_of_stream2 s = LCons (shd s) (llist_of_stream2 (stl s))"

primcorec stream_of_llist2 :: "'a Llist \<Rightarrow> 'a Stream"
where "stream_of_llist2 l = SCons (lhd l) (stream_of_llist2 (ltl l))"

primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Stream" where
  "shd (siterate f x) = x"
| "stl (siterate f x) = siterate f (f x)"

primcorec literates :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Llist"
where "literates f x = LCons x (literates f (f x))"

theorem llist_of_stream_siterates2:
"llist_of_stream2 (siterate f x) = literates f x"
  by hipster_coinduct_sledgehammer

end