(*  Title:      ZF/Cardinal.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>Cardinal Numbers Without the Axiom of Choice\<close>

theory Cardinal imports OrderType Finite Nat Sum begin

definition
  (*least ordinal operator*)
   Least    :: "(i=>o) => i"    (binder \<open>\<mu> \<close> 10)  where
     "Least(P) == THE i. Ord(i) & P(i) & (\<forall>j. j<i \<longrightarrow> ~P(j))"

definition
  eqpoll   :: "[i,i] => o"     (infixl \<open>\<approx>\<close> 50)  where
    "A \<approx> B == \<exists>f. f \<in> bij(A,B)"

definition
  lepoll   :: "[i,i] => o"     (infixl \<open>\<lesssim>\<close> 50)  where
    "A \<lesssim> B == \<exists>f. f \<in> inj(A,B)"

definition
  lesspoll :: "[i,i] => o"     (infixl \<open>\<prec>\<close> 50)  where
    "A \<prec> B == A \<lesssim> B & ~(A \<approx> B)"

definition
  cardinal :: "i=>i"           (\<open>|_|\<close>)  where
    "|A| == (\<mu> i. i \<approx> A)"

definition
  Finite   :: "i=>o"  where
    "Finite(A) == \<exists>n\<in>nat. A \<approx> n"

definition
  Card     :: "i=>o"  where
    "Card(i) == (i = |i|)"

subsection\<open>The Schroeder-Bernstein Theorem\<close>
text\<open>See Davey and Priestly, page 106\<close>

(** Lemma: Banach's Decomposition Theorem **)

lemma decomp_bnd_mono: "bnd_mono(X, %W. X - g``(Y - f``W))"
by (rule bnd_monoI, blast+)

lemma Banach_last_equation:
    "g \<in> Y->X
     ==> g``(Y - f`` lfp(X, %W. X - g``(Y - f``W))) =
         X - lfp(X, %W. X - g``(Y - f``W))"
apply (rule_tac P = "%u. v = X-u" for v
       in decomp_bnd_mono [THEN lfp_unfold, THEN ssubst])
apply (simp add: double_complement  fun_is_rel [THEN image_subset])
done

lemma decomposition:
     "[| f \<in> X->Y;  g \<in> Y->X |] ==>
      \<exists>XA XB YA YB. (XA \<inter> XB = 0) & (XA \<union> XB = X) &
                      (YA \<inter> YB = 0) & (YA \<union> YB = Y) &
                      f``XA=YA & g``YB=XB"
apply (intro exI conjI)
apply (rule_tac [6] Banach_last_equation)
apply (rule_tac [5] refl)
apply (assumption |
       rule  Diff_disjoint Diff_partition fun_is_rel image_subset lfp_subset)+
done

lemma schroeder_bernstein:
    "[| f \<in> inj(X,Y);  g \<in> inj(Y,X) |] ==> \<exists>h. h \<in> bij(X,Y)"
apply (insert decomposition [of f X Y g])
apply (simp add: inj_is_fun)
apply (blast intro!: restrict_bij bij_disjoint_Un intro: bij_converse_bij)
(* The instantiation of exI to @{term"restrict(f,XA) \<union> converse(restrict(g,YB))"}
   is forced by the context!! *)
done

(** Equipollence is an equivalence relation **)

lemma bij_imp_eqpoll: "f \<in> bij(A,B) ==> A \<approx> B"
apply (unfold eqpoll_def)
apply (erule exI)
done

(*A \<approx> A*)
lemmas eqpoll_refl = id_bij [THEN bij_imp_eqpoll, simp]

lemma eqpoll_sym: "X \<approx> Y ==> Y \<approx> X"
apply (unfold eqpoll_def)
apply (blast intro: bij_converse_bij)
done

lemma eqpoll_trans [trans]:
    "[| X \<approx> Y;  Y \<approx> Z |] ==> X \<approx> Z"
apply (unfold eqpoll_def)
apply (blast intro: comp_bij)
done

(** Le-pollence is a partial ordering **)

lemma subset_imp_lepoll: "X<=Y ==> X \<lesssim> Y"
apply (unfold lepoll_def)
apply (rule exI)
apply (erule id_subset_inj)
done

lemmas lepoll_refl = subset_refl [THEN subset_imp_lepoll, simp]

lemmas le_imp_lepoll = le_imp_subset [THEN subset_imp_lepoll]

lemma eqpoll_imp_lepoll: "X \<approx> Y ==> X \<lesssim> Y"
by (unfold eqpoll_def bij_def lepoll_def, blast)

lemma lepoll_trans [trans]: "[| X \<lesssim> Y;  Y \<lesssim> Z |] ==> X \<lesssim> Z"
apply (unfold lepoll_def)
apply (blast intro: comp_inj)
done

lemma eq_lepoll_trans [trans]: "[| X \<approx> Y;  Y \<lesssim> Z |] ==> X \<lesssim> Z"
 by (blast intro: eqpoll_imp_lepoll lepoll_trans)

lemma lepoll_eq_trans [trans]: "[| X \<lesssim> Y;  Y \<approx> Z |] ==> X \<lesssim> Z"
 by (blast intro: eqpoll_imp_lepoll lepoll_trans)

(*Asymmetry law*)
lemma eqpollI: "[| X \<lesssim> Y;  Y \<lesssim> X |] ==> X \<approx> Y"
apply (unfold lepoll_def eqpoll_def)
apply (elim exE)
apply (rule schroeder_bernstein, assumption+)
done

lemma eqpollE:
    "[| X \<approx> Y; [| X \<lesssim> Y; Y \<lesssim> X |] ==> P |] ==> P"
by (blast intro: eqpoll_imp_lepoll eqpoll_sym)

lemma eqpoll_iff: "X \<approx> Y \<longleftrightarrow> X \<lesssim> Y & Y \<lesssim> X"
by (blast intro: eqpollI elim!: eqpollE)

lemma lepoll_0_is_0: "A \<lesssim> 0 ==> A = 0"
apply (unfold lepoll_def inj_def)
apply (blast dest: apply_type)
done

(*@{term"0 \<lesssim> Y"}*)
lemmas empty_lepollI = empty_subsetI [THEN subset_imp_lepoll]

lemma lepoll_0_iff: "A \<lesssim> 0 \<longleftrightarrow> A=0"
by (blast intro: lepoll_0_is_0 lepoll_refl)

lemma Un_lepoll_Un:
    "[| A \<lesssim> B; C \<lesssim> D; B \<inter> D = 0 |] ==> A \<union> C \<lesssim> B \<union> D"
apply (unfold lepoll_def)
apply (blast intro: inj_disjoint_Un)
done

(*A \<approx> 0 ==> A=0*)
lemmas eqpoll_0_is_0 = eqpoll_imp_lepoll [THEN lepoll_0_is_0]

lemma eqpoll_0_iff: "A \<approx> 0 \<longleftrightarrow> A=0"
by (blast intro: eqpoll_0_is_0 eqpoll_refl)

lemma eqpoll_disjoint_Un:
    "[| A \<approx> B;  C \<approx> D;  A \<inter> C = 0;  B \<inter> D = 0 |]
     ==> A \<union> C \<approx> B \<union> D"
apply (unfold eqpoll_def)
apply (blast intro: bij_disjoint_Un)
done

subsection\<open>lesspoll: contributions by Krzysztof Grabczewski\<close>

lemma lesspoll_not_refl: "~ (i \<prec> i)"
by (simp add: lesspoll_def)

lemma lesspoll_irrefl [elim!]: "i \<prec> i ==> P"
by (simp add: lesspoll_def)

lemma lesspoll_imp_lepoll: "A \<prec> B ==> A \<lesssim> B"
by (unfold lesspoll_def, blast)

lemma lepoll_well_ord: "[| A \<lesssim> B; well_ord(B,r) |] ==> \<exists>s. well_ord(A,s)"
apply (unfold lepoll_def)
apply (blast intro: well_ord_rvimage)
done

lemma lepoll_iff_leqpoll: "A \<lesssim> B \<longleftrightarrow> A \<prec> B | A \<approx> B"
apply (unfold lesspoll_def)
apply (blast intro!: eqpollI elim!: eqpollE)
done

lemma inj_not_surj_succ:
  assumes fi: "f \<in> inj(A, succ(m))" and fns: "f \<notin> surj(A, succ(m))"
  shows "\<exists>f. f \<in> inj(A,m)"
proof -
  from fi [THEN inj_is_fun] fns
  obtain y where y: "y \<in> succ(m)" "\<And>x. x\<in>A \<Longrightarrow> f ` x \<noteq> y"
    by (auto simp add: surj_def)
  show ?thesis
    proof
      show "(\<lambda>z\<in>A. if f`z = m then y else f`z) \<in> inj(A, m)" using y fi
        by (simp add: inj_def)
           (auto intro!: if_type [THEN lam_type] intro: Pi_type dest: apply_funtype)
      qed
qed

(** Variations on transitivity **)

lemma lesspoll_trans [trans]:
      "[| X \<prec> Y; Y \<prec> Z |] ==> X \<prec> Z"
apply (unfold lesspoll_def)
apply (blast elim!: eqpollE intro: eqpollI lepoll_trans)
done

lemma lesspoll_trans1 [trans]:
      "[| X \<lesssim> Y; Y \<prec> Z |] ==> X \<prec> Z"
apply (unfold lesspoll_def)
apply (blast elim!: eqpollE intro: eqpollI lepoll_trans)
done

lemma lesspoll_trans2 [trans]:
      "[| X \<prec> Y; Y \<lesssim> Z |] ==> X \<prec> Z"
apply (unfold lesspoll_def)
apply (blast elim!: eqpollE intro: eqpollI lepoll_trans)
done

lemma eq_lesspoll_trans [trans]:
      "[| X \<approx> Y; Y \<prec> Z |] ==> X \<prec> Z"
  by (blast intro: eqpoll_imp_lepoll lesspoll_trans1)

lemma lesspoll_eq_trans [trans]:
      "[| X \<prec> Y; Y \<approx> Z |] ==> X \<prec> Z"
  by (blast intro: eqpoll_imp_lepoll lesspoll_trans2)

(** \<mu> -- the least number operator [from HOL/Univ.ML] **)

lemma Least_equality:
    "[| P(i);  Ord(i);  !!x. x<i ==> ~P(x) |] ==> (\<mu> x. P(x)) = i"
apply (unfold Least_def)
apply (rule the_equality, blast)
apply (elim conjE)
apply (erule Ord_linear_lt, assumption, blast+)
done

lemma LeastI:
  assumes P: "P(i)" and i: "Ord(i)" shows "P(\<mu> x. P(x))"
proof -
  { from i have "P(i) \<Longrightarrow> P(\<mu> x. P(x))"
      proof (induct i rule: trans_induct)
        case (step i)
        show ?case
          proof (cases "P(\<mu> a. P(a))")
            case True thus ?thesis .
          next
            case False
            hence "\<And>x. x \<in> i \<Longrightarrow> ~P(x)" using step
              by blast
            hence "(\<mu> a. P(a)) = i" using step
              by (blast intro: Least_equality ltD)
            thus ?thesis using step.prems
              by simp
          qed
      qed
  }
  thus ?thesis using P .
qed

text\<open>The proof is almost identical to the one above!\<close>
lemma Least_le:
  assumes P: "P(i)" and i: "Ord(i)" shows "(\<mu> x. P(x)) \<le> i"
proof -
  { from i have "P(i) \<Longrightarrow> (\<mu> x. P(x)) \<le> i"
      proof (induct i rule: trans_induct)
        case (step i)
        show ?case
          proof (cases "(\<mu> a. P(a)) \<le> i")
            case True thus ?thesis .
          next
            case False
            hence "\<And>x. x \<in> i \<Longrightarrow> ~ (\<mu> a. P(a)) \<le> i" using step
              by blast
            hence "(\<mu> a. P(a)) = i" using step
              by (blast elim: ltE intro: ltI Least_equality lt_trans1)
            thus ?thesis using step
              by simp
          qed
      qed
  }
  thus ?thesis using P .
qed

(*\<mu> really is the smallest*)
lemma less_LeastE: "[| P(i);  i < (\<mu> x. P(x)) |] ==> Q"
apply (rule Least_le [THEN [2] lt_trans2, THEN lt_irrefl], assumption+)
apply (simp add: lt_Ord)
done

(*Easier to apply than LeastI: conclusion has only one occurrence of P*)
lemma LeastI2:
    "[| P(i);  Ord(i);  !!j. P(j) ==> Q(j) |] ==> Q(\<mu> j. P(j))"
by (blast intro: LeastI )

(*If there is no such P then \<mu> is vacuously 0*)
lemma Least_0:
    "[| ~ (\<exists>i. Ord(i) & P(i)) |] ==> (\<mu> x. P(x)) = 0"
apply (unfold Least_def)
apply (rule the_0, blast)
done

lemma Ord_Least [intro,simp,TC]: "Ord(\<mu> x. P(x))"
proof (cases "\<exists>i. Ord(i) & P(i)")
  case True
  then obtain i where "P(i)" "Ord(i)"  by auto
  hence " (\<mu> x. P(x)) \<le> i"  by (rule Least_le)
  thus ?thesis
    by (elim ltE)
next
  case False
  hence "(\<mu> x. P(x)) = 0"  by (rule Least_0)
  thus ?thesis
    by auto
qed

subsection\<open>Basic Properties of Cardinals\<close>

(*Not needed for simplification, but helpful below*)
lemma Least_cong: "(!!y. P(y) \<longleftrightarrow> Q(y)) ==> (\<mu> x. P(x)) = (\<mu> x. Q(x))"
by simp

(*Need AC to get @{term"X \<lesssim> Y ==> |X| \<le> |Y|"};  see well_ord_lepoll_imp_Card_le
  Converse also requires AC, but see well_ord_cardinal_eqE*)
lemma cardinal_cong: "X \<approx> Y ==> |X| = |Y|"
apply (unfold eqpoll_def cardinal_def)
apply (rule Least_cong)
apply (blast intro: comp_bij bij_converse_bij)
done

(*Under AC, the premise becomes trivial; one consequence is ||A|| = |A|*)
lemma well_ord_cardinal_eqpoll:
  assumes r: "well_ord(A,r)" shows "|A| \<approx> A"
proof (unfold cardinal_def)
  show "(\<mu> i. i \<approx> A) \<approx> A"
    by (best intro: LeastI Ord_ordertype ordermap_bij bij_converse_bij bij_imp_eqpoll r)
qed

(* @{term"Ord(A) ==> |A| \<approx> A"} *)
lemmas Ord_cardinal_eqpoll = well_ord_Memrel [THEN well_ord_cardinal_eqpoll]

lemma Ord_cardinal_idem: "Ord(A) \<Longrightarrow> ||A|| = |A|"
 by (rule Ord_cardinal_eqpoll [THEN cardinal_cong])

lemma well_ord_cardinal_eqE:
  assumes woX: "well_ord(X,r)" and woY: "well_ord(Y,s)" and eq: "|X| = |Y|"
shows "X \<approx> Y"
proof -
  have "X \<approx> |X|" by (blast intro: well_ord_cardinal_eqpoll [OF woX] eqpoll_sym)
  also have "... = |Y|" by (rule eq)
  also have "... \<approx> Y" by (rule well_ord_cardinal_eqpoll [OF woY])
  finally show ?thesis .
qed

lemma well_ord_cardinal_eqpoll_iff:
     "[| well_ord(X,r);  well_ord(Y,s) |] ==> |X| = |Y| \<longleftrightarrow> X \<approx> Y"
by (blast intro: cardinal_cong well_ord_cardinal_eqE)

(** Observations from Kunen, page 28 **)

lemma Ord_cardinal_le: "Ord(i) ==> |i| \<le> i"
apply (unfold cardinal_def)
apply (erule eqpoll_refl [THEN Least_le])
done

lemma Card_cardinal_eq: "Card(K) ==> |K| = K"
apply (unfold Card_def)
apply (erule sym)
done

(* Could replace the  @{term"~(j \<approx> i)"}  by  @{term"~(i \<preceq> j)"}. *)
lemma CardI: "[| Ord(i);  !!j. j<i ==> ~(j \<approx> i) |] ==> Card(i)"
apply (unfold Card_def cardinal_def)
apply (subst Least_equality)
apply (blast intro: eqpoll_refl)+
done

lemma Card_is_Ord: "Card(i) ==> Ord(i)"
apply (unfold Card_def cardinal_def)
apply (erule ssubst)
apply (rule Ord_Least)
done

lemma Card_cardinal_le: "Card(K) ==> K \<le> |K|"
apply (simp (no_asm_simp) add: Card_is_Ord Card_cardinal_eq)
done

lemma Ord_cardinal [simp,intro!]: "Ord(|A|)"
apply (unfold cardinal_def)
apply (rule Ord_Least)
done

text\<open>The cardinals are the initial ordinals.\<close>
lemma Card_iff_initial: "Card(K) \<longleftrightarrow> Ord(K) & (\<forall>j. j<K \<longrightarrow> ~ j \<approx> K)"
proof -
  { fix j
    assume K: "Card(K)" "j \<approx> K"
    assume "j < K"
    also have "... = (\<mu> i. i \<approx> K)" using K
      by (simp add: Card_def cardinal_def)
    finally have "j < (\<mu> i. i \<approx> K)" .
    hence "False" using K
      by (best dest: less_LeastE)
  }
  then show ?thesis
    by (blast intro: CardI Card_is_Ord)
qed

lemma lt_Card_imp_lesspoll: "[| Card(a); i<a |] ==> i \<prec> a"
apply (unfold lesspoll_def)
apply (drule Card_iff_initial [THEN iffD1])
apply (blast intro!: leI [THEN le_imp_lepoll])
done

lemma Card_0: "Card(0)"
apply (rule Ord_0 [THEN CardI])
apply (blast elim!: ltE)
done

lemma Card_Un: "[| Card(K);  Card(L) |] ==> Card(K \<union> L)"
apply (rule Ord_linear_le [of K L])
apply (simp_all add: subset_Un_iff [THEN iffD1]  Card_is_Ord le_imp_subset
                     subset_Un_iff2 [THEN iffD1])
done

(*Infinite unions of cardinals?  See Devlin, Lemma 6.7, page 98*)

lemma Card_cardinal [iff]: "Card(|A|)"
proof (unfold cardinal_def)
  show "Card(\<mu> i. i \<approx> A)"
    proof (cases "\<exists>i. Ord (i) & i \<approx> A")
      case False thus ?thesis           \<comment> \<open>degenerate case\<close>
        by (simp add: Least_0 Card_0)
    next
      case True                         \<comment> \<open>real case: \<^term>\<open>A\<close> is isomorphic to some ordinal\<close>
      then obtain i where i: "Ord(i)" "i \<approx> A" by blast
      show ?thesis
        proof (rule CardI [OF Ord_Least], rule notI)
          fix j
          assume j: "j < (\<mu> i. i \<approx> A)"
          assume "j \<approx> (\<mu> i. i \<approx> A)"
          also have "... \<approx> A" using i by (auto intro: LeastI)
          finally have "j \<approx> A" .
          thus False
            by (rule less_LeastE [OF _ j])
        qed
    qed
qed

(*Kunen's Lemma 10.5*)
lemma cardinal_eq_lemma:
  assumes i:"|i| \<le> j" and j: "j \<le> i" shows "|j| = |i|"
proof (rule eqpollI [THEN cardinal_cong])
  show "j \<lesssim> i" by (rule le_imp_lepoll [OF j])
next
  have Oi: "Ord(i)" using j by (rule le_Ord2)
  hence "i \<approx> |i|"
    by (blast intro: Ord_cardinal_eqpoll eqpoll_sym)
  also have "... \<lesssim> j"
    by (blast intro: le_imp_lepoll i)
  finally show "i \<lesssim> j" .
qed

lemma cardinal_mono:
  assumes ij: "i \<le> j" shows "|i| \<le> |j|"
using Ord_cardinal [of i] Ord_cardinal [of j]
proof (cases rule: Ord_linear_le)
  case le thus ?thesis .
next
  case ge
  have i: "Ord(i)" using ij
    by (simp add: lt_Ord)
  have ci: "|i| \<le> j"
    by (blast intro: Ord_cardinal_le ij le_trans i)
  have "|i| = ||i||"
    by (auto simp add: Ord_cardinal_idem i)
  also have "... = |j|"
    by (rule cardinal_eq_lemma [OF ge ci])
  finally have "|i| = |j|" .
  thus ?thesis by simp
qed

text\<open>Since we have \<^term>\<open>|succ(nat)| \<le> |nat|\<close>, the converse of \<open>cardinal_mono\<close> fails!\<close>
lemma cardinal_lt_imp_lt: "[| |i| < |j|;  Ord(i);  Ord(j) |] ==> i < j"
apply (rule Ord_linear2 [of i j], assumption+)
apply (erule lt_trans2 [THEN lt_irrefl])
apply (erule cardinal_mono)
done

lemma Card_lt_imp_lt: "[| |i| < K;  Ord(i);  Card(K) |] ==> i < K"
  by (simp (no_asm_simp) add: cardinal_lt_imp_lt Card_is_Ord Card_cardinal_eq)

lemma Card_lt_iff: "[| Ord(i);  Card(K) |] ==> (|i| < K) \<longleftrightarrow> (i < K)"
by (blast intro: Card_lt_imp_lt Ord_cardinal_le [THEN lt_trans1])

lemma Card_le_iff: "[| Ord(i);  Card(K) |] ==> (K \<le> |i|) \<longleftrightarrow> (K \<le> i)"
by (simp add: Card_lt_iff Card_is_Ord Ord_cardinal not_lt_iff_le [THEN iff_sym])

(*Can use AC or finiteness to discharge first premise*)
lemma well_ord_lepoll_imp_Card_le:
  assumes wB: "well_ord(B,r)" and AB: "A \<lesssim> B"
  shows "|A| \<le> |B|"
using Ord_cardinal [of A] Ord_cardinal [of B]
proof (cases rule: Ord_linear_le)
  case le thus ?thesis .
next
  case ge
  from lepoll_well_ord [OF AB wB]
  obtain s where s: "well_ord(A, s)" by blast
  have "B  \<approx> |B|" by (blast intro: wB eqpoll_sym well_ord_cardinal_eqpoll)
  also have "... \<lesssim> |A|" by (rule le_imp_lepoll [OF ge])
  also have "... \<approx> A" by (rule well_ord_cardinal_eqpoll [OF s])
  finally have "B \<lesssim> A" .
  hence "A \<approx> B" by (blast intro: eqpollI AB)
  hence "|A| = |B|" by (rule cardinal_cong)
  thus ?thesis by simp
qed

lemma lepoll_cardinal_le: "[| A \<lesssim> i; Ord(i) |] ==> |A| \<le> i"
apply (rule le_trans)
apply (erule well_ord_Memrel [THEN well_ord_lepoll_imp_Card_le], assumption)
apply (erule Ord_cardinal_le)
done

lemma lepoll_Ord_imp_eqpoll: "[| A \<lesssim> i; Ord(i) |] ==> |A| \<approx> A"
by (blast intro: lepoll_cardinal_le well_ord_Memrel well_ord_cardinal_eqpoll dest!: lepoll_well_ord)

lemma lesspoll_imp_eqpoll: "[| A \<prec> i; Ord(i) |] ==> |A| \<approx> A"
apply (unfold lesspoll_def)
apply (blast intro: lepoll_Ord_imp_eqpoll)
done

lemma cardinal_subset_Ord: "[|A<=i; Ord(i)|] ==> |A| \<subseteq> i"
apply (drule subset_imp_lepoll [THEN lepoll_cardinal_le])
apply (auto simp add: lt_def)
apply (blast intro: Ord_trans)
done

subsection\<open>The finite cardinals\<close>

lemma cons_lepoll_consD:
 "[| cons(u,A) \<lesssim> cons(v,B);  u\<notin>A;  v\<notin>B |] ==> A \<lesssim> B"
apply (unfold lepoll_def inj_def, safe)
apply (rule_tac x = "\<lambda>x\<in>A. if f`x=v then f`u else f`x" in exI)
apply (rule CollectI)
(*Proving it's in the function space A->B*)
apply (rule if_type [THEN lam_type])
apply (blast dest: apply_funtype)
apply (blast elim!: mem_irrefl dest: apply_funtype)
(*Proving it's injective*)
apply (simp (no_asm_simp))
apply blast
done

lemma cons_eqpoll_consD: "[| cons(u,A) \<approx> cons(v,B);  u\<notin>A;  v\<notin>B |] ==> A \<approx> B"
apply (simp add: eqpoll_iff)
apply (blast intro: cons_lepoll_consD)
done

(*Lemma suggested by Mike Fourman*)
lemma succ_lepoll_succD: "succ(m) \<lesssim> succ(n) ==> m \<lesssim> n"
apply (unfold succ_def)
apply (erule cons_lepoll_consD)
apply (rule mem_not_refl)+
done

lemma nat_lepoll_imp_le:
     "m \<in> nat ==> n \<in> nat \<Longrightarrow> m \<lesssim> n \<Longrightarrow> m \<le> n"
proof (induct m arbitrary: n rule: nat_induct)
  case 0 thus ?case by (blast intro!: nat_0_le)
next
  case (succ m)
  show ?case  using \<open>n \<in> nat\<close>
    proof (cases rule: natE)
      case 0 thus ?thesis using succ
        by (simp add: lepoll_def inj_def)
    next
      case (succ n') thus ?thesis using succ.hyps \<open> succ(m) \<lesssim> n\<close>
        by (blast intro!: succ_leI dest!: succ_lepoll_succD)
    qed
qed

lemma nat_eqpoll_iff: "[| m \<in> nat; n \<in> nat |] ==> m \<approx> n \<longleftrightarrow> m = n"
apply (rule iffI)
apply (blast intro: nat_lepoll_imp_le le_anti_sym elim!: eqpollE)
apply (simp add: eqpoll_refl)
done

(*The object of all this work: every natural number is a (finite) cardinal*)
lemma nat_into_Card:
  assumes n: "n \<in> nat" shows "Card(n)"
proof (unfold Card_def cardinal_def, rule sym)
  have "Ord(n)" using n  by auto
  moreover
  { fix i
    assume "i < n" "i \<approx> n"
    hence False using n
      by (auto simp add: lt_nat_in_nat [THEN nat_eqpoll_iff])
  }
  ultimately show "(\<mu> i. i \<approx> n) = n" by (auto intro!: Least_equality)
qed

lemmas cardinal_0 = nat_0I [THEN nat_into_Card, THEN Card_cardinal_eq, iff]
lemmas cardinal_1 = nat_1I [THEN nat_into_Card, THEN Card_cardinal_eq, iff]

(*Part of Kunen's Lemma 10.6*)
lemma succ_lepoll_natE: "[| succ(n) \<lesssim> n;  n \<in> nat |] ==> P"
by (rule nat_lepoll_imp_le [THEN lt_irrefl], auto)

lemma nat_lepoll_imp_ex_eqpoll_n:
     "[| n \<in> nat;  nat \<lesssim> X |] ==> \<exists>Y. Y \<subseteq> X & n \<approx> Y"
apply (unfold lepoll_def eqpoll_def)
apply (fast del: subsetI subsetCE
            intro!: subset_SIs
            dest!: Ord_nat [THEN [2] OrdmemD, THEN [2] restrict_inj]
            elim!: restrict_bij
                   inj_is_fun [THEN fun_is_rel, THEN image_subset])
done

(** \<lesssim>, \<prec> and natural numbers **)

lemma lepoll_succ: "i \<lesssim> succ(i)"
  by (blast intro: subset_imp_lepoll)

lemma lepoll_imp_lesspoll_succ:
  assumes A: "A \<lesssim> m" and m: "m \<in> nat"
  shows "A \<prec> succ(m)"
proof -
  { assume "A \<approx> succ(m)"
    hence "succ(m) \<approx> A" by (rule eqpoll_sym)
    also have "... \<lesssim> m" by (rule A)
    finally have "succ(m) \<lesssim> m" .
    hence False by (rule succ_lepoll_natE) (rule m) }
  moreover have "A \<lesssim> succ(m)" by (blast intro: lepoll_trans A lepoll_succ)
  ultimately show ?thesis by (auto simp add: lesspoll_def)
qed

lemma lesspoll_succ_imp_lepoll:
     "[| A \<prec> succ(m); m \<in> nat |] ==> A \<lesssim> m"
apply (unfold lesspoll_def lepoll_def eqpoll_def bij_def)
apply (auto dest: inj_not_surj_succ)
done

lemma lesspoll_succ_iff: "m \<in> nat ==> A \<prec> succ(m) \<longleftrightarrow> A \<lesssim> m"
by (blast intro!: lepoll_imp_lesspoll_succ lesspoll_succ_imp_lepoll)

lemma lepoll_succ_disj: "[| A \<lesssim> succ(m);  m \<in> nat |] ==> A \<lesssim> m | A \<approx> succ(m)"
apply (rule disjCI)
apply (rule lesspoll_succ_imp_lepoll)
prefer 2 apply assumption
apply (simp (no_asm_simp) add: lesspoll_def)
done

lemma lesspoll_cardinal_lt: "[| A \<prec> i; Ord(i) |] ==> |A| < i"
apply (unfold lesspoll_def, clarify)
apply (frule lepoll_cardinal_le, assumption)
apply (blast intro: well_ord_Memrel well_ord_cardinal_eqpoll [THEN eqpoll_sym]
             dest: lepoll_well_ord  elim!: leE)
done

subsection\<open>The first infinite cardinal: Omega, or nat\<close>

(*This implies Kunen's Lemma 10.6*)
lemma lt_not_lepoll:
  assumes n: "n<i" "n \<in> nat" shows "~ i \<lesssim> n"
proof -
  { assume i: "i \<lesssim> n"
    have "succ(n) \<lesssim> i" using n
      by (elim ltE, blast intro: Ord_succ_subsetI [THEN subset_imp_lepoll])
    also have "... \<lesssim> n" by (rule i)
    finally have "succ(n) \<lesssim> n" .
    hence False  by (rule succ_lepoll_natE) (rule n) }
  thus ?thesis by auto
qed

text\<open>A slightly weaker version of \<open>nat_eqpoll_iff\<close>\<close>
lemma Ord_nat_eqpoll_iff:
  assumes i: "Ord(i)" and n: "n \<in> nat" shows "i \<approx> n \<longleftrightarrow> i=n"
using i nat_into_Ord [OF n]
proof (cases rule: Ord_linear_lt)
  case lt
  hence  "i \<in> nat" by (rule lt_nat_in_nat) (rule n)
  thus ?thesis by (simp add: nat_eqpoll_iff n)
next
  case eq
  thus ?thesis by (simp add: eqpoll_refl)
next
  case gt
  hence  "~ i \<lesssim> n" using n  by (rule lt_not_lepoll)
  hence  "~ i \<approx> n" using n  by (blast intro: eqpoll_imp_lepoll)
  moreover have "i \<noteq> n" using \<open>n<i\<close> by auto
  ultimately show ?thesis by blast
qed

lemma Card_nat: "Card(nat)"
proof -
  { fix i
    assume i: "i < nat" "i \<approx> nat"
    hence "~ nat \<lesssim> i"
      by (simp add: lt_def lt_not_lepoll)
    hence False using i
      by (simp add: eqpoll_iff)
  }
  hence "(\<mu> i. i \<approx> nat) = nat" by (blast intro: Least_equality eqpoll_refl)
  thus ?thesis
    by (auto simp add: Card_def cardinal_def)
qed

(*Allows showing that |i| is a limit cardinal*)
lemma nat_le_cardinal: "nat \<le> i ==> nat \<le> |i|"
apply (rule Card_nat [THEN Card_cardinal_eq, THEN subst])
apply (erule cardinal_mono)
done

lemma n_lesspoll_nat: "n \<in> nat ==> n \<prec> nat"
  by (blast intro: Ord_nat Card_nat ltI lt_Card_imp_lesspoll)

subsection\<open>Towards Cardinal Arithmetic\<close>
(** Congruence laws for successor, cardinal addition and multiplication **)

(*Congruence law for  cons  under equipollence*)
lemma cons_lepoll_cong:
    "[| A \<lesssim> B;  b \<notin> B |] ==> cons(a,A) \<lesssim> cons(b,B)"
apply (unfold lepoll_def, safe)
apply (rule_tac x = "\<lambda>y\<in>cons (a,A) . if y=a then b else f`y" in exI)
apply (rule_tac d = "%z. if z \<in> B then converse (f) `z else a" in lam_injective)
apply (safe elim!: consE')
   apply simp_all
apply (blast intro: inj_is_fun [THEN apply_type])+
done

lemma cons_eqpoll_cong:
     "[| A \<approx> B;  a \<notin> A;  b \<notin> B |] ==> cons(a,A) \<approx> cons(b,B)"
by (simp add: eqpoll_iff cons_lepoll_cong)

lemma cons_lepoll_cons_iff:
     "[| a \<notin> A;  b \<notin> B |] ==> cons(a,A) \<lesssim> cons(b,B)  \<longleftrightarrow>  A \<lesssim> B"
by (blast intro: cons_lepoll_cong cons_lepoll_consD)

lemma cons_eqpoll_cons_iff:
     "[| a \<notin> A;  b \<notin> B |] ==> cons(a,A) \<approx> cons(b,B)  \<longleftrightarrow>  A \<approx> B"
by (blast intro: cons_eqpoll_cong cons_eqpoll_consD)

lemma singleton_eqpoll_1: "{a} \<approx> 1"
apply (unfold succ_def)
apply (blast intro!: eqpoll_refl [THEN cons_eqpoll_cong])
done

lemma cardinal_singleton: "|{a}| = 1"
apply (rule singleton_eqpoll_1 [THEN cardinal_cong, THEN trans])
apply (simp (no_asm) add: nat_into_Card [THEN Card_cardinal_eq])
done

lemma not_0_is_lepoll_1: "A \<noteq> 0 ==> 1 \<lesssim> A"
apply (erule not_emptyE)
apply (rule_tac a = "cons (x, A-{x}) " in subst)
apply (rule_tac [2] a = "cons(0,0)" and P= "%y. y \<lesssim> cons (x, A-{x})" in subst)
prefer 3 apply (blast intro: cons_lepoll_cong subset_imp_lepoll, auto)
done

(*Congruence law for  succ  under equipollence*)
lemma succ_eqpoll_cong: "A \<approx> B ==> succ(A) \<approx> succ(B)"
apply (unfold succ_def)
apply (simp add: cons_eqpoll_cong mem_not_refl)
done

(*Congruence law for + under equipollence*)
lemma sum_eqpoll_cong: "[| A \<approx> C;  B \<approx> D |] ==> A+B \<approx> C+D"
apply (unfold eqpoll_def)
apply (blast intro!: sum_bij)
done

(*Congruence law for * under equipollence*)
lemma prod_eqpoll_cong:
    "[| A \<approx> C;  B \<approx> D |] ==> A*B \<approx> C*D"
apply (unfold eqpoll_def)
apply (blast intro!: prod_bij)
done

lemma inj_disjoint_eqpoll:
    "[| f \<in> inj(A,B);  A \<inter> B = 0 |] ==> A \<union> (B - range(f)) \<approx> B"
apply (unfold eqpoll_def)
apply (rule exI)
apply (rule_tac c = "%x. if x \<in> A then f`x else x"
            and d = "%y. if y \<in> range (f) then converse (f) `y else y"
       in lam_bijective)
apply (blast intro!: if_type inj_is_fun [THEN apply_type])
apply (simp (no_asm_simp) add: inj_converse_fun [THEN apply_funtype])
apply (safe elim!: UnE')
   apply (simp_all add: inj_is_fun [THEN apply_rangeI])
apply (blast intro: inj_converse_fun [THEN apply_type])+
done

subsection\<open>Lemmas by Krzysztof Grabczewski\<close>

(*New proofs using cons_lepoll_cons. Could generalise from succ to cons.*)

text\<open>If \<^term>\<open>A\<close> has at most \<^term>\<open>n+1\<close> elements and \<^term>\<open>a \<in> A\<close>
      then \<^term>\<open>A-{a}\<close> has at most \<^term>\<open>n\<close>.\<close>
lemma Diff_sing_lepoll:
      "[| a \<in> A;  A \<lesssim> succ(n) |] ==> A - {a} \<lesssim> n"
apply (unfold succ_def)
apply (rule cons_lepoll_consD)
apply (rule_tac [3] mem_not_refl)
apply (erule cons_Diff [THEN ssubst], safe)
done

text\<open>If \<^term>\<open>A\<close> has at least \<^term>\<open>n+1\<close> elements then \<^term>\<open>A-{a}\<close> has at least \<^term>\<open>n\<close>.\<close>
lemma lepoll_Diff_sing:
  assumes A: "succ(n) \<lesssim> A" shows "n \<lesssim> A - {a}"
proof -
  have "cons(n,n) \<lesssim> A" using A
    by (unfold succ_def)
  also have "... \<lesssim> cons(a, A-{a})"
    by (blast intro: subset_imp_lepoll)
  finally have "cons(n,n) \<lesssim> cons(a, A-{a})" .
  thus ?thesis
    by (blast intro: cons_lepoll_consD mem_irrefl)
qed

lemma Diff_sing_eqpoll: "[| a \<in> A; A \<approx> succ(n) |] ==> A - {a} \<approx> n"
by (blast intro!: eqpollI
          elim!: eqpollE
          intro: Diff_sing_lepoll lepoll_Diff_sing)

lemma lepoll_1_is_sing: "[| A \<lesssim> 1; a \<in> A |] ==> A = {a}"
apply (frule Diff_sing_lepoll, assumption)
apply (drule lepoll_0_is_0)
apply (blast elim: equalityE)
done

lemma Un_lepoll_sum: "A \<union> B \<lesssim> A+B"
apply (unfold lepoll_def)
apply (rule_tac x = "\<lambda>x\<in>A \<union> B. if x\<in>A then Inl (x) else Inr (x)" in exI)
apply (rule_tac d = "%z. snd (z)" in lam_injective)
apply force
apply (simp add: Inl_def Inr_def)
done

lemma well_ord_Un:
     "[| well_ord(X,R); well_ord(Y,S) |] ==> \<exists>T. well_ord(X \<union> Y, T)"
by (erule well_ord_radd [THEN Un_lepoll_sum [THEN lepoll_well_ord]],
    assumption)

(*Krzysztof Grabczewski*)
lemma disj_Un_eqpoll_sum: "A \<inter> B = 0 ==> A \<union> B \<approx> A + B"
apply (unfold eqpoll_def)
apply (rule_tac x = "\<lambda>a\<in>A \<union> B. if a \<in> A then Inl (a) else Inr (a)" in exI)
apply (rule_tac d = "%z. case (%x. x, %x. x, z)" in lam_bijective)
apply auto
done

subsection \<open>Finite and infinite sets\<close>

lemma eqpoll_imp_Finite_iff: "A \<approx> B ==> Finite(A) \<longleftrightarrow> Finite(B)"
apply (unfold Finite_def)
apply (blast intro: eqpoll_trans eqpoll_sym)
done

lemma Finite_0 [simp]: "Finite(0)"
apply (unfold Finite_def)
apply (blast intro!: eqpoll_refl nat_0I)
done

lemma Finite_cons: "Finite(x) ==> Finite(cons(y,x))"
apply (unfold Finite_def)
apply (case_tac "y \<in> x")
apply (simp add: cons_absorb)
apply (erule bexE)
apply (rule bexI)
apply (erule_tac [2] nat_succI)
apply (simp (no_asm_simp) add: succ_def cons_eqpoll_cong mem_not_refl)
done

lemma Finite_succ: "Finite(x) ==> Finite(succ(x))"
apply (unfold succ_def)
apply (erule Finite_cons)
done

lemma lepoll_nat_imp_Finite:
  assumes A: "A \<lesssim> n" and n: "n \<in> nat" shows "Finite(A)"
proof -
  have "A \<lesssim> n \<Longrightarrow> Finite(A)" using n
    proof (induct n)
      case 0
      hence "A = 0" by (rule lepoll_0_is_0)
      thus ?case by simp
    next
      case (succ n)
      hence "A \<lesssim> n \<or> A \<approx> succ(n)" by (blast dest: lepoll_succ_disj)
      thus ?case using succ by (auto simp add: Finite_def)
    qed
  thus ?thesis using A .
qed

lemma lesspoll_nat_is_Finite:
     "A \<prec> nat ==> Finite(A)"
apply (unfold Finite_def)
apply (blast dest: ltD lesspoll_cardinal_lt
                   lesspoll_imp_eqpoll [THEN eqpoll_sym])
done

lemma lepoll_Finite:
  assumes Y: "Y \<lesssim> X" and X: "Finite(X)" shows "Finite(Y)"
proof -
  obtain n where n: "n \<in> nat" "X \<approx> n" using X
    by (auto simp add: Finite_def)
  have "Y \<lesssim> X"         by (rule Y)
  also have "... \<approx> n"  by (rule n)
  finally have "Y \<lesssim> n" .
  thus ?thesis using n by (simp add: lepoll_nat_imp_Finite)
qed

lemmas subset_Finite = subset_imp_lepoll [THEN lepoll_Finite]

lemma Finite_cons_iff [iff]: "Finite(cons(y,x)) \<longleftrightarrow> Finite(x)"
by (blast intro: Finite_cons subset_Finite)

lemma Finite_succ_iff [iff]: "Finite(succ(x)) \<longleftrightarrow> Finite(x)"
by (simp add: succ_def)

lemma Finite_Int: "Finite(A) | Finite(B) ==> Finite(A \<inter> B)"
by (blast intro: subset_Finite)

lemmas Finite_Diff = Diff_subset [THEN subset_Finite]

lemma nat_le_infinite_Ord:
      "[| Ord(i);  ~ Finite(i) |] ==> nat \<le> i"
apply (unfold Finite_def)
apply (erule Ord_nat [THEN [2] Ord_linear2])
prefer 2 apply assumption
apply (blast intro!: eqpoll_refl elim!: ltE)
done

lemma Finite_imp_well_ord:
    "Finite(A) ==> \<exists>r. well_ord(A,r)"
apply (unfold Finite_def eqpoll_def)
apply (blast intro: well_ord_rvimage bij_is_inj well_ord_Memrel nat_into_Ord)
done

lemma succ_lepoll_imp_not_empty: "succ(x) \<lesssim> y ==> y \<noteq> 0"
by (fast dest!: lepoll_0_is_0)

lemma eqpoll_succ_imp_not_empty: "x \<approx> succ(n) ==> x \<noteq> 0"
by (fast elim!: eqpoll_sym [THEN eqpoll_0_is_0, THEN succ_neq_0])

lemma Finite_Fin_lemma [rule_format]:
     "n \<in> nat ==> \<forall>A. (A\<approx>n & A \<subseteq> X) \<longrightarrow> A \<in> Fin(X)"
apply (induct_tac n)
apply (rule allI)
apply (fast intro!: Fin.emptyI dest!: eqpoll_imp_lepoll [THEN lepoll_0_is_0])
apply (rule allI)
apply (rule impI)
apply (erule conjE)
apply (rule eqpoll_succ_imp_not_empty [THEN not_emptyE], assumption)
apply (frule Diff_sing_eqpoll, assumption)
apply (erule allE)
apply (erule impE, fast)
apply (drule subsetD, assumption)
apply (drule Fin.consI, assumption)
apply (simp add: cons_Diff)
done

lemma Finite_Fin: "[| Finite(A); A \<subseteq> X |] ==> A \<in> Fin(X)"
by (unfold Finite_def, blast intro: Finite_Fin_lemma)

lemma Fin_lemma [rule_format]: "n \<in> nat ==> \<forall>A. A \<approx> n \<longrightarrow> A \<in> Fin(A)"
apply (induct_tac n)
apply (simp add: eqpoll_0_iff, clarify)
apply (subgoal_tac "\<exists>u. u \<in> A")
apply (erule exE)
apply (rule Diff_sing_eqpoll [elim_format])
prefer 2 apply assumption
apply assumption
apply (rule_tac b = A in cons_Diff [THEN subst], assumption)
apply (rule Fin.consI, blast)
apply (blast intro: subset_consI [THEN Fin_mono, THEN subsetD])
(*Now for the lemma assumed above*)
apply (unfold eqpoll_def)
apply (blast intro: bij_converse_bij [THEN bij_is_fun, THEN apply_type])
done

lemma Finite_into_Fin: "Finite(A) ==> A \<in> Fin(A)"
apply (unfold Finite_def)
apply (blast intro: Fin_lemma)
done

lemma Fin_into_Finite: "A \<in> Fin(U) ==> Finite(A)"
by (fast intro!: Finite_0 Finite_cons elim: Fin_induct)

lemma Finite_Fin_iff: "Finite(A) \<longleftrightarrow> A \<in> Fin(A)"
by (blast intro: Finite_into_Fin Fin_into_Finite)

lemma Finite_Un: "[| Finite(A); Finite(B) |] ==> Finite(A \<union> B)"
by (blast intro!: Fin_into_Finite Fin_UnI
          dest!: Finite_into_Fin
          intro: Un_upper1 [THEN Fin_mono, THEN subsetD]
                 Un_upper2 [THEN Fin_mono, THEN subsetD])

lemma Finite_Un_iff [simp]: "Finite(A \<union> B) \<longleftrightarrow> (Finite(A) & Finite(B))"
by (blast intro: subset_Finite Finite_Un)

text\<open>The converse must hold too.\<close>
lemma Finite_Union: "[| \<forall>y\<in>X. Finite(y);  Finite(X) |] ==> Finite(\<Union>(X))"
apply (simp add: Finite_Fin_iff)
apply (rule Fin_UnionI)
apply (erule Fin_induct, simp)
apply (blast intro: Fin.consI Fin_mono [THEN [2] rev_subsetD])
done

(* Induction principle for Finite(A), by Sidi Ehmety *)
lemma Finite_induct [case_names 0 cons, induct set: Finite]:
"[| Finite(A); P(0);
    !! x B.   [| Finite(B); x \<notin> B; P(B) |] ==> P(cons(x, B)) |]
 ==> P(A)"
apply (erule Finite_into_Fin [THEN Fin_induct])
apply (blast intro: Fin_into_Finite)+
done

(*Sidi Ehmety.  The contrapositive says ~Finite(A) ==> ~Finite(A-{a}) *)
lemma Diff_sing_Finite: "Finite(A - {a}) ==> Finite(A)"
apply (unfold Finite_def)
apply (case_tac "a \<in> A")
apply (subgoal_tac [2] "A-{a}=A", auto)
apply (rule_tac x = "succ (n) " in bexI)
apply (subgoal_tac "cons (a, A - {a}) = A & cons (n, n) = succ (n) ")
apply (drule_tac a = a and b = n in cons_eqpoll_cong)
apply (auto dest: mem_irrefl)
done

(*Sidi Ehmety.  And the contrapositive of this says
   [| ~Finite(A); Finite(B) |] ==> ~Finite(A-B) *)
lemma Diff_Finite [rule_format]: "Finite(B) ==> Finite(A-B) \<longrightarrow> Finite(A)"
apply (erule Finite_induct, auto)
apply (case_tac "x \<in> A")
 apply (subgoal_tac [2] "A-cons (x, B) = A - B")
apply (subgoal_tac "A - cons (x, B) = (A - B) - {x}", simp)
apply (drule Diff_sing_Finite, auto)
done

lemma Finite_RepFun: "Finite(A) ==> Finite(RepFun(A,f))"
by (erule Finite_induct, simp_all)

lemma Finite_RepFun_iff_lemma [rule_format]:
     "[|Finite(x); !!x y. f(x)=f(y) ==> x=y|]
      ==> \<forall>A. x = RepFun(A,f) \<longrightarrow> Finite(A)"
apply (erule Finite_induct)
 apply clarify
 apply (case_tac "A=0", simp)
 apply (blast del: allE, clarify)
apply (subgoal_tac "\<exists>z\<in>A. x = f(z)")
 prefer 2 apply (blast del: allE elim: equalityE, clarify)
apply (subgoal_tac "B = {f(u) . u \<in> A - {z}}")
 apply (blast intro: Diff_sing_Finite)
apply (thin_tac "\<forall>A. P(A) \<longrightarrow> Finite(A)" for P)
apply (rule equalityI)
 apply (blast intro: elim: equalityE)
apply (blast intro: elim: equalityCE)
done

text\<open>I don't know why, but if the premise is expressed using meta-connectives
then  the simplifier cannot prove it automatically in conditional rewriting.\<close>
lemma Finite_RepFun_iff:
     "(\<forall>x y. f(x)=f(y) \<longrightarrow> x=y) ==> Finite(RepFun(A,f)) \<longleftrightarrow> Finite(A)"
by (blast intro: Finite_RepFun Finite_RepFun_iff_lemma [of _ f])

lemma Finite_Pow: "Finite(A) ==> Finite(Pow(A))"
apply (erule Finite_induct)
apply (simp_all add: Pow_insert Finite_Un Finite_RepFun)
done

lemma Finite_Pow_imp_Finite: "Finite(Pow(A)) ==> Finite(A)"
apply (subgoal_tac "Finite({{x} . x \<in> A})")
 apply (simp add: Finite_RepFun_iff )
apply (blast intro: subset_Finite)
done

lemma Finite_Pow_iff [iff]: "Finite(Pow(A)) \<longleftrightarrow> Finite(A)"
by (blast intro: Finite_Pow Finite_Pow_imp_Finite)

lemma Finite_cardinal_iff:
  assumes i: "Ord(i)" shows "Finite(|i|) \<longleftrightarrow> Finite(i)"
  by (auto simp add: Finite_def) (blast intro: eqpoll_trans eqpoll_sym Ord_cardinal_eqpoll [OF i])+

(*Krzysztof Grabczewski's proof that the converse of a finite, well-ordered
  set is well-ordered.  Proofs simplified by lcp. *)

lemma nat_wf_on_converse_Memrel: "n \<in> nat ==> wf[n](converse(Memrel(n)))"
proof (induct n rule: nat_induct)
  case 0 thus ?case by (blast intro: wf_onI)
next
  case (succ x)
  hence wfx: "\<And>Z. Z = 0 \<or> (\<exists>z\<in>Z. \<forall>y. z \<in> y \<and> z \<in> x \<and> y \<in> x \<and> z \<in> x \<longrightarrow> y \<notin> Z)"
    by (simp add: wf_on_def wf_def)  \<comment> \<open>not easy to erase the duplicate \<^term>\<open>z \<in> x\<close>!\<close>
  show ?case
    proof (rule wf_onI)
      fix Z u
      assume Z: "u \<in> Z" "\<forall>z\<in>Z. \<exists>y\<in>Z. \<langle>y, z\<rangle> \<in> converse(Memrel(succ(x)))"
      show False
        proof (cases "x \<in> Z")
          case True thus False using Z
            by (blast elim: mem_irrefl mem_asym)
          next
          case False thus False using wfx [of Z] Z
            by blast
        qed
    qed
qed

lemma nat_well_ord_converse_Memrel: "n \<in> nat ==> well_ord(n,converse(Memrel(n)))"
apply (frule Ord_nat [THEN Ord_in_Ord, THEN well_ord_Memrel])
apply (simp add: well_ord_def tot_ord_converse nat_wf_on_converse_Memrel)
done

lemma well_ord_converse:
     "[|well_ord(A,r);
        well_ord(ordertype(A,r), converse(Memrel(ordertype(A, r)))) |]
      ==> well_ord(A,converse(r))"
apply (rule well_ord_Int_iff [THEN iffD1])
apply (frule ordermap_bij [THEN bij_is_inj, THEN well_ord_rvimage], assumption)
apply (simp add: rvimage_converse converse_Int converse_prod
                 ordertype_ord_iso [THEN ord_iso_rvimage_eq])
done

lemma ordertype_eq_n:
  assumes r: "well_ord(A,r)" and A: "A \<approx> n" and n: "n \<in> nat"
  shows "ordertype(A,r) = n"
proof -
  have "ordertype(A,r) \<approx> A"
    by (blast intro: bij_imp_eqpoll bij_converse_bij ordermap_bij r)
  also have "... \<approx> n" by (rule A)
  finally have "ordertype(A,r) \<approx> n" .
  thus ?thesis
    by (simp add: Ord_nat_eqpoll_iff Ord_ordertype n r)
qed

lemma Finite_well_ord_converse:
    "[| Finite(A);  well_ord(A,r) |] ==> well_ord(A,converse(r))"
apply (unfold Finite_def)
apply (rule well_ord_converse, assumption)
apply (blast dest: ordertype_eq_n intro!: nat_well_ord_converse_Memrel)
done

lemma nat_into_Finite: "n \<in> nat ==> Finite(n)"
  by (auto simp add: Finite_def intro: eqpoll_refl)

lemma nat_not_Finite: "~ Finite(nat)"
proof -
  { fix n
    assume n: "n \<in> nat" "nat \<approx> n"
    have "n \<in> nat"    by (rule n)
    also have "... = n" using n
      by (simp add: Ord_nat_eqpoll_iff Ord_nat)
    finally have "n \<in> n" .
    hence False
      by (blast elim: mem_irrefl)
  }
  thus ?thesis
    by (auto simp add: Finite_def)
qed

end


(* Authors: Amine Chaieb & Florian Haftmann, TU Muenchen *)

header {* Falling factorials *}

theory Factorials
imports Complex_Main Stirling
begin

primrec ffact :: "nat \<Rightarrow> 'a::comm_ring_1 \<Rightarrow> 'a"
where
  "ffact 0 a = 1"
| "ffact (Suc n) a = a * ffact n (a - 1)"

lemma ffact_0 [simp]:
  "ffact 0 = (\<lambda>x. 1)"
  by (simp add: fun_eq_iff)

lemma ffact_fact:
  "ffact n (of_nat n) = of_nat (fact n)"
  by (induct n) (simp_all add: algebra_simps of_nat_mult)

lemma ffact_Suc:
  "ffact (Suc n) a = (a - of_nat n) * ffact n a"
proof (induct n arbitrary: a)
  case 0 thus ?case by simp
next
  case (Suc n a)
  moreover have "-2 + a = (a - 1) - 1"
    by simp
  ultimately have hyp:
    "ffact (Suc n) (a - 1) = (a - 1 - of_nat n) * ffact n (a - 1)"
    by (simp only:)
  have "ffact (Suc (Suc n)) a = a * ffact (Suc n) (a - 1)" by simp
  also have "\<dots> = a * (ffact n (a - 1) * (a - of_nat (n + 1)))"
    by (simp only: hyp) (simp add: algebra_simps)
  also have "\<dots> = ffact (Suc n) a * (a - of_nat (Suc n))" by (simp add: algebra_simps)
  finally have "ffact (Suc (Suc n)) a = ffact (Suc n) a * (a - of_nat (Suc n))" .
  then show ?case by (simp add: mult.commute)
qed

lemma ffact_add_diff_assoc:
  "(a - of_nat n) * ffact n a + of_nat n * ffact n a = a * ffact n a"
  by (simp add: algebra_simps)

lemma mult_ffact:
  "a * ffact n a = ffact (Suc n) a + of_nat n * ffact n a"
proof -
  have "ffact (Suc n) a + of_nat n * (ffact n a) = (a - of_nat n) * (ffact n a) + of_nat n * (ffact n a)"
    using ffact_Suc [of n] by auto
  also have "\<dots> = a * ffact n a" using ffact_add_diff_assoc by (simp add: algebra_simps)
  finally show ?thesis by simp
qed

lemma of_int_ffact:
  "of_int (ffact n k) = ffact n (of_int k)"
proof (induct n arbitrary: k)
  case 0 then show ?case by simp
next
  case (Suc n k) then have "of_int (ffact n (k - 1)) = ffact n (of_int (k - 1) :: 'a)" .
  then show ?case by simp
qed

text {* Conversion of natural potences into falling factorials *}

lemma monomial_ffact:
  "a ^ n = (\<Sum>k = 0..n. of_nat (Stirling n k) * ffact k a)"
proof (rule sym, induct n)
  case 0 then show ?case by simp
next
  case (Suc n)
  then have "a ^ Suc n = a * (\<Sum>k = 0..n. of_nat (Stirling n k) * ffact k a)"
    by simp
  also have "\<dots> = (\<Sum>k = 0..n. of_nat (Stirling n k) * (a * ffact k a))"
    by (simp add: setsum_right_distrib algebra_simps)
  also have "\<dots> = (\<Sum>k = 0..n. of_nat (Stirling n k) * ffact (Suc k) a) +
    (\<Sum>k = 0..n. of_nat (Stirling n k) * (of_nat k * ffact k a))"
    by (simp add: setsum.distrib algebra_simps mult_ffact)
  also have "\<dots> = (\<Sum>k = 0.. Suc n. of_nat (Stirling n k) * ffact (Suc k) a) +
    (\<Sum>k = 0..Suc n. of_nat ((Suc k) * (Stirling n (Suc k))) * (ffact (Suc k) a))"
  proof -
    have "(\<Sum>k = 0..n. of_nat (Stirling n k) * (of_nat k * ffact k a)) =
      (\<Sum>k = 0..n+2. of_nat (Stirling n k) * (of_nat k * ffact k a))" by simp
    also have "\<dots> = (\<Sum>k = Suc 0 .. Suc (Suc n). of_nat (Stirling n k) * (of_nat k * ffact k a)) "
      by (simp only: setsum_head_Suc [of 0 "n + 2"]) simp
    also have "\<dots> = (\<Sum>k = 0 .. Suc n. of_nat (Stirling n (Suc k)) * (of_nat (Suc k) * ffact (Suc k) a))"
      by (simp only: image_Suc_atLeastAtMost setsum_shift_bounds_cl_Suc_ivl)
    also have "\<dots> = (\<Sum>k = 0 .. Suc n. of_nat ((Suc k) * Stirling n (Suc k)) * ffact (Suc k) a)"
      by (simp only: of_nat_mult algebra_simps)
    finally have "(\<Sum>k = 0..n. of_nat (Stirling n k) * (of_nat k * ffact k a)) =
      (\<Sum>k = 0..Suc n. of_nat (Suc k * Stirling n (Suc k)) * ffact (Suc k) a)"
      by simp
    then show ?thesis by simp
  qed
  also have "\<dots> = (\<Sum>k = 0..n. of_nat (Stirling (Suc n) (Suc k)) * ffact (Suc k) a)"
    by (simp add: algebra_simps setsum.distrib)
  also have "\<dots> = (\<Sum>k = Suc 0..Suc n. of_nat (Stirling (Suc n) k) * ffact k a)"
    by (simp only: image_Suc_atLeastAtMost setsum_shift_bounds_cl_Suc_ivl)
  also have "\<dots> = (\<Sum>k = 0..Suc n. of_nat (Stirling (Suc n) k) * ffact k a)"
    by (simp only: setsum_head_Suc [of "0" "Suc n"]) simp
  finally show ?case by simp
qed

end


theory Exercise6
  imports Main
begin

fun elems :: "'a list \<Rightarrow> 'a set" where
"elems [] = {}" |
"elems (a # as) = {x. x=a \<or> x \<in> (elems as)}"

theorem "
  x \<in> elems xs
  \<Longrightarrow> \<exists> ys zs. xs = ys @ x # zs
    \<and> x \<notin> elems ys
"
proof (induction xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  hence "x = a \<or> (x \<noteq> a \<and> x \<in> elems xs)" by auto
  thus ?case
  proof
    assume "x = a"
    hence "a # xs = [] @ x # xs \<and> x \<notin> elems []" by simp
    thus ?thesis by fastforce
  next
    assume "x \<noteq> a \<and> x \<in> elems xs"
    hence "
      \<exists> ys zs. a # xs = (a # ys) @ x # zs
      \<and> x \<notin> elems (a # ys)
    " using local.Cons.IH by simp
    thus ?thesis by fastforce
  qed
qed

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

section \<open>Binary Predicates Restricted to Elements of a Given Set\<close>

theory Restricted_Predicates
imports Main
begin

text \<open>
  A subset \<open>C\<close> of \<open>A\<close> is a \emph{chain} on \<open>A\<close> (w.r.t.\ \<open>P\<close>)
  iff for all pairs of elements of \<open>C\<close>, one is less than or equal
  to the other one.
\<close>
abbreviation "chain_on P C A \<equiv> pred_on.chain A P C"
lemmas chain_on_def = pred_on.chain_def

lemma chain_on_subset:
  "A \<subseteq> B \<Longrightarrow> chain_on P C A \<Longrightarrow> chain_on P C B"
by (force simp: chain_on_def)

lemma chain_on_imp_subset:
  "chain_on P C A \<Longrightarrow> C \<subseteq> A"
by (simp add: chain_on_def)

lemma subchain_on:
  assumes "C \<subseteq> D" and "chain_on P D A"
  shows "chain_on P C A"
using assms by (auto simp: chain_on_def)

definition restrict_to :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)" where
  "restrict_to P A = (\<lambda>x y. x \<in> A \<and> y \<in> A \<and> P x y)"

definition reflp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "reflp_on P A \<longleftrightarrow> (\<forall>a\<in>A. P a a)"

definition transp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "transp_on P A \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. P x y \<and> P y z \<longrightarrow> P x z)"

definition total_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "total_on P A \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. x = y \<or> P x y \<or> P y x)"

abbreviation "strict P \<equiv> \<lambda>x y. P x y \<and> \<not> (P y x)"

abbreviation "incomparable P \<equiv> \<lambda>x y. \<not> P x y \<and> \<not> P y x"

abbreviation "antichain_on P f A \<equiv> \<forall>(i::nat) j. f i \<in> A \<and> (i < j \<longrightarrow> incomparable P (f i) (f j))"

lemma strict_reflclp_conv [simp]:
  "strict (P\<^sup>=\<^sup>=) = strict P" by auto

lemma reflp_onI [Pure.intro]:
  "(\<And>a. a \<in> A \<Longrightarrow> P a a) \<Longrightarrow> reflp_on P A"
  unfolding reflp_on_def by blast

lemma transp_onI [Pure.intro]:
  "(\<And>x y z. \<lbrakk>x \<in> A; y \<in> A; z \<in> A; P x y; P y z\<rbrakk> \<Longrightarrow> P x z) \<Longrightarrow> transp_on P A"
  unfolding transp_on_def by blast

lemma total_onI [Pure.intro]:
  "(\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> x = y \<or> P x y \<or> P y x) \<Longrightarrow> total_on P A"
  unfolding total_on_def by blast

lemma reflp_on_reflclp_simp [simp]:
  assumes "reflp_on P A" and "a \<in> A" and "b \<in> A"
  shows "P\<^sup>=\<^sup>= a b = P a b"
  using assms by (auto simp: reflp_on_def)

lemma reflp_on_reflclp:
  "reflp_on (P\<^sup>=\<^sup>=) A"
  by (auto simp: reflp_on_def)

lemma reflp_on_converse_simp [simp]:
  "reflp_on P\<inverse>\<inverse> A \<longleftrightarrow> reflp_on P A"
  by (auto simp: reflp_on_def)

lemma transp_on_converse:
  "transp_on P A \<Longrightarrow> transp_on P\<inverse>\<inverse> A"
  unfolding transp_on_def by blast

lemma transp_on_converse_simp [simp]:
  "transp_on P\<inverse>\<inverse> A \<longleftrightarrow> transp_on P A"
  unfolding transp_on_def by blast

lemma transp_on_reflclp:
  "transp_on P A \<Longrightarrow> transp_on P\<^sup>=\<^sup>= A"
  unfolding transp_on_def by blast

lemma transp_on_strict:
  "transp_on P A \<Longrightarrow> transp_on (strict P) A"
  unfolding transp_on_def by blast

lemma reflp_on_subset:
  "A \<subseteq> B \<Longrightarrow> reflp_on P B \<Longrightarrow> reflp_on P A"
  by (auto simp: reflp_on_def)

lemma transp_on_subset:
  "A \<subseteq> B \<Longrightarrow> transp_on P B \<Longrightarrow> transp_on P A"
  by (auto simp: transp_on_def)

definition wfp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
where
  "wfp_on P A \<longleftrightarrow> \<not> (\<exists>f. \<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i))"

definition inductive_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "inductive_on P A \<longleftrightarrow> (\<forall>Q. (\<forall>y\<in>A. (\<forall>x\<in>A. P x y \<longrightarrow> Q x) \<longrightarrow> Q y) \<longrightarrow> (\<forall>x\<in>A. Q x))"

lemma inductive_onI [Pure.intro]:
  assumes "\<And>Q x. \<lbrakk>x \<in> A; (\<And>y. \<lbrakk>y \<in> A; \<And>x. \<lbrakk>x \<in> A; P x y\<rbrakk> \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> Q y)\<rbrakk> \<Longrightarrow>  Q x"
  shows "inductive_on P A"
  using assms unfolding inductive_on_def by metis

text \<open>
  If @{term P} is well-founded on @{term A} then every non-empty subset @{term Q} of @{term A} has a
  minimal element @{term z} w.r.t. @{term P}, i.e., all elements that are @{term P}-smaller than
  @{term z} are not in @{term Q}.
\<close>
lemma wfp_on_imp_minimal:
  assumes "wfp_on P A"
  shows "\<forall>Q x. x \<in> Q \<and> Q \<subseteq> A \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q)"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain Q x where *: "x \<in> Q" "Q \<subseteq> A"
    and "\<forall>z. \<exists>y. z \<in> Q \<longrightarrow> P y z \<and> y \<in> Q" by metis
  from choice [OF this(3)] obtain f
    where **: "\<forall>x\<in>Q. P (f x) x \<and> f x \<in> Q" by blast
  let ?S = "\<lambda>i. (f ^^ i) x"
  have ***: "\<forall>i. ?S i \<in> Q"
  proof
    fix i show "?S i \<in> Q" by (induct i) (auto simp: * **)
  qed
  then have "\<forall>i. ?S i \<in> A" using * by blast
  moreover have "\<forall>i. P (?S (Suc i)) (?S i)"
  proof
    fix i show "P (?S (Suc i)) (?S i)"
      by (induct i) (auto simp: * ** ***)
  qed
  ultimately have "\<forall>i. ?S i \<in> A \<and> P (?S (Suc i)) (?S i)" by blast
  with assms(1) show False
    unfolding wfp_on_def by fast
qed

lemma minimal_imp_inductive_on:
  assumes "\<forall>Q x. x \<in> Q \<and> Q \<subseteq> A \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q)"
  shows "inductive_on P A"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain Q x
    where *: "\<forall>y\<in>A. (\<forall>x\<in>A. P x y \<longrightarrow> Q x) \<longrightarrow> Q y"
    and **: "x \<in> A" "\<not> Q x"
    by (auto simp: inductive_on_def)
  let ?Q = "{x\<in>A. \<not> Q x}"
  from ** have "x \<in> ?Q" by auto
  moreover have "?Q \<subseteq> A" by auto
  ultimately obtain z where "z \<in> ?Q"
    and min: "\<forall>y. P y z \<longrightarrow> y \<notin> ?Q"
    using assms [THEN spec [of _ ?Q], THEN spec [of _ x]] by blast
  from \<open>z \<in> ?Q\<close> have "z \<in> A" and "\<not> Q z" by auto
  with * obtain y where "y \<in> A" and "P y z" and "\<not> Q y" by auto
  then have "y \<in> ?Q" by auto
  with \<open>P y z\<close> and min show False by auto
qed

lemmas wfp_on_imp_inductive_on =
  wfp_on_imp_minimal [THEN minimal_imp_inductive_on]

lemma inductive_on_induct [consumes 2, case_names less, induct pred: inductive_on]:
  assumes "inductive_on P A" and "x \<in> A"
    and "\<And>y. \<lbrakk> y \<in> A; \<And>x. \<lbrakk> x \<in> A; P x y \<rbrakk> \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> Q y"
  shows "Q x"
  using assms unfolding inductive_on_def by metis

lemma inductive_on_imp_wfp_on:
  assumes "inductive_on P A"
  shows "wfp_on P A"
proof -
  let ?Q = "\<lambda>x. \<not> (\<exists>f. f 0 = x \<and> (\<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i)))"
  { fix x assume "x \<in> A"
    with assms have "?Q x"
    proof (induct rule: inductive_on_induct)
      fix y assume "y \<in> A" and IH: "\<And>x. x \<in> A \<Longrightarrow> P x y \<Longrightarrow> ?Q x"
      show "?Q y"
      proof (rule ccontr)
        assume "\<not> ?Q y"
        then obtain f where *: "f 0 = y"
          "\<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i)" by auto
        then have "P (f (Suc 0)) (f 0)" and "f (Suc 0) \<in> A" by auto
        with IH and * have "?Q (f (Suc 0))" by auto
        with * show False by auto
      qed
    qed }
  then show ?thesis unfolding wfp_on_def by blast
qed

definition antisymp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "antisymp_on P A \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b\<in>A. P a b \<and> P b a \<longrightarrow> a = b)"

lemma antisymp_onI [Pure.intro]:
  "(\<And>a b. \<lbrakk>a \<in> A; b \<in> A; P a b; P b a\<rbrakk> \<Longrightarrow> a = b) \<Longrightarrow> antisymp_on P A"
  by (auto simp: antisymp_on_def)

lemma antisymp_on_reflclp [simp]:
  "antisymp_on P\<^sup>=\<^sup>= A = antisymp_on P A"
  by (auto simp: antisymp_on_def)

definition qo_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "qo_on P A \<longleftrightarrow> reflp_on P A \<and> transp_on P A"

definition irreflp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "irreflp_on P A \<longleftrightarrow> (\<forall>a\<in>A. \<not> P a a)"

definition po_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "po_on P A \<longleftrightarrow> (irreflp_on P A \<and> transp_on P A)"

lemma po_onI [Pure.intro]:
  "\<lbrakk>irreflp_on P A; transp_on P A\<rbrakk> \<Longrightarrow> po_on P A"
  by (auto simp: po_on_def)

lemma irreflp_onI [Pure.intro]:
  "(\<And>a. a \<in> A \<Longrightarrow> \<not> P a a) \<Longrightarrow> irreflp_on P A"
  unfolding irreflp_on_def by blast

lemma irreflp_on_converse:
  "irreflp_on P A \<Longrightarrow> irreflp_on P\<inverse>\<inverse> A"
  unfolding irreflp_on_def by blast

lemma irreflp_on_converse_simp [simp]:
  "irreflp_on P\<inverse>\<inverse> A \<longleftrightarrow> irreflp_on P A"
  by (auto simp: irreflp_on_def)

lemma po_on_converse_simp [simp]:
  "po_on P\<inverse>\<inverse> A \<longleftrightarrow> po_on P A"
  by (simp add: po_on_def)

lemma po_on_imp_qo_on:
  "po_on P A \<Longrightarrow> qo_on (P\<^sup>=\<^sup>=) A"
  unfolding po_on_def qo_on_def
  by (metis reflp_on_reflclp transp_on_reflclp)

lemma po_on_imp_irreflp_on:
  "po_on P A \<Longrightarrow> irreflp_on P A"
  by (auto simp: po_on_def)

lemma po_on_imp_transp_on:
  "po_on P A \<Longrightarrow> transp_on P A"
  by (auto simp: po_on_def)

lemma irreflp_on_subset:
  assumes "A \<subseteq> B" and "irreflp_on P B"
  shows "irreflp_on P A"
  using assms by (auto simp: irreflp_on_def)

lemma po_on_subset:
  assumes "A \<subseteq> B" and "po_on P B"
  shows "po_on P A"
  using transp_on_subset and irreflp_on_subset and assms
  unfolding po_on_def by blast

lemma transp_on_irreflp_on_imp_antisymp_on:
  assumes "transp_on P A" and "irreflp_on P A"
  shows "antisymp_on (P\<^sup>=\<^sup>=) A"
proof
  fix a b assume "a \<in> A"
    and "b \<in> A" and "P\<^sup>=\<^sup>= a b" and "P\<^sup>=\<^sup>= b a"
  show "a = b"
  proof (rule ccontr)
    assume "a \<noteq> b"
    with \<open>P\<^sup>=\<^sup>= a b\<close> and \<open>P\<^sup>=\<^sup>= b a\<close> have "P a b" and "P b a" by auto
    with \<open>transp_on P A\<close> and \<open>a \<in> A\<close> and \<open>b \<in> A\<close> have "P a a" unfolding transp_on_def by blast
    with \<open>irreflp_on P A\<close> and \<open>a \<in> A\<close> show False unfolding irreflp_on_def by blast
  qed
qed

lemma po_on_imp_antisymp_on:
  assumes "po_on P A"
  shows "antisymp_on P A"
using transp_on_irreflp_on_imp_antisymp_on [of P A] and assms by (auto simp: po_on_def)

lemma strict_reflclp [simp]:
  assumes "x \<in> A" and "y \<in> A"
    and "transp_on P A" and "irreflp_on P A"
  shows "strict (P\<^sup>=\<^sup>=) x y = P x y"
  using assms unfolding transp_on_def irreflp_on_def
  by blast

lemma qo_on_imp_reflp_on:
  "qo_on P A \<Longrightarrow> reflp_on P A"
  by (auto simp: qo_on_def)

lemma qo_on_imp_transp_on:
  "qo_on P A \<Longrightarrow> transp_on P A"
  by (auto simp: qo_on_def)

lemma qo_on_subset:
  "A \<subseteq> B \<Longrightarrow> qo_on P B \<Longrightarrow> qo_on P A"
  unfolding qo_on_def
  using reflp_on_subset
    and transp_on_subset by blast

text \<open>
  Quasi-orders are instances of the @{class preorder} class.
\<close>
lemma qo_on_UNIV_conv:
  "qo_on P UNIV \<longleftrightarrow> class.preorder P (strict P)" (is "?lhs = ?rhs")
proof
  assume "?lhs" then show "?rhs"
    unfolding qo_on_def class.preorder_def
    using qo_on_imp_reflp_on [of P UNIV]
      and qo_on_imp_transp_on [of P UNIV]
    by (auto simp: reflp_on_def) (unfold transp_on_def, blast)
next
  assume "?rhs" then show "?lhs"
    unfolding class.preorder_def
    by (auto simp: qo_on_def reflp_on_def transp_on_def)
qed

lemma wfp_on_iff_inductive_on:
  "wfp_on P A \<longleftrightarrow> inductive_on P A"
  by (blast intro: inductive_on_imp_wfp_on wfp_on_imp_inductive_on)

lemma wfp_on_iff_minimal:
  "wfp_on P A \<longleftrightarrow> (\<forall>Q x.
     x \<in> Q \<and> Q \<subseteq> A \<longrightarrow>
     (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q))"
  using wfp_on_imp_minimal [of P A]
    and minimal_imp_inductive_on [of A P]
    and inductive_on_imp_wfp_on [of P A]
    by blast

text \<open>
  Every non-empty well-founded set @{term A} has a minimal element, i.e., an element that is not
  greater than any other element.
\<close>
lemma wfp_on_imp_has_min_elt:
  assumes "wfp_on P A" and "A \<noteq> {}"
  shows "\<exists>x\<in>A. \<forall>y\<in>A. \<not> P y x"
  using assms unfolding wfp_on_iff_minimal by force

lemma wfp_on_induct [consumes 2, case_names less, induct pred: wfp_on]:
  assumes "wfp_on P A" and "x \<in> A"
    and "\<And>y. \<lbrakk> y \<in> A; \<And>x. \<lbrakk> x \<in> A; P x y \<rbrakk> \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> Q y"
  shows "Q x"
  using assms and inductive_on_induct [of P A x]
  unfolding wfp_on_iff_inductive_on by blast

lemma wfp_on_UNIV [simp]:
  "wfp_on P UNIV \<longleftrightarrow> wfP P"
  unfolding wfp_on_iff_inductive_on inductive_on_def wfP_def wf_def by force

subsection \<open>Measures on Sets (Instead of Full Types)\<close>

definition
  inv_image_betw ::
    "('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
where
  "inv_image_betw P f A B = (\<lambda>x y. x \<in> A \<and> y \<in> A \<and> f x \<in> B \<and> f y \<in> B \<and> P (f x) (f y))"

definition
  measure_on :: "('a \<Rightarrow> nat) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "measure_on f A = inv_image_betw (<) f A UNIV"

lemma in_inv_image_betw [simp]:
  "inv_image_betw P f A B x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> f x \<in> B \<and> f y \<in> B \<and> P (f x) (f y)"
  by (auto simp: inv_image_betw_def)

lemma in_measure_on [simp, code_unfold]:
  "measure_on f A x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> f x < f y"
  by (simp add: measure_on_def)

lemma wfp_on_inv_image_betw [simp, intro!]:
  assumes "wfp_on P B"
  shows "wfp_on (inv_image_betw P f A B) A" (is "wfp_on ?P A")
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain g where "\<forall>i. g i \<in> A \<and> ?P (g (Suc i)) (g i)" by (auto simp: wfp_on_def)
  with assms show False by (auto simp: wfp_on_def)
qed

lemma wfp_less:
  "wfp_on (<) (UNIV :: nat set)"
  using wf_less by (auto simp: wfP_def)

lemma wfp_on_measure_on [iff]:
  "wfp_on (measure_on f A) A"
  unfolding measure_on_def
  by (rule wfp_less [THEN wfp_on_inv_image_betw])

lemma wfp_on_mono:
  "A \<subseteq> B \<Longrightarrow> (\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> P x y \<Longrightarrow> Q x y) \<Longrightarrow> wfp_on Q B \<Longrightarrow> wfp_on P A"
  unfolding wfp_on_def by (metis subsetD)

lemma wfp_on_subset:
  "A \<subseteq> B \<Longrightarrow> wfp_on P B \<Longrightarrow> wfp_on P A"
  using wfp_on_mono by blast

lemma restrict_to_iff [iff]:
  "restrict_to P A x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> P x y"
  by (simp add: restrict_to_def)

lemma wfp_on_restrict_to [simp]:
  "wfp_on (restrict_to P A) A = wfp_on P A"
  by (auto simp: wfp_on_def)

lemma irreflp_on_strict [simp, intro]:
  "irreflp_on (strict P) A"
  by (auto simp: irreflp_on_def)

lemma transp_on_map':
  assumes "transp_on Q B"
    and "g ` A \<subseteq> B"
    and "h ` A \<subseteq> B"
    and "\<And>x. x \<in> A \<Longrightarrow> Q\<^sup>=\<^sup>= (h x) (g x)"
  shows "transp_on (\<lambda>x y. Q (g x) (h y)) A"
  using assms unfolding transp_on_def
  by auto (metis imageI subsetD)

lemma transp_on_map:
  assumes "transp_on Q B"
    and "h ` A \<subseteq> B"
  shows "transp_on (\<lambda>x y. Q (h x) (h y)) A"
  using transp_on_map' [of Q B h A h, simplified, OF assms] by blast

lemma irreflp_on_map:
  assumes "irreflp_on Q B"
    and "h ` A \<subseteq> B"
  shows "irreflp_on (\<lambda>x y. Q (h x) (h y)) A"
  using assms unfolding irreflp_on_def by auto

lemma po_on_map:
  assumes "po_on Q B"
    and "h ` A \<subseteq> B"
  shows "po_on (\<lambda>x y. Q (h x) (h y)) A"
  using assms and transp_on_map and irreflp_on_map
  unfolding po_on_def by auto

lemma chain_transp_on_less:
  assumes "\<forall>i. f i \<in> A \<and> P (f i) (f (Suc i))" and "transp_on P A" and "i < j"
  shows "P (f i) (f j)"
using \<open>i < j\<close>
proof (induct j)
  case 0 then show ?case by simp
next
  case (Suc j)
  show ?case
  proof (cases "i = j")
    case True
    with Suc show ?thesis using assms(1) by simp
  next
    case False
    with Suc have "P (f i) (f j)" by force
    moreover from assms have "P (f j) (f (Suc j))" by auto
    ultimately show ?thesis using assms(1, 2) unfolding transp_on_def by blast
  qed
qed

lemma wfp_on_imp_irreflp_on:
  assumes "wfp_on P A"
  shows "irreflp_on P A"
proof
  fix x
  assume "x \<in> A"
  show "\<not> P x x"
  proof
    let ?f = "\<lambda>_. x"
    assume "P x x"
    then have "\<forall>i. P (?f (Suc i)) (?f i)" by blast
    with \<open>x \<in> A\<close> have "\<not> wfp_on P A" by (auto simp: wfp_on_def)
    with assms show False by contradiction
  qed
qed

inductive
  accessible_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> bool"
  for P and A
where
  accessible_onI [Pure.intro]:
    "\<lbrakk>x \<in> A; \<And>y. \<lbrakk>y \<in> A; P y x\<rbrakk> \<Longrightarrow> accessible_on P A y\<rbrakk> \<Longrightarrow> accessible_on P A x"

lemma accessible_on_imp_mem:
  assumes "accessible_on P A a"
  shows "a \<in> A"
  using assms by (induct) auto

lemma accessible_on_induct [consumes 1, induct pred: accessible_on]:
  assumes *: "accessible_on P A a"
    and IH: "\<And>x. \<lbrakk>accessible_on P A x; \<And>y. \<lbrakk>y \<in> A; P y x\<rbrakk> \<Longrightarrow> Q y\<rbrakk> \<Longrightarrow> Q x"
  shows "Q a"
  by (rule * [THEN accessible_on.induct]) (auto intro: IH accessible_onI)

lemma accessible_on_downward:
  "accessible_on P A b \<Longrightarrow> a \<in> A \<Longrightarrow> P a b \<Longrightarrow> accessible_on P A a"
  by (cases rule: accessible_on.cases) fast

lemma accessible_on_restrict_to_downwards:
  assumes "(restrict_to P A)\<^sup>+\<^sup>+ a b" and "accessible_on P A b"
  shows "accessible_on P A a"
  using assms by (induct) (auto dest: accessible_on_imp_mem accessible_on_downward)

lemma accessible_on_imp_inductive_on:
  assumes "\<forall>x\<in>A. accessible_on P A x"
  shows "inductive_on P A"
proof
  fix Q x
  assume "x \<in> A"
    and *: "\<And>y. \<lbrakk>y \<in> A; \<And>x. \<lbrakk>x \<in> A; P x y\<rbrakk> \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> Q y"
  with assms have "accessible_on P A x" by auto
  then show "Q x"
  proof (induct)
    case (1 z)
    then have "z \<in> A" by (blast dest: accessible_on_imp_mem)
    show ?case by (rule *) fact+
  qed
qed

lemmas accessible_on_imp_wfp_on = accessible_on_imp_inductive_on [THEN inductive_on_imp_wfp_on]

lemma wfp_on_tranclp_imp_wfp_on:
  assumes "wfp_on (P\<^sup>+\<^sup>+) A"
  shows "wfp_on P A"
  by (rule ccontr) (insert assms, auto simp: wfp_on_def)

lemma inductive_on_imp_accessible_on:
  assumes "inductive_on P A"
  shows "\<forall>x\<in>A. accessible_on P A x"
proof
  fix x
  assume "x \<in> A"
  with assms show "accessible_on P A x"
    by (induct) (auto intro: accessible_onI)
qed

lemma inductive_on_accessible_on_conv:
  "inductive_on P A \<longleftrightarrow> (\<forall>x\<in>A. accessible_on P A x)"
  using inductive_on_imp_accessible_on
    and accessible_on_imp_inductive_on
    by blast

lemmas wfp_on_imp_accessible_on =
  wfp_on_imp_inductive_on [THEN inductive_on_imp_accessible_on]

lemma wfp_on_accessible_on_iff:
  "wfp_on P A \<longleftrightarrow> (\<forall>x\<in>A. accessible_on P A x)"
  by (blast dest: wfp_on_imp_accessible_on accessible_on_imp_wfp_on)

lemma accessible_on_tranclp:
  assumes "accessible_on P A x"
  shows "accessible_on ((restrict_to P A)\<^sup>+\<^sup>+) A x"
    (is "accessible_on ?P A x")
  using assms
proof (induct)
  case (1 x)
  then have "x \<in> A" by (blast dest: accessible_on_imp_mem)
  then show ?case
  proof (rule accessible_onI)
    fix y
    assume "y \<in> A"
    assume "?P y x"
    then show "accessible_on ?P A y"
    proof (cases)
      assume "restrict_to P A y x"
      with 1 and \<open>y \<in> A\<close> show ?thesis by blast
    next
      fix z
      assume "?P y z" and "restrict_to P A z x"
      with 1 have "accessible_on ?P A z" by (auto simp: restrict_to_def)
      from accessible_on_downward [OF this \<open>y \<in> A\<close> \<open>?P y z\<close>]
        show ?thesis .
    qed
  qed
qed

lemma wfp_on_restrict_to_tranclp:
  assumes "wfp_on P A"
  shows "wfp_on ((restrict_to P A)\<^sup>+\<^sup>+) A"
  using wfp_on_imp_accessible_on [OF assms]
    and accessible_on_tranclp [of P A]
    and accessible_on_imp_wfp_on [of A "(restrict_to P A)\<^sup>+\<^sup>+"]
    by blast

lemma wfp_on_restrict_to_tranclp':
  assumes "wfp_on (restrict_to P A)\<^sup>+\<^sup>+ A"
  shows "wfp_on P A"
  by (rule ccontr) (insert assms, auto simp: wfp_on_def)

lemma wfp_on_restrict_to_tranclp_wfp_on_conv:
  "wfp_on (restrict_to P A)\<^sup>+\<^sup>+ A \<longleftrightarrow> wfp_on P A"
  using wfp_on_restrict_to_tranclp [of P A]
    and wfp_on_restrict_to_tranclp' [of P A]
    by blast

lemma tranclp_idemp [simp]:
  "(P\<^sup>+\<^sup>+)\<^sup>+\<^sup>+ = P\<^sup>+\<^sup>+" (is "?l = ?r")
proof (intro ext)
  fix x y
  show "?l x y = ?r x y"
  proof
    assume "?l x y" then show "?r x y" by (induct) auto
  next
    assume "?r x y" then show "?l x y" by (induct) auto
  qed
qed

(*TODO: move the following 3 lemmas to Transitive_Closure?*)
lemma stepfun_imp_tranclp:
  assumes "f 0 = x" and "f (Suc n) = z"
    and "\<forall>i\<le>n. P (f i) (f (Suc i))"
  shows "P\<^sup>+\<^sup>+ x z"
  using assms
  by (induct n arbitrary: x z)
     (auto intro: tranclp.trancl_into_trancl)

lemma tranclp_imp_stepfun:
  assumes "P\<^sup>+\<^sup>+ x z"
  shows "\<exists>f n. f 0 = x \<and> f (Suc n) = z \<and> (\<forall>i\<le>n. P (f i) (f (Suc i)))"
    (is "\<exists>f n. ?P x z f n")
  using assms
proof (induct rule: tranclp_induct)
  case (base y)
  let ?f = "(\<lambda>_. y)(0 := x)"
  have "?f 0 = x" and "?f (Suc 0) = y" by auto
  moreover have "\<forall>i\<le>0. P (?f i) (?f (Suc i))"
    using base by auto
  ultimately show ?case by blast
next
  case (step y z)
  then obtain f n where IH: "?P x y f n" by blast
  then have *: "\<forall>i\<le>n. P (f i) (f (Suc i))"
    and [simp]: "f 0 = x" "f (Suc n) = y"
    by auto
  let ?n = "Suc n"
  let ?f = "f(Suc ?n := z)"
  have "?f 0 = x" and "?f (Suc ?n) = z" by auto
  moreover have "\<forall>i\<le>?n. P (?f i) (?f (Suc i))"
    using \<open>P y z\<close> and * by auto
  ultimately show ?case by blast
qed

lemma tranclp_stepfun_conv:
  "P\<^sup>+\<^sup>+ x y \<longleftrightarrow> (\<exists>f n. f 0 = x \<and> f (Suc n) = y \<and> (\<forall>i\<le>n. P (f i) (f (Suc i))))"
  using tranclp_imp_stepfun and stepfun_imp_tranclp by metis

subsection \<open>Facts About Predecessor Sets\<close>

lemma qo_on_predecessor_subset_conv':
  assumes "qo_on P A" and "B \<subseteq> A" and "C \<subseteq> A"
  shows "{x\<in>A. \<exists>y\<in>B. P x y} \<subseteq> {x\<in>A. \<exists>y\<in>C. P x y} \<longleftrightarrow> (\<forall>x\<in>B. \<exists>y\<in>C. P x y)"
  using assms
  by (auto simp: subset_eq qo_on_def reflp_on_def, unfold transp_on_def) metis+

lemma qo_on_predecessor_subset_conv:
  "\<lbrakk>qo_on P A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> {z\<in>A. P z x} \<subseteq> {z\<in>A. P z y} \<longleftrightarrow> P x y"
  using qo_on_predecessor_subset_conv' [of P A "{x}" "{y}"] by simp

lemma po_on_predecessors_eq_conv:
  assumes "po_on P A" and "x \<in> A" and "y \<in> A"
  shows "{z\<in>A. P\<^sup>=\<^sup>= z x} = {z\<in>A. P\<^sup>=\<^sup>= z y} \<longleftrightarrow> x = y"
  using assms(2-)
    and reflp_on_reflclp [of P A]
    and po_on_imp_antisymp_on [OF \<open>po_on P A\<close>]
    unfolding antisymp_on_def reflp_on_def
    by blast

lemma restrict_to_rtranclp:
  assumes "transp_on P A"
    and "x \<in> A" and "y \<in> A"
  shows "(restrict_to P A)\<^sup>*\<^sup>* x y \<longleftrightarrow> P\<^sup>=\<^sup>= x y"
proof -
  { assume "(restrict_to P A)\<^sup>*\<^sup>* x y"
    then have "P\<^sup>=\<^sup>= x y" using assms
      by (induct) (auto, unfold transp_on_def, blast) }
  with assms show ?thesis by auto
qed

lemma reflp_on_restrict_to_rtranclp:
  assumes "reflp_on P A" and "transp_on P A"
    and "x \<in> A" and "y \<in> A"
  shows "(restrict_to P A)\<^sup>*\<^sup>* x y \<longleftrightarrow> P x y"
  unfolding restrict_to_rtranclp [OF assms(2-)]
  unfolding reflp_on_reflclp_simp [OF assms(1, 3-)] ..

end


(*
    $Id: ex.thy,v 1.3 2008/07/04 15:37:21 nipkow Exp $
*)

header {* Sum of List Elements, Tail-Recursively *}

(*<*) theory ex imports Main begin (*>*)

text {*
\begin{description}
\item[\bf (a)] Define a primitive recursive function @{term ListSum} that
computes the sum of all elements of a list of natural numbers.

Prove the following equations.  Note that @{term  "[0..n]"} und @{term
"replicate n a"} are already defined in a theory {\tt List.thy}.
\end{description}
*}

  consts ListSum :: "nat list \<Rightarrow> nat"

  theorem "2 * ListSum [0..<n+1] = n * (n + 1)" (*<*) oops (*>*)

  theorem "ListSum (replicate n a) = n * a" (*<*) oops (*>*)

text {*
\begin{description}
\item[\bf (b)] Define an equivalent function @{term ListSumT} using a
tail-recursive function @{term ListSumTAux}.  Prove that @{term ListSum}
and @{term ListSumT} are in fact equivalent.
\end{description}
*}

  consts ListSumTAux :: "nat list \<Rightarrow> nat \<Rightarrow> nat"

  consts ListSumT :: "nat list \<Rightarrow> nat"

  theorem "ListSum xs = ListSumT xs" (*<*) oops (*>*)

(*<*) end (*>*)


theory Inductive_Demo
imports Main
begin

subsection{*Inductive definition of the even numbers*}

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc(Suc n))"

thm ev0 evSS
thm ev.intros

text{* Using the introduction rules: *}
lemma "ev (Suc(Suc(Suc(Suc 0))))"
oops

thm evSS[OF evSS[OF ev0]]

text{* A recursive definition of evenness: *}
fun evn :: "nat \<Rightarrow> bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc(Suc n)) = evn n"

text{*A simple example of rule induction: *}
lemma "ev n \<Longrightarrow> evn n"
  apply(induction rule: ev.induct)
    by auto

text{* An induction on the computation of evn: *}
lemma "evn n \<Longrightarrow> ev n"
  apply(induction n rule: evn.induct)
    apply (simp add: ev0)
   apply simp
  apply (rule evSS)
  apply simp
    done

lemma "evn n \<Longrightarrow> ev n"
  apply(induction n rule: evn.induct)
  apply (auto intro: ev.intros)
  done

text{* No problem with termination because the premises are always smaller
than the conclusion: *}
declare ev.intros[simp,intro]

text{* A shorter proof: *}
lemma "evn n \<Longrightarrow> ev n"
apply(induction n rule: evn.induct)
apply(simp_all)
done

text{* The power of arith: *}
lemma "ev n \<Longrightarrow> \<exists>k. n = 2*k"
  apply(induction rule: ev.induct)
    apply auto try0
  by presburger

subsection{*Inductive definition of the reflexive transitive closure *}

inductive
  star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_trans:
  "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
apply(induction rule: star.induct)
apply(assumption)
apply (blast intro: step)
done

(* The last definition defines star by prepending a new element in every step.
  We could also have defined it by appending a new element:
*)

inductive
  star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
for r where
refl':  "star' r x x" |
step':  "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma star'_trans:
  "star' r x y \<Longrightarrow> star' r y z \<Longrightarrow> star' r x z"
apply (rotate_tac)  (* Note: Rule induction applies to first assumption!
  However, we need to induction on the derivation of star' r y z!
  With Isar, we will be able to write this more concisely.
*)
apply(induction rule: star'.induct)
apply(assumption)
apply (blast intro: step')
done

(* To prove equality of star and star', it's a good idea to prove both directions \<Longrightarrow> and \<Longleftarrow> separately: *)

lemma star_imp_star': "star r x y \<Longrightarrow> star' r x y"
  apply (induction rule: star.induct)
   apply (rule refl')
  thm star'_trans[OF step'[OF refl']] (* Let's assemble a suitable theorem to solve the second subgoal *)
  apply (rule star'_trans[OF step'[OF refl']])
  apply (assumption)
  apply (assumption)
  done

(* Of course, we can summarize the whole proof into a single auto application *)
lemma "star r x y \<Longrightarrow> star' r x y"
  apply (induction rule: star.induct)
  apply (auto intro: refl' star'_trans[OF step'[OF refl']])
  done

(* The other direction *)
lemma star'_imp_star: "star' r x y \<Longrightarrow> star r x y"
  apply (induction rule: star'.induct)
  thm star_trans[OF _ step[OF _ refl]]
  by (auto intro: refl star_trans[OF _ step[OF _ refl]])

(* The equality lemma *)
lemma star'_eq_star: "star' r x y = star r x y"
  by (auto intro: star_imp_star' star'_imp_star)

(* We can also omit the arguments *)
thm ext
lemma "star' = star"
  apply (rule ext)
  apply (rule ext)
  apply (rule ext)
  by (rule star'_eq_star)

thm ext (* Two functions are equal if they are equal for any argument *)

lemma "star' = star"
  apply (intro ext) (* Apply given rules as often as possible *)
  by (rule star'_eq_star)

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

header {* Definition of Ordinals *}

theory OrdinalDef
imports Main
begin

subsection {* Preliminary datatype for ordinals *}

datatype ord0 = ord0_Zero | ord0_Lim "nat \<Rightarrow> ord0"

text {* subterm ordering on ord0 *}

definition
  ord0_prec :: "(ord0 \<times> ord0) set" where
  "ord0_prec = (\<Union>f i. {(f i, ord0_Lim f)})"

lemma wf_ord0_prec: "wf ord0_prec"
 apply (unfold ord0_prec_def)
 apply (rule wfUNIVI, induct_tac x)
  apply (drule spec, erule mp, simp)
 apply (drule spec, erule mp, auto)
done

lemmas ord0_prec_induct = wf_induct[OF wf_trancl[OF wf_ord0_prec]]

text {* less-than-or-equal ordering on ord0 *}

inductive_set ord0_leq :: "(ord0 \<times> ord0) set" where
"\<lbrakk>\<forall>a. (a,x) \<in> ord0_prec\<^sup>+ \<longrightarrow> (\<exists>b. (b,y) \<in> ord0_prec\<^sup>+ \<and> (a,b) \<in> ord0_leq)\<rbrakk>
  \<Longrightarrow> (x,y) \<in> ord0_leq"

lemma ord0_leqI:
"\<lbrakk>\<forall>a. (a,x) \<in> ord0_prec\<^sup>+ \<longrightarrow> (a,y) \<in> ord0_leq O ord0_prec\<^sup>+\<rbrakk>
 \<Longrightarrow> (x,y) \<in> ord0_leq"
by (rule ord0_leq.intros, auto)

lemma ord0_leqD:
"\<lbrakk>(x,y) \<in> ord0_leq; (a,x) \<in> ord0_prec\<^sup>+\<rbrakk> \<Longrightarrow> (a,y) \<in> ord0_leq O ord0_prec\<^sup>+"
by (ind_cases "(x,y) \<in> ord0_leq", auto)

lemma ord0_leq_refl: "(x, x) \<in> ord0_leq"
by (rule ord0_prec_induct, rule ord0_leqI, auto)

lemma ord0_leq_trans[rule_format]:
"\<forall>y. (x,y) \<in> ord0_leq \<longrightarrow>
   (\<forall>z. (y,z) \<in> ord0_leq \<longrightarrow> (x,z) \<in> ord0_leq)"
 apply (rule ord0_prec_induct, clarify)
 apply (rule ord0_leqI, clarify)
 apply (drule spec, drule mp, assumption)
 apply (drule ord0_leqD, assumption, clarify)
 apply (drule spec, drule mp, assumption)
 apply (drule ord0_leqD, assumption, clarify)
 apply (drule spec, drule mp, assumption)
 apply auto
done

lemma wf_ord0_leq: "wf (ord0_leq O ord0_prec\<^sup>+)"
 apply (unfold wf_def, clarify)
 apply (subgoal_tac "\<forall>z. (z,x) \<in> ord0_leq \<longrightarrow> P z")
  apply (drule spec, erule mp, rule ord0_leq_refl)
 apply (rule ord0_prec_induct, clarify)
 apply (drule spec, erule mp, clarify)
 apply (drule ord0_leqD, assumption, clarify)
 apply (drule spec, drule mp, assumption)
 apply (drule spec, erule mp)
 apply (erule ord0_leq_trans, assumption)
done

text {* ordering on ord0 *}

instantiation ord0 :: ord
begin

definition
  ord0_less_def: "x < y \<longleftrightarrow> (x,y) \<in> ord0_leq O ord0_prec\<^sup>+"

definition
  ord0_le_def:   "x \<le> y \<longleftrightarrow> (x,y) \<in> ord0_leq"

instance ..

end

lemma ord0_order_refl[simp]: "(x::ord0) \<le> x"
by (unfold ord0_le_def, rule ord0_leq_refl)

lemma ord0_order_trans: "\<lbrakk>(x::ord0) \<le> y; y \<le> z\<rbrakk> \<Longrightarrow> x \<le> z"
by (unfold ord0_le_def, rule ord0_leq_trans)

lemma ord0_wf: "wf {(x,y::ord0). x < y}"
 apply (subgoal_tac "{(x,y). x < y} = ord0_leq O ord0_prec\<^sup>+")
  apply (simp add: wf_ord0_leq)
 apply (auto simp add: ord0_less_def)
done

lemmas ord0_less_induct = wf_induct[OF ord0_wf]

lemma ord0_leI:
"\<lbrakk>\<forall>a::ord0. a < x \<longrightarrow> a < y\<rbrakk> \<Longrightarrow> x \<le> y"
 apply (unfold ord0_less_def ord0_le_def)
 apply (rule ord0_leqI[rule_format])
 apply (drule spec, erule mp)
 apply (erule relcompI[OF ord0_leq_refl])
done

lemma ord0_less_le_trans:
"\<lbrakk>(x::ord0) < y; y \<le> z\<rbrakk> \<Longrightarrow> x < z"
 apply (unfold ord0_le_def ord0_less_def, clarify)
 apply (drule ord0_leqD, assumption, clarify)
by (rule relcompI[OF ord0_leq_trans])

lemma ord0_le_less_trans:
"\<lbrakk>(x::ord0) \<le> y; y < z\<rbrakk> \<Longrightarrow> x < z"
 apply (unfold ord0_le_def ord0_less_def, clarify)
by (rule relcompI[OF ord0_leq_trans])

lemma rev_ord0_le_less_trans:
"\<lbrakk>(y::ord0) < z; x \<le> y\<rbrakk> \<Longrightarrow> x < z"
by (rule ord0_le_less_trans)

lemma ord0_less_trans:
"\<lbrakk>(x::ord0) < y; y < z\<rbrakk> \<Longrightarrow> x < z"
 apply (unfold ord0_less_def, clarify)
 apply (drule ord0_leqD, assumption, clarify)
by (rule relcompI[OF ord0_leq_trans trancl_trans])

lemma ord0_less_imp_le: "(x::ord0) < y \<Longrightarrow> x \<le> y"
by (rule ord0_leI[rule_format], rule ord0_less_trans)

lemma ord0_linear_lemma:
fixes m :: ord0 and n :: ord0
shows "m < n \<or> n < m \<or> (m \<le> n \<and> n \<le> m)"
 apply (rule_tac x=m in spec)
 apply (rule_tac a=n in ord0_less_induct, rename_tac n)
 apply (rule allI, rename_tac m)
 apply (rule_tac a=m in ord0_less_induct, rename_tac m)
 apply (case_tac "\<forall>a. a < n \<longrightarrow> a < m")
  apply (rule disjI2)
  apply (case_tac "\<forall>a. a < m \<longrightarrow> a < n")
   apply (rule disjI2)
   apply (rule conjI, erule ord0_leI, erule ord0_leI)
  apply (rule disjI1, clarsimp)
  apply (drule spec, drule mp, assumption)
  apply (erule rev_ord0_le_less_trans)
  apply (force simp add: ord0_less_imp_le)
 apply (rule disjI1, clarsimp)
 apply (drule spec, drule mp, assumption)
 apply (drule_tac x=m in spec, simp)
 apply (erule rev_ord0_le_less_trans)
 apply (force simp add: ord0_less_imp_le)
done

lemma ord0_linear: "(x::ord0) \<le> y \<or> y \<le> x"
 apply (cut_tac ord0_linear_lemma[of x y])
 apply (auto dest: ord0_less_imp_le)
done

lemma ord0_order_less_le: "(x::ord0) < y = (x \<le> y \<and> \<not> y \<le> x)"
 apply (rule iffI)
  apply (clarsimp simp add: ord0_less_imp_le)
  apply (drule ord0_less_le_trans, assumption)
  apply (cut_tac a=x in wf_not_refl[OF ord0_wf], simp)
 apply (cut_tac ord0_linear_lemma[of x y], simp)
 apply (auto dest: ord0_less_imp_le)
done

subsection {* Ordinal type *}

definition
  ord0rel :: "(ord0 \<times> ord0) set" where
  "ord0rel = {(x,y). x \<le> y \<and> y \<le> x}"

typedef ordinal = "(UNIV::ord0 set) // ord0rel"
by (unfold quotient_def, auto)

theorem Abs_ordinal_cases2 [case_names Abs_ordinal, cases type: ordinal]:
"(\<And>z. x = Abs_ordinal (ord0rel `` {z}) \<Longrightarrow> P) \<Longrightarrow> P"
by (cases x, auto simp add: quotient_def)

instantiation ordinal :: ord
begin

definition
  ordinal_less_def: "x < y \<longleftrightarrow> (\<forall>a\<in>Rep_ordinal x. \<forall>b\<in>Rep_ordinal y. a < b)"

definition
  ordinal_le_def: "x \<le> y \<longleftrightarrow> (\<forall>a\<in>Rep_ordinal x. \<forall>b\<in>Rep_ordinal y. a \<le> b)"

instance ..

end

lemma Rep_Abs_ord0rel [simp]:
"Rep_ordinal (Abs_ordinal (ord0rel `` {x})) = (ord0rel `` {x})"
by (simp add: Abs_ordinal_inverse quotientI)

lemma mem_ord0rel_Image [simp, intro!]: "x \<in> ord0rel `` {x}"
by (simp add: ord0rel_def)

lemma equiv_ord0rel: "equiv UNIV ord0rel"
 apply (unfold equiv_def refl_on_def sym_def trans_def ord0rel_def)
 apply (auto elim: ord0_order_trans)
done

lemma Abs_ordinal_eq[simp]:
"(Abs_ordinal (ord0rel `` {x}) = Abs_ordinal (ord0rel `` {y}))
  = (x \<le> y \<and> y \<le> x)"
 apply (simp add: Abs_ordinal_inject quotientI)
 apply (simp add: eq_equiv_class_iff[OF equiv_ord0rel])
 apply (simp add: ord0rel_def)
done

lemma Abs_ordinal_le[simp]:
"Abs_ordinal (ord0rel `` {x}) \<le> Abs_ordinal (ord0rel `` {y}) = (x \<le> y)"
 apply (auto simp add: ordinal_le_def)
 apply (unfold ord0rel_def)
 apply (auto elim: ord0_order_trans)
done

lemma Abs_ordinal_less[simp]:
"Abs_ordinal (ord0rel `` {x}) < Abs_ordinal (ord0rel `` {y}) = (x < y)"
 apply (auto simp add: ordinal_less_def)
 apply (unfold ord0rel_def)
 apply (auto elim: ord0_less_le_trans[OF rev_ord0_le_less_trans])
done

lemma ordinal_order_refl: "(x::ordinal) \<le> x"
by (cases x, simp)

lemma ordinal_order_trans: "(x::ordinal) \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
by (cases x, cases y, cases z, auto elim: ord0_order_trans)

lemma ordinal_order_antisym: "(x::ordinal) \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
by (cases x, cases y, simp)

lemma ordinal_linear: "(x::ordinal) \<le> y \<or> y \<le> x"
by (cases x, cases y, simp add: ord0_linear)

lemma ordinal_wf: "wf {(x,y::ordinal). x < y}"
 apply (rule wfUNIVI)
 apply (rule_tac x=x in Abs_ordinal_cases2, clarify)
 apply (rule ord0_less_induct, rename_tac a)
 apply (drule spec, erule mp, clarify)
 apply (rule_tac x=y in Abs_ordinal_cases2, simp)
done

instance ordinal :: wellorder
 apply (rule wf_wellorderI)
 apply (rule ordinal_wf)
 apply (intro_classes)
       apply (rule ordinal_order_less_le_not_le)
      apply (rule ordinal_order_refl)
     apply (rule ordinal_order_trans, assumption+)
    apply (rule ordinal_order_antisym, assumption+)
  apply (rule ordinal_linear)
done

subsection {* Induction over ordinals *}

text "zero and strict limits"

definition
  oZero :: "ordinal" where
    "oZero = Abs_ordinal (ord0rel `` {ord0_Zero})"

definition
  oStrictLimit :: "(nat \<Rightarrow> ordinal) \<Rightarrow> ordinal" where
    "oStrictLimit f = Abs_ordinal
      (ord0rel `` {ord0_Lim (\<lambda>n. SOME x. x \<in> Rep_ordinal (f n))})"

text "induction over ordinals"

lemma ord0relD: "(x,y) \<in> ord0rel \<Longrightarrow> x \<le> y \<and> y \<le> x"
by (simp add: ord0rel_def)

lemma ord0_precD: "(x,y) \<in> ord0_prec \<Longrightarrow> \<exists>f n. x = f n \<and> y = ord0_Lim f"
by (simp add: ord0_prec_def)

lemma less_ord0_LimI: "f n < ord0_Lim f"
 apply (simp add: ord0_less_def)
 apply (rule relcompI[OF ord0_leq_refl])
 apply (rule r_into_trancl)
 apply (auto simp add: ord0_prec_def)
done

lemma less_ord0_LimD: "x < ord0_Lim f \<Longrightarrow> \<exists>n. x \<le> f n"
 apply (simp add: ord0_less_def, clarify)
 apply (erule tranclE)
  apply (drule ord0_precD, clarify)
  apply (force simp add: ord0_le_def)
 apply (drule ord0_precD, clarify)
 apply (rule_tac x=n in exI)
 apply (rule ord0_less_imp_le)
 apply (auto simp add: ord0_less_def)
done

lemma some_ord0rel: "(x, SOME y. (x,y) \<in> ord0rel) \<in> ord0rel"
by (rule_tac x=x in someI, simp add: ord0rel_def)

lemma ord0_Lim_le:
"\<forall>n. f n \<le> g n \<Longrightarrow> ord0_Lim f \<le> ord0_Lim g"
 apply (rule ord0_leI[rule_format])
 apply (drule less_ord0_LimD, clarify)
 apply (erule ord0_le_less_trans)
 apply (drule_tac x=n in spec)
 apply (erule ord0_le_less_trans)
 apply (rule less_ord0_LimI)
done

lemma ord0_Lim_ord0rel:
"\<forall>n. (f n, g n) \<in> ord0rel \<Longrightarrow> (ord0_Lim f, ord0_Lim g) \<in> ord0rel"
by (simp add: ord0rel_def ord0_Lim_le)

lemma Abs_ordinal_oStrictLimit:
"Abs_ordinal (ord0rel `` {ord0_Lim f})
  = oStrictLimit (\<lambda>n. Abs_ordinal (ord0rel `` {f n}))"
 apply (simp add: oStrictLimit_def)
 apply (rule ord0relD)
 apply (rule ord0_Lim_ord0rel)
 apply (simp add: some_ord0rel)
done

lemma oStrictLimit_induct:
assumes base: "P oZero"
assumes step: "\<And>f. \<forall>n. P (f n) \<Longrightarrow> P (oStrictLimit f)"
shows "P a"
 apply (cases a, clarsimp)
 apply (induct_tac z)
  apply (rule base[unfolded oZero_def])
 apply (simp add: Abs_ordinal_oStrictLimit step)
done

text "order properties of 0 and strict limits"

lemma oZero_least: "oZero \<le> x"
 apply (unfold oZero_def, cases x, clarsimp)
 apply (induct_tac z, simp, atomize)
 apply (rule ord0_less_imp_le)
 apply (rule ord0_le_less_trans)
 apply (auto simp: less_ord0_LimI)
done

lemma oStrictLimit_ub: "f n < oStrictLimit f"
 apply (cases "f n", simp add: oStrictLimit_def)
 apply (rule_tac y="SOME x. x \<in> Rep_ordinal (f n)" in ord0_le_less_trans)
  apply (simp, rule ord0relD[THEN conjunct1])
  apply (rule some_ord0rel)
 apply (rule less_ord0_LimI)
done

lemma oStrictLimit_lub: "\<forall>n. f n < x \<Longrightarrow> oStrictLimit f \<le> x"
 apply (erule contrapos_pp, simp add: linorder_not_less linorder_not_le)
 apply (cases x, simp add: oStrictLimit_def)
 apply (drule less_ord0_LimD, clarify)
 apply (rule_tac x=n in exI)
 apply (rule_tac x="f n" in Abs_ordinal_cases2, simp, rename_tac y)
 apply (erule ord0_order_trans)
 apply (rule ord0relD[THEN conjunct2])
 apply (rule some_ord0rel)
done

lemma less_oStrictLimitD: "x < oStrictLimit f \<Longrightarrow> \<exists>n. x \<le> f n"
 apply (erule contrapos_pp)
 apply (simp add: linorder_not_less linorder_not_le)
 apply (erule oStrictLimit_lub)
done

end