diff --git a/src/ZF/AC/AC15_WO6.thy b/src/ZF/AC/AC15_WO6.thy
--- a/src/ZF/AC/AC15_WO6.thy
+++ b/src/ZF/AC/AC15_WO6.thy
@@ -1,289 +1,289 @@
 (*  Title:      ZF/AC/AC15_WO6.thy
     Author:     Krzysztof Grabczewski
 
 The proofs needed to state that AC10, ..., AC15 are equivalent to the rest.
 We need the following:
 
 WO1 \<Longrightarrow> AC10(n) \<Longrightarrow> AC11 \<Longrightarrow> AC12 \<Longrightarrow> AC15 \<Longrightarrow> WO6
 
 In order to add the formulations AC13 and AC14 we need:
 
 AC10(succ(n)) \<Longrightarrow> AC13(n) \<Longrightarrow> AC14 \<Longrightarrow> AC15
 
 or
 
 AC1 \<Longrightarrow> AC13(1);  AC13(m) \<Longrightarrow> AC13(n) \<Longrightarrow> AC14 \<Longrightarrow> AC15    (m\<le>n)
 
 So we don't have to prove all implications of both cases.
 Moreover we don't need to prove AC13(1) \<Longrightarrow> AC1 and AC11 \<Longrightarrow> AC14 as
 Rubin \<and> Rubin do.
 *)
 
 theory AC15_WO6
 imports HH Cardinal_aux
 begin
 
 
 (* ********************************************************************** *)
 (* Lemmas used in the proofs in which the conclusion is AC13, AC14        *)
 (* or AC15                                                                *)
 (*  - cons_times_nat_not_Finite                                           *)
 (*  - ex_fun_AC13_AC15                                                    *)
 (* ********************************************************************** *)
 
 lemma lepoll_Sigma: "A\<noteq>0 \<Longrightarrow> B \<lesssim> A*B"
   unfolding lepoll_def
 apply (erule not_emptyE)
 apply (rule_tac x = "\<lambda>z \<in> B. \<langle>x,z\<rangle>" in exI)
 apply (fast intro!: snd_conv lam_injective)
 done
 
 lemma cons_times_nat_not_Finite:
      "0\<notin>A \<Longrightarrow> \<forall>B \<in> {cons(0,x*nat). x \<in> A}. \<not>Finite(B)"
 apply clarify 
 apply (rule nat_not_Finite [THEN notE] )
 apply (subgoal_tac "x \<noteq> 0")
  apply (blast intro: lepoll_Sigma [THEN lepoll_Finite])+
 done
 
 lemma lemma1: "\<lbrakk>\<Union>(C)=A; a \<in> A\<rbrakk> \<Longrightarrow> \<exists>B \<in> C. a \<in> B \<and> B \<subseteq> A"
 by fast
 
 lemma lemma2: 
         "\<lbrakk>pairwise_disjoint(A); B \<in> A; C \<in> A; a \<in> B; a \<in> C\<rbrakk> \<Longrightarrow> B=C"
 by (unfold pairwise_disjoint_def, blast) 
 
 lemma lemma3: 
      "\<forall>B \<in> {cons(0, x*nat). x \<in> A}. pairwise_disjoint(f`B) \<and>   
              sets_of_size_between(f`B, 2, n) \<and> \<Union>(f`B)=B   
      \<Longrightarrow> \<forall>B \<in> A. \<exists>! u. u \<in> f`cons(0, B*nat) \<and> u \<subseteq> cons(0, B*nat) \<and>   
              0 \<in> u \<and> 2 \<lesssim> u \<and> u \<lesssim> n"
   unfolding sets_of_size_between_def
 apply (rule ballI)
 apply (erule_tac x="cons(0, B*nat)" in ballE)
  apply (blast dest: lemma1 intro!: lemma2, blast)
 done
 
 lemma lemma4: "\<lbrakk>A \<lesssim> i; Ord(i)\<rbrakk> \<Longrightarrow> {P(a). a \<in> A} \<lesssim> i"
   unfolding lepoll_def
 apply (erule exE)
 apply (rule_tac x = "\<lambda>x \<in> RepFun(A,P). \<mu> j. \<exists>a\<in>A. x=P(a) \<and> f`a=j" 
        in exI)
 apply (rule_tac d = "\<lambda>y. P (converse (f) `y) " in lam_injective)
 apply (erule RepFunE)
 apply (frule inj_is_fun [THEN apply_type], assumption)
 apply (fast intro: LeastI2 elim!: Ord_in_Ord inj_is_fun [THEN apply_type])
 apply (erule RepFunE)
 apply (rule LeastI2)
   apply fast
  apply (fast elim!: Ord_in_Ord inj_is_fun [THEN apply_type])
 apply (fast elim: sym left_inverse [THEN ssubst])
 done
 
 lemma lemma5_1:
      "\<lbrakk>B \<in> A; 2 \<lesssim> u(B)\<rbrakk> \<Longrightarrow> (\<lambda>x \<in> A. {fst(x). x \<in> u(x)-{0}})`B \<noteq> 0"
 apply simp
 apply (fast dest: lepoll_Diff_sing 
             elim: lepoll_trans [THEN succ_lepoll_natE] ssubst
             intro!: lepoll_refl)
 done
 
 lemma lemma5_2:
      "\<lbrakk>B \<in> A; u(B) \<subseteq> cons(0, B*nat)\<rbrakk>   
       \<Longrightarrow> (\<lambda>x \<in> A. {fst(x). x \<in> u(x)-{0}})`B \<subseteq> B"
 apply auto 
 done
 
 lemma lemma5_3:
      "\<lbrakk>n \<in> nat; B \<in> A; 0 \<in> u(B); u(B) \<lesssim> succ(n)\<rbrakk>   
       \<Longrightarrow> (\<lambda>x \<in> A. {fst(x). x \<in> u(x)-{0}})`B \<lesssim> n"
 apply simp
 apply (fast elim!: Diff_lepoll [THEN lemma4 [OF _ nat_into_Ord]])
 done
 
 lemma ex_fun_AC13_AC15:
      "\<lbrakk>\<forall>B \<in> {cons(0, x*nat). x \<in> A}.   
                 pairwise_disjoint(f`B) \<and>   
                 sets_of_size_between(f`B, 2, succ(n)) \<and> \<Union>(f`B)=B; 
          n \<in> nat\<rbrakk>   
       \<Longrightarrow> \<exists>f. \<forall>B \<in> A. f`B \<noteq> 0 \<and> f`B \<subseteq> B \<and> f`B \<lesssim> n"
 by (fast del: subsetI notI
          dest!: lemma3 theI intro!: lemma5_1 lemma5_2 lemma5_3)
 
 
 (* ********************************************************************** *)
 (* The target proofs                                                      *)
 (* ********************************************************************** *)
 
 (* ********************************************************************** *)
 (* AC10(n) \<Longrightarrow> AC11                                                       *)
 (* ********************************************************************** *)
 
 theorem AC10_AC11: "\<lbrakk>n \<in> nat; 1\<le>n; AC10(n)\<rbrakk> \<Longrightarrow> AC11"
 by (unfold AC10_def AC11_def, blast)
 
 (* ********************************************************************** *)
 (* AC11 \<Longrightarrow> AC12                                                          *)
 (* ********************************************************************** *)
 
 theorem AC11_AC12: "AC11 \<Longrightarrow> AC12"
 by (unfold AC10_def AC11_def AC11_def AC12_def, blast)
 
 (* ********************************************************************** *)
 (* AC12 \<Longrightarrow> AC15                                                          *)
 (* ********************************************************************** *)
 
 theorem AC12_AC15: "AC12 \<Longrightarrow> AC15"
-apply (unfold AC12_def AC15_def)
+  unfolding AC12_def AC15_def
 apply (blast del: ballI 
              intro!: cons_times_nat_not_Finite ex_fun_AC13_AC15)
 done
 
 (* ********************************************************************** *)
 (* AC15 \<Longrightarrow> WO6                                                           *)
 (* ********************************************************************** *)
 
 lemma OUN_eq_UN: "Ord(x) \<Longrightarrow> (\<Union>a<x. F(a)) = (\<Union>a \<in> x. F(a))"
 by (fast intro!: ltI dest!: ltD)
 
 lemma AC15_WO6_aux1:
      "\<forall>x \<in> Pow(A)-{0}. f`x\<noteq>0 \<and> f`x \<subseteq> x \<and> f`x \<lesssim> m 
       \<Longrightarrow> (\<Union>i<\<mu> x. HH(f,A,x)={A}. HH(f,A,i)) = A"
 apply (simp add: Ord_Least [THEN OUN_eq_UN])
 apply (rule equalityI)
 apply (fast dest!: less_Least_subset_x)
 apply (blast del: subsetI 
            intro!: f_subsets_imp_UN_HH_eq_x [THEN Diff_eq_0_iff [THEN iffD1]])
 done
 
 lemma AC15_WO6_aux2:
      "\<forall>x \<in> Pow(A)-{0}. f`x\<noteq>0 \<and> f`x \<subseteq> x \<and> f`x \<lesssim> m 
       \<Longrightarrow> \<forall>x < (\<mu> x. HH(f,A,x)={A}). HH(f,A,x) \<lesssim> m"
 apply (rule oallI)
 apply (drule ltD [THEN less_Least_subset_x])
 apply (frule HH_subset_imp_eq)
 apply (erule ssubst)
 apply (blast dest!: HH_subset_x_imp_subset_Diff_UN [THEN not_emptyI2])
         (*but can't use del: DiffE despite the obvious conflict*)
 done
 
 theorem AC15_WO6: "AC15 \<Longrightarrow> WO6"
-apply (unfold AC15_def WO6_def)
+  unfolding AC15_def WO6_def
 apply (rule allI)
 apply (erule_tac x = "Pow (A) -{0}" in allE)
 apply (erule impE, fast)
 apply (elim bexE conjE exE)
 apply (rule bexI)
  apply (rule conjI, assumption)
  apply (rule_tac x = "\<mu> i. HH (f,A,i) ={A}" in exI)
  apply (rule_tac x = "\<lambda>j \<in> (\<mu> i. HH (f,A,i) ={A}) . HH (f,A,j) " in exI)
  apply (simp_all add: ltD)
 apply (fast intro!: Ord_Least lam_type [THEN domain_of_fun]
             elim!: less_Least_subset_x AC15_WO6_aux1 AC15_WO6_aux2) 
 done
 
 
 (* ********************************************************************** *)
 (* The proof needed in the first case, not in the second                  *)
 (* ********************************************************************** *)
 
 (* ********************************************************************** *)
 (* AC10(n) \<Longrightarrow> AC13(n-1)  if 2\<le>n                                       *)
 (*                                                                        *)
 (* Because of the change to the formal definition of AC10(n) we prove     *)
 (* the following obviously equivalent theorem \<in>                           *)
 (* AC10(n) implies AC13(n) for (1\<le>n)                                   *)
 (* ********************************************************************** *)
 
 theorem AC10_AC13: "\<lbrakk>n \<in> nat; 1\<le>n; AC10(n)\<rbrakk> \<Longrightarrow> AC13(n)"
 apply (unfold AC10_def AC13_def, safe)
 apply (erule allE) 
 apply (erule impE [OF _ cons_times_nat_not_Finite], assumption) 
 apply (fast elim!: impE [OF _ cons_times_nat_not_Finite] 
             dest!: ex_fun_AC13_AC15)
 done
 
 (* ********************************************************************** *)
 (* The proofs needed in the second case, not in the first                 *)
 (* ********************************************************************** *)
 
 (* ********************************************************************** *)
 (* AC1 \<Longrightarrow> AC13(1)                                                        *)
 (* ********************************************************************** *)
 
 lemma AC1_AC13: "AC1 \<Longrightarrow> AC13(1)"
-apply (unfold AC1_def AC13_def)
+  unfolding AC1_def AC13_def
 apply (rule allI)
 apply (erule allE)
 apply (rule impI)
 apply (drule mp, assumption) 
 apply (elim exE)
 apply (rule_tac x = "\<lambda>x \<in> A. {f`x}" in exI)
 apply (simp add: singleton_eqpoll_1 [THEN eqpoll_imp_lepoll])
 done
 
 (* ********************************************************************** *)
 (* AC13(m) \<Longrightarrow> AC13(n) for m \<subseteq> n                                         *)
 (* ********************************************************************** *)
 
 lemma AC13_mono: "\<lbrakk>m\<le>n; AC13(m)\<rbrakk> \<Longrightarrow> AC13(n)"
   unfolding AC13_def
 apply (drule le_imp_lepoll)
 apply (fast elim!: lepoll_trans)
 done
 
 (* ********************************************************************** *)
 (* The proofs necessary for both cases                                    *)
 (* ********************************************************************** *)
 
 (* ********************************************************************** *)
 (* AC13(n) \<Longrightarrow> AC14  if 1 \<subseteq> n                                            *)
 (* ********************************************************************** *)
 
 theorem AC13_AC14: "\<lbrakk>n \<in> nat; 1\<le>n; AC13(n)\<rbrakk> \<Longrightarrow> AC14"
 by (unfold AC13_def AC14_def, auto)
 
 (* ********************************************************************** *)
 (* AC14 \<Longrightarrow> AC15                                                          *)
 (* ********************************************************************** *)
 
 theorem AC14_AC15: "AC14 \<Longrightarrow> AC15"
 by (unfold AC13_def AC14_def AC15_def, fast)
 
 (* ********************************************************************** *)
 (* The redundant proofs; however cited by Rubin \<and> Rubin                   *)
 (* ********************************************************************** *)
 
 (* ********************************************************************** *)
 (* AC13(1) \<Longrightarrow> AC1                                                        *)
 (* ********************************************************************** *)
 
 lemma lemma_aux: "\<lbrakk>A\<noteq>0; A \<lesssim> 1\<rbrakk> \<Longrightarrow> \<exists>a. A={a}"
 by (fast elim!: not_emptyE lepoll_1_is_sing)
 
 lemma AC13_AC1_lemma:
      "\<forall>B \<in> A. f(B)\<noteq>0 \<and> f(B)<=B \<and> f(B) \<lesssim> 1   
       \<Longrightarrow> (\<lambda>x \<in> A. THE y. f(x)={y}) \<in> (\<Prod>X \<in> A. X)"
 apply (rule lam_type)
 apply (drule bspec, assumption)
 apply (elim conjE)
 apply (erule lemma_aux [THEN exE], assumption)
 apply (simp add: the_equality)
 done
 
 theorem AC13_AC1: "AC13(1) \<Longrightarrow> AC1"
-apply (unfold AC13_def AC1_def)
+  unfolding AC13_def AC1_def
 apply (fast elim!: AC13_AC1_lemma)
 done
 
 (* ********************************************************************** *)
 (* AC11 \<Longrightarrow> AC14                                                          *)
 (* ********************************************************************** *)
 
 theorem AC11_AC14: "AC11 \<Longrightarrow> AC14"
-apply (unfold AC11_def AC14_def)
+  unfolding AC11_def AC14_def
 apply (fast intro!: AC10_AC13)
 done
 
 end
 
diff --git a/src/ZF/AC/AC16_WO4.thy b/src/ZF/AC/AC16_WO4.thy
--- a/src/ZF/AC/AC16_WO4.thy
+++ b/src/ZF/AC/AC16_WO4.thy
@@ -1,578 +1,578 @@
 (*  Title:      ZF/AC/AC16_WO4.thy
     Author:     Krzysztof Grabczewski
 
 The proof of AC16(n, k) \<Longrightarrow> WO4(n-k)
 
 Tidied (using locales) by LCP
 *)
 
 theory AC16_WO4
 imports AC16_lemmas
 begin
 
 (* ********************************************************************** *)
 (* The case of finite set                                                 *)
 (* ********************************************************************** *)
 
 lemma lemma1:
      "\<lbrakk>Finite(A); 0<m; m \<in> nat\<rbrakk> 
       \<Longrightarrow> \<exists>a f. Ord(a) \<and> domain(f) = a \<and>   
                 (\<Union>b<a. f`b) = A \<and> (\<forall>b<a. f`b \<lesssim> m)"
   unfolding Finite_def
 apply (erule bexE)
 apply (drule eqpoll_sym [THEN eqpoll_def [THEN def_imp_iff, THEN iffD1]])
 apply (erule exE)
 apply (rule_tac x = n in exI)
 apply (rule_tac x = "\<lambda>i \<in> n. {f`i}" in exI)
 apply (simp add: ltD bij_def surj_def)
 apply (fast intro!: ltI nat_into_Ord lam_funtype [THEN domain_of_fun] 
                singleton_eqpoll_1 [THEN eqpoll_imp_lepoll, THEN lepoll_trans] 
                     nat_1_lepoll_iff [THEN iffD2]
           elim!: apply_type ltE)
 done
 
 (* ********************************************************************** *)
 (* The case of infinite set                                               *)
 (* ********************************************************************** *)
 
 (* well_ord(x,r) \<Longrightarrow> well_ord({{y,z}. y \<in> x}, Something(x,z))  **)
 lemmas well_ord_paired = paired_bij [THEN bij_is_inj, THEN well_ord_rvimage]
 
 lemma lepoll_trans1: "\<lbrakk>A \<lesssim> B; \<not> A \<lesssim> C\<rbrakk> \<Longrightarrow> \<not> B \<lesssim> C"
 by (blast intro: lepoll_trans)
 
 (* ********************************************************************** *)
 (* There exists a well ordered set y such that ...                        *)
 (* ********************************************************************** *)
 
 lemmas lepoll_paired = paired_eqpoll [THEN eqpoll_sym, THEN eqpoll_imp_lepoll]
 
 lemma lemma2: "\<exists>y R. well_ord(y,R) \<and> x \<inter> y = 0 \<and> \<not>y \<lesssim> z \<and> \<not>Finite(y)"
 apply (rule_tac x = "{{a,x}. a \<in> nat \<union> Hartog (z) }" in exI)
 apply (rule well_ord_Un [OF Ord_nat [THEN well_ord_Memrel] 
                          Ord_Hartog [THEN well_ord_Memrel], THEN exE])
 apply (blast intro!: Ord_Hartog well_ord_Memrel well_ord_paired
                       lepoll_trans1 [OF _ not_Hartog_lepoll_self]
                       lepoll_trans [OF subset_imp_lepoll lepoll_paired]
        elim!: nat_not_Finite [THEN notE]
        elim: mem_asym 
        dest!: Un_upper1 [THEN subset_imp_lepoll, THEN lepoll_Finite]
               lepoll_paired [THEN lepoll_Finite])
 done
 
 lemma infinite_Un: "\<not>Finite(B) \<Longrightarrow> \<not>Finite(A \<union> B)"
 by (blast intro: subset_Finite)
 
 (* ********************************************************************** *)
 (* There is a v \<in> s(u) such that k \<lesssim> x \<inter> y (in our case succ(k))    *)
 (* The idea of the proof is the following \<in>                               *)
 (* Suppose not, i.e. every element of s(u) has exactly k-1 elements of y   *)
 (* Thence y is less than or equipollent to {v \<in> Pow(x). v \<approx> n#-k}      *)
 (*   We have obtained this result in two steps \<in>                          *)
 (*   1. y is less than or equipollent to {v \<in> s(u). a \<subseteq> v}                  *)
 (*      where a is certain k-2 element subset of y                        *)
 (*   2. {v \<in> s(u). a \<subseteq> v} is less than or equipollent                       *)
 (*      to {v \<in> Pow(x). v \<approx> n-k}                                       *)
 (* ********************************************************************** *)
 
 (*Proof simplified by LCP*)
 lemma succ_not_lepoll_lemma:
      "\<lbrakk>\<not>(\<exists>x \<in> A. f`x=y); f \<in> inj(A, B); y \<in> B\<rbrakk>   
       \<Longrightarrow> (\<lambda>a \<in> succ(A). if(a=A, y, f`a)) \<in> inj(succ(A), B)"
 apply (rule_tac d = "\<lambda>z. if (z=y, A, converse (f) `z) " in lam_injective)
 apply (force simp add: inj_is_fun [THEN apply_type])
 (*this preliminary simplification prevents looping somehow*)
 apply (simp (no_asm_simp))
 apply force
 done
 
 lemma succ_not_lepoll_imp_eqpoll: "\<lbrakk>\<not>A \<approx> B; A \<lesssim> B\<rbrakk> \<Longrightarrow> succ(A) \<lesssim> B"
-apply (unfold lepoll_def eqpoll_def bij_def surj_def)
+  unfolding lepoll_def eqpoll_def bij_def surj_def
 apply (fast elim!: succ_not_lepoll_lemma inj_is_fun)
 done
 
 
 (* ********************************************************************** *)
 (* There is a k-2 element subset of y                                     *)
 (* ********************************************************************** *)
 
 lemmas ordertype_eqpoll =
        ordermap_bij [THEN exI [THEN eqpoll_def [THEN def_imp_iff, THEN iffD2]]]
 
 lemma cons_cons_subset:
      "\<lbrakk>a \<subseteq> y; b \<in> y-a; u \<in> x\<rbrakk> \<Longrightarrow> cons(b, cons(u, a)) \<in> Pow(x \<union> y)"
 by fast
 
 lemma cons_cons_eqpoll:
      "\<lbrakk>a \<approx> k; a \<subseteq> y; b \<in> y-a; u \<in> x; x \<inter> y = 0\<rbrakk>    
       \<Longrightarrow> cons(b, cons(u, a)) \<approx> succ(succ(k))"
 by (fast intro!: cons_eqpoll_succ)
 
 lemma set_eq_cons:
      "\<lbrakk>succ(k) \<approx> A; k \<approx> B; B \<subseteq> A; a \<in> A-B; k \<in> nat\<rbrakk> \<Longrightarrow> A = cons(a, B)"
 apply (rule equalityI)
 prefer 2 apply fast
 apply (rule Diff_eq_0_iff [THEN iffD1])
 apply (rule equals0I)
 apply (drule eqpoll_sym [THEN eqpoll_imp_lepoll])
 apply (drule eqpoll_sym [THEN cons_eqpoll_succ], fast)
 apply (drule cons_eqpoll_succ, fast)
 apply (fast elim!: lepoll_trans [THEN lepoll_trans, THEN succ_lepoll_natE,
          OF eqpoll_sym [THEN eqpoll_imp_lepoll] subset_imp_lepoll])
 done
 
 lemma cons_eqE: "\<lbrakk>cons(x,a) = cons(y,a); x \<notin> a\<rbrakk> \<Longrightarrow> x = y "
 by (fast elim!: equalityE)
 
 lemma eq_imp_Int_eq: "A = B \<Longrightarrow> A \<inter> C = B \<inter> C"
 by blast
 
 (* ********************************************************************** *)
 (* some arithmetic                                                        *)
 (* ********************************************************************** *)
 
 lemma eqpoll_sum_imp_Diff_lepoll_lemma [rule_format]:
      "\<lbrakk>k \<in> nat; m \<in> nat\<rbrakk> 
       \<Longrightarrow> \<forall>A B. A \<approx> k #+ m \<and> k \<lesssim> B \<and> B \<subseteq> A \<longrightarrow> A-B \<lesssim> m"
 apply (induct_tac "k")
 apply (simp add: add_0)
 apply (blast intro: eqpoll_imp_lepoll lepoll_trans
                     Diff_subset [THEN subset_imp_lepoll])
 apply (intro allI impI)
 apply (rule succ_lepoll_imp_not_empty [THEN not_emptyE], fast)
 apply (erule_tac x = "A - {xa}" in allE)
 apply (erule_tac x = "B - {xa}" in allE)
 apply (erule impE)
 apply (simp add: add_succ)
 apply (fast intro!: Diff_sing_eqpoll lepoll_Diff_sing) 
 apply (subgoal_tac "A - {xa} - (B - {xa}) = A - B", simp)
 apply blast 
 done
 
 lemma eqpoll_sum_imp_Diff_lepoll:
      "\<lbrakk>A \<approx> succ(k #+ m); B \<subseteq> A; succ(k) \<lesssim> B;  k \<in> nat; m \<in> nat\<rbrakk>   
       \<Longrightarrow> A-B \<lesssim> m"
 apply (simp only: add_succ [symmetric]) 
 apply (blast intro: eqpoll_sum_imp_Diff_lepoll_lemma) 
 done
 
 (* ********************************************************************** *)
 (* similar properties for \<approx>                                          *)
 (* ********************************************************************** *)
 
 lemma eqpoll_sum_imp_Diff_eqpoll_lemma [rule_format]:
      "\<lbrakk>k \<in> nat; m \<in> nat\<rbrakk> 
       \<Longrightarrow> \<forall>A B. A \<approx> k #+ m \<and> k \<approx> B \<and> B \<subseteq> A \<longrightarrow> A-B \<approx> m"
 apply (induct_tac "k")
 apply (force dest!: eqpoll_sym [THEN eqpoll_imp_lepoll, THEN lepoll_0_is_0])
 apply (intro allI impI)
 apply (rule succ_lepoll_imp_not_empty [THEN not_emptyE])
 apply (fast elim!: eqpoll_imp_lepoll)
 apply (erule_tac x = "A - {xa}" in allE)
 apply (erule_tac x = "B - {xa}" in allE)
 apply (erule impE)
 apply (force intro: eqpoll_sym intro!: Diff_sing_eqpoll)
 apply (subgoal_tac "A - {xa} - (B - {xa}) = A - B", simp)
 apply blast 
 done
 
 lemma eqpoll_sum_imp_Diff_eqpoll:
      "\<lbrakk>A \<approx> succ(k #+ m); B \<subseteq> A; succ(k) \<approx> B; k \<in> nat; m \<in> nat\<rbrakk>   
       \<Longrightarrow> A-B \<approx> m"
 apply (simp only: add_succ [symmetric]) 
 apply (blast intro: eqpoll_sum_imp_Diff_eqpoll_lemma) 
 done
 
 
 (* ********************************************************************** *)
 (* LL can be well ordered                                                 *)
 (* ********************************************************************** *)
 
 lemma subsets_lepoll_0_eq_unit: "{x \<in> Pow(X). x \<lesssim> 0} = {0}"
 by (fast dest!: lepoll_0_is_0 intro!: lepoll_refl)
 
 lemma subsets_lepoll_succ:
      "n \<in> nat \<Longrightarrow> {z \<in> Pow(y). z \<lesssim> succ(n)} =   
                   {z \<in> Pow(y). z \<lesssim> n} \<union> {z \<in> Pow(y). z \<approx> succ(n)}"
 by (blast intro: leI le_imp_lepoll nat_into_Ord 
                     lepoll_trans eqpoll_imp_lepoll
           dest!: lepoll_succ_disj)
 
 lemma Int_empty:
      "n \<in> nat \<Longrightarrow> {z \<in> Pow(y). z \<lesssim> n} \<inter> {z \<in> Pow(y). z \<approx> succ(n)} = 0"
 by (blast intro: eqpoll_sym [THEN eqpoll_imp_lepoll, THEN lepoll_trans] 
                  succ_lepoll_natE)
 
 locale AC16 =
   fixes x and y and k and l and m and t_n and R and MM and LL and GG and s 
   defines k_def:     "k   \<equiv> succ(l)"
       and MM_def:    "MM  \<equiv> {v \<in> t_n. succ(k) \<lesssim> v \<inter> y}"
       and LL_def:    "LL  \<equiv> {v \<inter> y. v \<in> MM}"
       and GG_def:    "GG  \<equiv> \<lambda>v \<in> LL. (THE w. w \<in> MM \<and> v \<subseteq> w) - v"
       and s_def:     "s(u) \<equiv> {v \<in> t_n. u \<in> v \<and> k \<lesssim> v \<inter> y}"
   assumes all_ex:    "\<forall>z \<in> {z \<in> Pow(x \<union> y) . z \<approx> succ(k)}.
                        \<exists>! w. w \<in> t_n \<and> z \<subseteq> w "
     and disjoint[iff]:  "x \<inter> y = 0"
     and "includes":  "t_n \<subseteq> {v \<in> Pow(x \<union> y). v \<approx> succ(k #+ m)}"
     and WO_R[iff]:      "well_ord(y,R)"
     and lnat[iff]:      "l \<in> nat"
     and mnat[iff]:      "m \<in> nat"
     and mpos[iff]:      "0<m"
     and Infinite[iff]:  "\<not> Finite(y)"
     and noLepoll:  "\<not> y \<lesssim> {v \<in> Pow(x). v \<approx> m}"
 begin
 
 lemma knat [iff]: "k \<in> nat"
 by (simp add: k_def)
 
 
 (* ********************************************************************** *)
 (*   1. y is less than or equipollent to {v \<in> s(u). a \<subseteq> v}                *)
 (*      where a is certain k-2 element subset of y                        *)
 (* ********************************************************************** *)
 
 lemma Diff_Finite_eqpoll: "\<lbrakk>l \<approx> a; a \<subseteq> y\<rbrakk> \<Longrightarrow> y - a \<approx> y"
 apply (insert WO_R Infinite lnat)
 apply (rule eqpoll_trans) 
 apply (rule Diff_lesspoll_eqpoll_Card) 
 apply (erule well_ord_cardinal_eqpoll [THEN eqpoll_sym])
 apply (blast intro: lesspoll_trans1
             intro!: Card_cardinal  
                     Card_cardinal [THEN Card_is_Ord, THEN nat_le_infinite_Ord,
                                    THEN le_imp_lepoll] 
             dest: well_ord_cardinal_eqpoll 
                    eqpoll_sym  eqpoll_imp_lepoll
                    n_lesspoll_nat [THEN lesspoll_trans2]
                    well_ord_cardinal_eqpoll [THEN eqpoll_sym, 
                           THEN eqpoll_imp_lepoll, THEN lepoll_infinite])+
 done
 
 
 lemma s_subset: "s(u) \<subseteq> t_n"
 by (unfold s_def, blast)
 
 lemma sI: 
       "\<lbrakk>w \<in> t_n; cons(b,cons(u,a)) \<subseteq> w; a \<subseteq> y; b \<in> y-a; l \<approx> a\<rbrakk> 
        \<Longrightarrow> w \<in> s(u)"
-apply (unfold s_def succ_def k_def)
+  unfolding s_def succ_def k_def
 apply (blast intro!: eqpoll_imp_lepoll [THEN cons_lepoll_cong]
              intro: subset_imp_lepoll lepoll_trans)
 done
 
 lemma in_s_imp_u_in: "v \<in> s(u) \<Longrightarrow> u \<in> v"
 by (unfold s_def, blast)
 
 
 lemma ex1_superset_a:
      "\<lbrakk>l \<approx> a;  a \<subseteq> y;  b \<in> y - a;  u \<in> x\<rbrakk>   
       \<Longrightarrow> \<exists>! c. c \<in> s(u) \<and> a \<subseteq> c \<and> b \<in> c"
 apply (rule all_ex [simplified k_def, THEN ballE])
  apply (erule ex1E)
  apply (rule_tac a = w in ex1I, blast intro: sI)
  apply (blast dest: s_subset [THEN subsetD] in_s_imp_u_in)
 apply (blast del: PowI 
              intro!: cons_cons_subset eqpoll_sym [THEN cons_cons_eqpoll])
 done
 
 lemma the_eq_cons:
      "\<lbrakk>\<forall>v \<in> s(u). succ(l) \<approx> v \<inter> y;   
          l \<approx> a;  a \<subseteq> y;  b \<in> y - a;  u \<in> x\<rbrakk>    
       \<Longrightarrow> (THE c. c \<in> s(u) \<and> a \<subseteq> c \<and> b \<in> c) \<inter> y = cons(b, a)"
 apply (frule ex1_superset_a [THEN theI], assumption+)
 apply (rule set_eq_cons)
 apply (fast+)
 done
 
 lemma y_lepoll_subset_s:
      "\<lbrakk>\<forall>v \<in> s(u). succ(l) \<approx> v \<inter> y;   
          l \<approx> a;  a \<subseteq> y;  u \<in> x\<rbrakk>   
       \<Longrightarrow> y \<lesssim> {v \<in> s(u). a \<subseteq> v}"
 apply (rule Diff_Finite_eqpoll [THEN eqpoll_sym, THEN eqpoll_imp_lepoll, 
                                 THEN lepoll_trans],  fast+)
 apply (rule_tac  f3 = "\<lambda>b \<in> y-a. THE c. c \<in> s (u) \<and> a \<subseteq> c \<and> b \<in> c" 
         in exI [THEN lepoll_def [THEN def_imp_iff, THEN iffD2]])
 apply (simp add: inj_def)
 apply (rule conjI)
 apply (rule lam_type)
 apply (frule ex1_superset_a [THEN theI], fast+, clarify)
 apply (rule cons_eqE [of _ a])
 apply (drule_tac A = "THE c. P (c)" and C = y for P in eq_imp_Int_eq)
 apply (simp_all add: the_eq_cons)
 done
 
 
 (* ********************************************************************** *)
 (* back to the second part                                                *)
 (* ********************************************************************** *)
 
 
 (*relies on the disjointness of x, y*)
 lemma x_imp_not_y [dest]: "a \<in> x \<Longrightarrow> a \<notin> y"
 by (blast dest:  disjoint [THEN equalityD1, THEN subsetD, OF IntI])
 
 lemma w_Int_eq_w_Diff:
      "w \<subseteq> x \<union> y \<Longrightarrow> w \<inter> (x - {u}) = w - cons(u, w \<inter> y)" 
 by blast
 
 lemma w_Int_eqpoll_m:
      "\<lbrakk>w \<in> {v \<in> s(u). a \<subseteq> v};   
          l \<approx> a;  u \<in> x;   
          \<forall>v \<in> s(u). succ(l) \<approx> v \<inter> y\<rbrakk> 
       \<Longrightarrow> w \<inter> (x - {u}) \<approx> m"
 apply (erule CollectE)
 apply (subst w_Int_eq_w_Diff)
 apply (fast dest!: s_subset [THEN subsetD] 
                    "includes" [simplified k_def, THEN subsetD])
 apply (blast dest: s_subset [THEN subsetD] 
                    "includes" [simplified k_def, THEN subsetD] 
              dest: eqpoll_sym [THEN cons_eqpoll_succ, THEN eqpoll_sym] 
                    in_s_imp_u_in
             intro!: eqpoll_sum_imp_Diff_eqpoll)
 done
 
 
 (* ********************************************************************** *)
 (*   2. {v \<in> s(u). a \<subseteq> v} is less than or equipollent                       *)
 (*      to {v \<in> Pow(x). v \<approx> n-k}                                       *)
 (* ********************************************************************** *)
 
 lemma eqpoll_m_not_empty: "a \<approx> m \<Longrightarrow> a \<noteq> 0"
 apply (insert mpos)
 apply (fast elim!: zero_lt_natE dest!: eqpoll_succ_imp_not_empty)
 done
 
 lemma cons_cons_in:
      "\<lbrakk>z \<in> xa \<inter> (x - {u}); l \<approx> a; a \<subseteq> y; u \<in> x\<rbrakk>   
       \<Longrightarrow> \<exists>! w. w \<in> t_n \<and> cons(z, cons(u, a)) \<subseteq> w"
 apply (rule all_ex [THEN bspec])
   unfolding k_def
 apply (fast intro!: cons_eqpoll_succ elim: eqpoll_sym)
 done
 
 lemma subset_s_lepoll_w:
      "\<lbrakk>\<forall>v \<in> s(u). succ(l) \<approx> v \<inter> y; a \<subseteq> y; l \<approx> a; u \<in> x\<rbrakk>   
       \<Longrightarrow> {v \<in> s(u). a \<subseteq> v} \<lesssim> {v \<in> Pow(x). v \<approx> m}"
 apply (rule_tac f3 = "\<lambda>w \<in> {v \<in> s (u) . a \<subseteq> v}. w \<inter> (x - {u})" 
        in exI [THEN lepoll_def [THEN def_imp_iff, THEN iffD2]])
 apply (simp add: inj_def)
 apply (intro conjI lam_type CollectI)
   apply fast
  apply (blast intro: w_Int_eqpoll_m) 
 apply (intro ballI impI)
 (** LEVEL 8 **)
 apply (rule w_Int_eqpoll_m [THEN eqpoll_m_not_empty, THEN not_emptyE])
 apply (blast, assumption+)
 apply (drule equalityD1 [THEN subsetD], assumption)
 apply (frule cons_cons_in, assumption+)
 apply (blast dest: ex1_two_eq intro: s_subset [THEN subsetD] in_s_imp_u_in)+
 done
 
 
 (* ********************************************************************** *)
 (* well_ord_subsets_lepoll_n                                              *)
 (* ********************************************************************** *)
 
 lemma well_ord_subsets_eqpoll_n:
      "n \<in> nat \<Longrightarrow> \<exists>S. well_ord({z \<in> Pow(y) . z \<approx> succ(n)}, S)"
 apply (rule WO_R [THEN well_ord_infinite_subsets_eqpoll_X,
                   THEN eqpoll_def [THEN def_imp_iff, THEN iffD1], THEN exE])
 apply (fast intro: bij_is_inj [THEN well_ord_rvimage])+
 done
 
 lemma well_ord_subsets_lepoll_n:
      "n \<in> nat \<Longrightarrow> \<exists>R. well_ord({z \<in> Pow(y). z \<lesssim> n}, R)"
 apply (induct_tac "n")
 apply (force intro!: well_ord_unit simp add: subsets_lepoll_0_eq_unit)
 apply (erule exE)
 apply (rule well_ord_subsets_eqpoll_n [THEN exE], assumption)
 apply (simp add: subsets_lepoll_succ)
 apply (drule well_ord_radd, assumption)
 apply (erule Int_empty [THEN disj_Un_eqpoll_sum,
                   THEN eqpoll_def [THEN def_imp_iff, THEN iffD1], THEN exE])
 apply (fast elim!: bij_is_inj [THEN well_ord_rvimage])
 done
 
 
 lemma LL_subset: "LL \<subseteq> {z \<in> Pow(y). z \<lesssim> succ(k #+ m)}"
-apply (unfold LL_def MM_def)
+  unfolding LL_def MM_def
 apply (insert "includes")
 apply (blast intro: subset_imp_lepoll eqpoll_imp_lepoll lepoll_trans)
 done
 
 lemma well_ord_LL: "\<exists>S. well_ord(LL,S)"
 apply (rule well_ord_subsets_lepoll_n [THEN exE, of "succ(k#+m)"])
 apply simp 
 apply (blast intro: well_ord_subset [OF _ LL_subset])
 done
 
 (* ********************************************************************** *)
 (* every element of LL is a contained in exactly one element of MM        *)
 (* ********************************************************************** *)
 
 lemma unique_superset_in_MM:
      "v \<in> LL \<Longrightarrow> \<exists>! w. w \<in> MM \<and> v \<subseteq> w"
 apply (unfold MM_def LL_def, safe, fast)
 apply (rule lepoll_imp_eqpoll_subset [THEN exE], assumption)
 apply (rule_tac x = x in all_ex [THEN ballE]) 
 apply (blast intro: eqpoll_sym)+
 done
 
 
 (* ********************************************************************** *)
 (* The function GG satisfies the conditions of WO4                        *)
 (* ********************************************************************** *)
 
 (* ********************************************************************** *)
 (* The union of appropriate values is the whole x                         *)
 (* ********************************************************************** *)
 
 lemma Int_in_LL: "w \<in> MM \<Longrightarrow> w \<inter> y \<in> LL"
 by (unfold LL_def, fast)
 
 lemma in_LL_eq_Int: 
      "v \<in> LL \<Longrightarrow> v = (THE x. x \<in> MM \<and> v \<subseteq> x) \<inter> y"
 apply (unfold LL_def, clarify)
 apply (subst unique_superset_in_MM [THEN the_equality2])
 apply (auto simp add: Int_in_LL)
 done
 
 lemma unique_superset1: "a \<in> LL \<Longrightarrow> (THE x. x \<in> MM \<and> a \<subseteq> x) \<in> MM"
 by (erule unique_superset_in_MM [THEN theI, THEN conjunct1]) 
 
 lemma the_in_MM_subset:
      "v \<in> LL \<Longrightarrow> (THE x. x \<in> MM \<and> v \<subseteq> x) \<subseteq> x \<union> y"
 apply (drule unique_superset1)
   unfolding MM_def
 apply (fast dest!: unique_superset1 "includes" [THEN subsetD])
 done
 
 lemma GG_subset: "v \<in> LL \<Longrightarrow> GG ` v \<subseteq> x"
   unfolding GG_def
 apply (frule the_in_MM_subset)
 apply (frule in_LL_eq_Int)
 apply (force elim: equalityE)
 done
 
 lemma nat_lepoll_ordertype: "nat \<lesssim> ordertype(y, R)"
 apply (rule nat_le_infinite_Ord [THEN le_imp_lepoll]) 
  apply (rule Ord_ordertype [OF WO_R]) 
 apply (rule ordertype_eqpoll [THEN eqpoll_imp_lepoll, THEN lepoll_infinite]) 
  apply (rule WO_R) 
 apply (rule Infinite) 
 done
 
 lemma ex_subset_eqpoll_n: "n \<in> nat \<Longrightarrow> \<exists>z. z \<subseteq> y \<and> n \<approx> z"
 apply (erule nat_lepoll_imp_ex_eqpoll_n)
 apply (rule lepoll_trans [OF nat_lepoll_ordertype]) 
 apply (rule ordertype_eqpoll [THEN eqpoll_sym, THEN eqpoll_imp_lepoll]) 
 apply (rule WO_R) 
 done
 
 
 lemma exists_proper_in_s: "u \<in> x \<Longrightarrow> \<exists>v \<in> s(u). succ(k) \<lesssim> v \<inter> y"
 apply (rule ccontr)
 apply (subgoal_tac "\<forall>v \<in> s (u) . k \<approx> v \<inter> y")
 prefer 2 apply (simp add: s_def, blast intro: succ_not_lepoll_imp_eqpoll)
   unfolding k_def
 apply (insert all_ex "includes" lnat)
 apply (rule ex_subset_eqpoll_n [THEN exE], assumption)
 apply (rule noLepoll [THEN notE])
 apply (blast intro: lepoll_trans [OF y_lepoll_subset_s subset_s_lepoll_w])
 done
 
 lemma exists_in_MM: "u \<in> x \<Longrightarrow> \<exists>w \<in> MM. u \<in> w"
 apply (erule exists_proper_in_s [THEN bexE])
 apply (unfold MM_def s_def, fast)
 done
 
 lemma exists_in_LL: "u \<in> x \<Longrightarrow> \<exists>w \<in> LL. u \<in> GG`w"
 apply (rule exists_in_MM [THEN bexE], assumption)
 apply (rule bexI)
 apply (erule_tac [2] Int_in_LL)
   unfolding GG_def
 apply (simp add: Int_in_LL)
 apply (subst unique_superset_in_MM [THEN the_equality2])
 apply (fast elim!: Int_in_LL)+
 done
 
 lemma OUN_eq_x: "well_ord(LL,S) \<Longrightarrow>       
       (\<Union>b<ordertype(LL,S). GG ` (converse(ordermap(LL,S)) ` b)) = x"
 apply (rule equalityI)
 apply (rule subsetI)
 apply (erule OUN_E)
 apply (rule GG_subset [THEN subsetD])
 prefer 2 apply assumption
 apply (blast intro: ltD  ordermap_bij [THEN bij_converse_bij, THEN bij_is_fun,
                                        THEN apply_type])
 apply (rule subsetI)
 apply (erule exists_in_LL [THEN bexE])
 apply (force intro: ltI [OF _ Ord_ordertype]
                     ordermap_type [THEN apply_type]
              simp add: ordermap_bij [THEN bij_is_inj, THEN left_inverse])
 done
 
 (* ********************************************************************** *)
 (* Every element of the family is less than or equipollent to n-k (m)     *)
 (* ********************************************************************** *)
 
 lemma in_MM_eqpoll_n: "w \<in> MM \<Longrightarrow> w \<approx> succ(k #+ m)"
   unfolding MM_def
 apply (fast dest: "includes" [THEN subsetD])
 done
 
 lemma in_LL_eqpoll_n: "w \<in> LL \<Longrightarrow> succ(k) \<lesssim> w"
 by (unfold LL_def MM_def, fast)
 
 lemma in_LL: "w \<in> LL \<Longrightarrow> w \<subseteq> (THE x. x \<in> MM \<and> w \<subseteq> x)"
 by (erule subset_trans [OF in_LL_eq_Int [THEN equalityD1] Int_lower1])
 
 lemma all_in_lepoll_m: 
       "well_ord(LL,S) \<Longrightarrow>       
        \<forall>b<ordertype(LL,S). GG ` (converse(ordermap(LL,S)) ` b) \<lesssim> m"
   unfolding GG_def
 apply (rule oallI)
 apply (simp add: ltD ordermap_bij [THEN bij_converse_bij, THEN bij_is_fun, THEN apply_type])
 apply (insert "includes")
 apply (rule eqpoll_sum_imp_Diff_lepoll)
 apply (blast del: subsetI
              dest!: ltD 
              intro!: eqpoll_sum_imp_Diff_lepoll in_LL_eqpoll_n
              intro: in_LL   unique_superset1 [THEN in_MM_eqpoll_n] 
                     ordermap_bij [THEN bij_converse_bij, THEN bij_is_fun, 
                                   THEN apply_type])+
 done
 
 lemma "conclusion":
      "\<exists>a f. Ord(a) \<and> domain(f) = a \<and> (\<Union>b<a. f ` b) = x \<and> (\<forall>b<a. f ` b \<lesssim> m)"
 apply (rule well_ord_LL [THEN exE])
 apply (rename_tac S)
 apply (rule_tac x = "ordertype (LL,S)" in exI)
 apply (rule_tac x = "\<lambda>b \<in> ordertype(LL,S). 
                       GG ` (converse (ordermap (LL,S)) ` b)"  in exI)
 apply (simp add: ltD)
 apply (blast intro: lam_funtype [THEN domain_of_fun] 
                     Ord_ordertype  OUN_eq_x  all_in_lepoll_m [THEN ospec])
 done
 
 end
 
 
 (* ********************************************************************** *)
 (* The main theorem AC16(n, k) \<Longrightarrow> WO4(n-k)                               *)
 (* ********************************************************************** *)
 
 theorem AC16_WO4: 
      "\<lbrakk>AC_Equiv.AC16(k #+ m, k); 0 < k; 0 < m; k \<in> nat; m \<in> nat\<rbrakk> \<Longrightarrow> WO4(m)"
-apply (unfold AC_Equiv.AC16_def WO4_def)
+  unfolding AC_Equiv.AC16_def WO4_def
 apply (rule allI)
 apply (case_tac "Finite (A)")
 apply (rule lemma1, assumption+)
 apply (cut_tac lemma2)
 apply (elim exE conjE)
 apply (erule_tac x = "A \<union> y" in allE)
 apply (frule infinite_Un, drule mp, assumption)
 apply (erule zero_lt_natE, assumption, clarify)
 apply (blast intro: AC16.conclusion [OF AC16.intro])
 done
 
 end
diff --git a/src/ZF/AC/AC16_lemmas.thy b/src/ZF/AC/AC16_lemmas.thy
--- a/src/ZF/AC/AC16_lemmas.thy
+++ b/src/ZF/AC/AC16_lemmas.thy
@@ -1,236 +1,236 @@
 (*  Title:      ZF/AC/AC16_lemmas.thy
     Author:     Krzysztof Grabczewski
 
 Lemmas used in the proofs concerning AC16
 *)
 
 theory AC16_lemmas
 imports AC_Equiv Hartog Cardinal_aux
 begin
 
 lemma cons_Diff_eq: "a\<notin>A \<Longrightarrow> cons(a,A)-{a}=A"
 by fast
 
 lemma nat_1_lepoll_iff: "1\<lesssim>X \<longleftrightarrow> (\<exists>x. x \<in> X)"
   unfolding lepoll_def
 apply (rule iffI)
 apply (fast intro: inj_is_fun [THEN apply_type])
 apply (erule exE)
 apply (rule_tac x = "\<lambda>a \<in> 1. x" in exI)
 apply (fast intro!: lam_injective)
 done
 
 lemma eqpoll_1_iff_singleton: "X\<approx>1 \<longleftrightarrow> (\<exists>x. X={x})"
 apply (rule iffI)
 apply (erule eqpollE)
 apply (drule nat_1_lepoll_iff [THEN iffD1])
 apply (fast intro!: lepoll_1_is_sing)
 apply (fast intro!: singleton_eqpoll_1)
 done
 
 lemma cons_eqpoll_succ: "\<lbrakk>x\<approx>n; y\<notin>x\<rbrakk> \<Longrightarrow> cons(y,x)\<approx>succ(n)"
   unfolding succ_def
 apply (fast elim!: cons_eqpoll_cong mem_irrefl)
 done
 
 lemma subsets_eqpoll_1_eq: "{Y \<in> Pow(X). Y\<approx>1} = {{x}. x \<in> X}"
 apply (rule equalityI)
 apply (rule subsetI)
 apply (erule CollectE)
 apply (drule eqpoll_1_iff_singleton [THEN iffD1])
 apply (fast intro!: RepFunI)
 apply (rule subsetI)
 apply (erule RepFunE)
 apply (rule CollectI, fast)
 apply (fast intro!: singleton_eqpoll_1)
 done
 
 lemma eqpoll_RepFun_sing: "X\<approx>{{x}. x \<in> X}"
-apply (unfold eqpoll_def bij_def)
+  unfolding eqpoll_def bij_def
 apply (rule_tac x = "\<lambda>x \<in> X. {x}" in exI)
 apply (rule IntI)
 apply (unfold inj_def surj_def, simp)
 apply (fast intro!: lam_type RepFunI intro: singleton_eq_iff [THEN iffD1], simp)
 apply (fast intro!: lam_type)
 done
 
 lemma subsets_eqpoll_1_eqpoll: "{Y \<in> Pow(X). Y\<approx>1}\<approx>X"
 apply (rule subsets_eqpoll_1_eq [THEN ssubst])
 apply (rule eqpoll_RepFun_sing [THEN eqpoll_sym])
 done
 
 lemma InfCard_Least_in:
      "\<lbrakk>InfCard(x); y \<subseteq> x; y \<approx> succ(z)\<rbrakk> \<Longrightarrow> (\<mu> i. i \<in> y) \<in> y"
 apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll, 
                          THEN succ_lepoll_imp_not_empty, THEN not_emptyE])
 apply (fast intro: LeastI 
             dest!: InfCard_is_Card [THEN Card_is_Ord] 
             elim: Ord_in_Ord)
 done
 
 lemma subsets_lepoll_lemma1:
      "\<lbrakk>InfCard(x); n \<in> nat\<rbrakk> 
       \<Longrightarrow> {y \<in> Pow(x). y\<approx>succ(succ(n))} \<lesssim> x*{y \<in> Pow(x). y\<approx>succ(n)}"
   unfolding lepoll_def
 apply (rule_tac x = "\<lambda>y \<in> {y \<in> Pow(x) . y\<approx>succ (succ (n))}. 
                       <\<mu> i. i \<in> y, y-{\<mu> i. i \<in> y}>" in exI)
 apply (rule_tac d = "\<lambda>z. cons (fst(z), snd(z))" in lam_injective)
  apply (blast intro!: Diff_sing_eqpoll intro: InfCard_Least_in)
 apply (simp, blast intro: InfCard_Least_in)
 done
 
 lemma set_of_Ord_succ_Union: "(\<forall>y \<in> z. Ord(y)) \<Longrightarrow> z \<subseteq> succ(\<Union>(z))"
 apply (rule subsetI)
 apply (case_tac "\<forall>y \<in> z. y \<subseteq> x", blast )
 apply (simp, erule bexE) 
 apply (rule_tac i=y and j=x in Ord_linear_le)
 apply (blast dest: le_imp_subset elim: leE ltE)+
 done
 
 lemma subset_not_mem: "j \<subseteq> i \<Longrightarrow> i \<notin> j"
 by (fast elim!: mem_irrefl)
 
 lemma succ_Union_not_mem:
      "(\<And>y. y \<in> z \<Longrightarrow> Ord(y)) \<Longrightarrow> succ(\<Union>(z)) \<notin> z"
 apply (rule set_of_Ord_succ_Union [THEN subset_not_mem], blast)
 done
 
 lemma Union_cons_eq_succ_Union:
      "\<Union>(cons(succ(\<Union>(z)),z)) = succ(\<Union>(z))"
 by fast
 
 lemma Un_Ord_disj: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> i \<union> j = i | i \<union> j = j"
 by (fast dest!: le_imp_subset elim: Ord_linear_le)
 
 lemma Union_eq_Un: "x \<in> X \<Longrightarrow> \<Union>(X) = x \<union> \<Union>(X-{x})"
 by fast
 
 lemma Union_in_lemma [rule_format]:
      "n \<in> nat \<Longrightarrow> \<forall>z. (\<forall>y \<in> z. Ord(y)) \<and> z\<approx>n \<and> z\<noteq>0 \<longrightarrow> \<Union>(z) \<in> z"
 apply (induct_tac "n")
 apply (fast dest!: eqpoll_imp_lepoll [THEN lepoll_0_is_0])
 apply (intro allI impI)
 apply (erule natE)
 apply (fast dest!: eqpoll_1_iff_singleton [THEN iffD1]
             intro!: Union_singleton, clarify) 
 apply (elim not_emptyE)
 apply (erule_tac x = "z-{xb}" in allE)
 apply (erule impE)
 apply (fast elim!: Diff_sing_eqpoll
                    Diff_sing_eqpoll [THEN eqpoll_succ_imp_not_empty])
 apply (subgoal_tac "xb \<union> \<Union>(z - {xb}) \<in> z")
 apply (simp add: Union_eq_Un [symmetric])
 apply (frule bspec, assumption)
 apply (drule bspec) 
 apply (erule Diff_subset [THEN subsetD])
 apply (drule Un_Ord_disj, assumption, auto) 
 done
 
 lemma Union_in: "\<lbrakk>\<forall>x \<in> z. Ord(x); z\<approx>n; z\<noteq>0; n \<in> nat\<rbrakk> \<Longrightarrow> \<Union>(z) \<in> z"
 by (blast intro: Union_in_lemma)
 
 lemma succ_Union_in_x:
      "\<lbrakk>InfCard(x); z \<in> Pow(x); z\<approx>n; n \<in> nat\<rbrakk> \<Longrightarrow> succ(\<Union>(z)) \<in> x"
 apply (rule Limit_has_succ [THEN ltE])
 prefer 3 apply assumption
 apply (erule InfCard_is_Limit)
 apply (case_tac "z=0")
 apply (simp, fast intro!: InfCard_is_Limit [THEN Limit_has_0])
 apply (rule ltI [OF PowD [THEN subsetD] InfCard_is_Card [THEN Card_is_Ord]], assumption)
 apply (blast intro: Union_in
                     InfCard_is_Card [THEN Card_is_Ord, THEN Ord_in_Ord])+
 done
 
 lemma succ_lepoll_succ_succ:
      "\<lbrakk>InfCard(x); n \<in> nat\<rbrakk> 
       \<Longrightarrow> {y \<in> Pow(x). y\<approx>succ(n)} \<lesssim> {y \<in> Pow(x). y\<approx>succ(succ(n))}"
   unfolding lepoll_def
 apply (rule_tac x = "\<lambda>z \<in> {y\<in>Pow(x). y\<approx>succ(n)}. cons(succ(\<Union>(z)), z)" 
        in exI)
 apply (rule_tac d = "\<lambda>z. z-{\<Union>(z) }" in lam_injective)
 apply (blast intro!: succ_Union_in_x succ_Union_not_mem
              intro: cons_eqpoll_succ Ord_in_Ord
              dest!: InfCard_is_Card [THEN Card_is_Ord])
 apply (simp only: Union_cons_eq_succ_Union) 
 apply (rule cons_Diff_eq)
 apply (fast dest!: InfCard_is_Card [THEN Card_is_Ord]
             elim: Ord_in_Ord 
             intro!: succ_Union_not_mem)
 done
 
 lemma subsets_eqpoll_X:
      "\<lbrakk>InfCard(X); n \<in> nat\<rbrakk> \<Longrightarrow> {Y \<in> Pow(X). Y\<approx>succ(n)} \<approx> X"
 apply (induct_tac "n")
 apply (rule subsets_eqpoll_1_eqpoll)
 apply (rule eqpollI)
 apply (rule subsets_lepoll_lemma1 [THEN lepoll_trans], assumption+)
 apply (rule eqpoll_trans [THEN eqpoll_imp_lepoll]) 
  apply (erule eqpoll_refl [THEN prod_eqpoll_cong])
 apply (erule InfCard_square_eqpoll)
 apply (fast elim: eqpoll_sym [THEN eqpoll_imp_lepoll, THEN lepoll_trans] 
             intro!: succ_lepoll_succ_succ)
 done
 
 lemma image_vimage_eq:
      "\<lbrakk>f \<in> surj(A,B); y \<subseteq> B\<rbrakk> \<Longrightarrow> f``(converse(f)``y) = y"
   unfolding surj_def
 apply (fast dest: apply_equality2 elim: apply_iff [THEN iffD2])
 done
 
 lemma vimage_image_eq: "\<lbrakk>f \<in> inj(A,B); y \<subseteq> A\<rbrakk> \<Longrightarrow> converse(f)``(f``y) = y"
 by (fast elim!: inj_is_fun [THEN apply_Pair] dest: inj_equality)
 
 lemma subsets_eqpoll:
      "A\<approx>B \<Longrightarrow> {Y \<in> Pow(A). Y\<approx>n}\<approx>{Y \<in> Pow(B). Y\<approx>n}"
   unfolding eqpoll_def
 apply (erule exE)
 apply (rule_tac x = "\<lambda>X \<in> {Y \<in> Pow (A) . \<exists>f. f \<in> bij (Y, n) }. f``X" in exI)
 apply (rule_tac d = "\<lambda>Z. converse (f) ``Z" in lam_bijective)
 apply (fast intro!: bij_is_inj [THEN restrict_bij, THEN bij_converse_bij, 
                                 THEN comp_bij] 
             elim!: bij_is_fun [THEN fun_is_rel, THEN image_subset])
 apply (blast intro!:  bij_is_inj [THEN restrict_bij] 
                       comp_bij bij_converse_bij
                       bij_is_fun [THEN fun_is_rel, THEN image_subset])
 apply (fast elim!: bij_is_inj [THEN vimage_image_eq])
 apply (fast elim!: bij_is_surj [THEN image_vimage_eq])
 done
 
 lemma WO2_imp_ex_Card: "WO2 \<Longrightarrow> \<exists>a. Card(a) \<and> X\<approx>a"
   unfolding WO2_def
 apply (drule spec [of _ X])
 apply (blast intro: Card_cardinal eqpoll_trans
           well_ord_Memrel [THEN well_ord_cardinal_eqpoll, THEN eqpoll_sym])
 done
 
 lemma lepoll_infinite: "\<lbrakk>X\<lesssim>Y; \<not>Finite(X)\<rbrakk> \<Longrightarrow> \<not>Finite(Y)"
 by (blast intro: lepoll_Finite)
 
 lemma infinite_Card_is_InfCard: "\<lbrakk>\<not>Finite(X); Card(X)\<rbrakk> \<Longrightarrow> InfCard(X)"
   unfolding InfCard_def
 apply (fast elim!: Card_is_Ord [THEN nat_le_infinite_Ord])
 done
 
 lemma WO2_infinite_subsets_eqpoll_X: "\<lbrakk>WO2; n \<in> nat; \<not>Finite(X)\<rbrakk>   
         \<Longrightarrow> {Y \<in> Pow(X). Y\<approx>succ(n)}\<approx>X"
 apply (drule WO2_imp_ex_Card)
 apply (elim allE exE conjE)
 apply (frule eqpoll_imp_lepoll [THEN lepoll_infinite], assumption)
 apply (drule infinite_Card_is_InfCard, assumption)
 apply (blast intro: subsets_eqpoll subsets_eqpoll_X eqpoll_sym eqpoll_trans) 
 done
 
 lemma well_ord_imp_ex_Card: "well_ord(X,R) \<Longrightarrow> \<exists>a. Card(a) \<and> X\<approx>a"
 by (fast elim!: well_ord_cardinal_eqpoll [THEN eqpoll_sym] 
          intro!: Card_cardinal)
 
 lemma well_ord_infinite_subsets_eqpoll_X:
      "\<lbrakk>well_ord(X,R); n \<in> nat; \<not>Finite(X)\<rbrakk> \<Longrightarrow> {Y \<in> Pow(X). Y\<approx>succ(n)}\<approx>X"
 apply (drule well_ord_imp_ex_Card)
 apply (elim allE exE conjE)
 apply (frule eqpoll_imp_lepoll [THEN lepoll_infinite], assumption)
 apply (drule infinite_Card_is_InfCard, assumption)
 apply (blast intro: subsets_eqpoll subsets_eqpoll_X eqpoll_sym eqpoll_trans) 
 done
 
 end
diff --git a/src/ZF/AC/AC17_AC1.thy b/src/ZF/AC/AC17_AC1.thy
--- a/src/ZF/AC/AC17_AC1.thy
+++ b/src/ZF/AC/AC17_AC1.thy
@@ -1,301 +1,301 @@
 (*  Title:      ZF/AC/AC17_AC1.thy
     Author:     Krzysztof Grabczewski
 
 The equivalence of AC0, AC1 and AC17
 
 Also, the proofs needed to show that each of AC2, AC3, ..., AC6 is equivalent
 to AC0 and AC1.
 *)
 
 theory AC17_AC1
 imports HH
 begin
 
 
 (** AC0 is equivalent to AC1.  
     AC0 comes from Suppes, AC1 from Rubin \<and> Rubin **)
 
 lemma AC0_AC1_lemma: "\<lbrakk>f:(\<Prod>X \<in> A. X); D \<subseteq> A\<rbrakk> \<Longrightarrow> \<exists>g. g:(\<Prod>X \<in> D. X)"
 by (fast intro!: lam_type apply_type)
 
 lemma AC0_AC1: "AC0 \<Longrightarrow> AC1"
-apply (unfold AC0_def AC1_def)
+  unfolding AC0_def AC1_def
 apply (blast intro: AC0_AC1_lemma)
 done
 
 lemma AC1_AC0: "AC1 \<Longrightarrow> AC0"
 by (unfold AC0_def AC1_def, blast)
 
 
 (**** The proof of AC1 \<Longrightarrow> AC17 ****)
 
 lemma AC1_AC17_lemma: "f \<in> (\<Prod>X \<in> Pow(A) - {0}. X) \<Longrightarrow> f \<in> (Pow(A) - {0} -> A)"
 apply (rule Pi_type, assumption)
 apply (drule apply_type, assumption, fast)
 done
 
 lemma AC1_AC17: "AC1 \<Longrightarrow> AC17"
-apply (unfold AC1_def AC17_def)
+  unfolding AC1_def AC17_def
 apply (rule allI)
 apply (rule ballI)
 apply (erule_tac x = "Pow (A) -{0}" in allE)
 apply (erule impE, fast)
 apply (erule exE)
 apply (rule bexI)
 apply (erule_tac [2] AC1_AC17_lemma)
 apply (rule apply_type, assumption)
 apply (fast dest!: AC1_AC17_lemma elim!: apply_type)
 done
 
 
 (**** The proof of AC17 \<Longrightarrow> AC1 ****)
 
 (* *********************************************************************** *)
 (* more properties of HH                                                   *)
 (* *********************************************************************** *)
 
 lemma UN_eq_imp_well_ord:
      "\<lbrakk>x - (\<Union>j \<in> \<mu> i. HH(\<lambda>X \<in> Pow(x)-{0}. {f`X}, x, i) = {x}.  
         HH(\<lambda>X \<in> Pow(x)-{0}. {f`X}, x, j)) = 0;   
         f \<in> Pow(x)-{0} -> x\<rbrakk>   
         \<Longrightarrow> \<exists>r. well_ord(x,r)"
 apply (rule exI)
 apply (erule well_ord_rvimage 
         [OF bij_Least_HH_x [THEN bij_converse_bij, THEN bij_is_inj] 
             Ord_Least [THEN well_ord_Memrel]], assumption)
 done
 
 (* *********************************************************************** *)
 (* theorems closer to the proof                                            *)
 (* *********************************************************************** *)
 
 lemma not_AC1_imp_ex:
      "\<not>AC1 \<Longrightarrow> \<exists>A. \<forall>f \<in> Pow(A)-{0} -> A. \<exists>u \<in> Pow(A)-{0}. f`u \<notin> u"
   unfolding AC1_def
 apply (erule swap)
 apply (rule allI)
 apply (erule swap)
 apply (rule_tac x = "\<Union>(A)" in exI)
 apply (blast intro: lam_type)
 done
 
 lemma AC17_AC1_aux1:
      "\<lbrakk>\<forall>f \<in> Pow(x) - {0} -> x. \<exists>u \<in> Pow(x) - {0}. f`u\<notin>u;   
          \<exists>f \<in> Pow(x)-{0}->x.  
             x - (\<Union>a \<in> (\<mu> i. HH(\<lambda>X \<in> Pow(x)-{0}. {f`X},x,i)={x}).   
             HH(\<lambda>X \<in> Pow(x)-{0}. {f`X},x,a)) = 0\<rbrakk>  
         \<Longrightarrow> P"
 apply (erule bexE)
 apply (erule UN_eq_imp_well_ord [THEN exE], assumption)
 apply (erule ex_choice_fun_Pow [THEN exE])
 apply (erule ballE) 
 apply (fast intro: apply_type del: DiffE)
 apply (erule notE)
 apply (rule Pi_type, assumption)
 apply (blast dest: apply_type) 
 done
 
 lemma AC17_AC1_aux2:
       "\<not> (\<exists>f \<in> Pow(x)-{0}->x. x - F(f) = 0)   
        \<Longrightarrow> (\<lambda>f \<in> Pow(x)-{0}->x . x - F(f))   
            \<in> (Pow(x) -{0} -> x) -> Pow(x) - {0}"
 by (fast intro!: lam_type dest!: Diff_eq_0_iff [THEN iffD1])
 
 lemma AC17_AC1_aux3:
      "\<lbrakk>f`Z \<in> Z; Z \<in> Pow(x)-{0}\<rbrakk> 
       \<Longrightarrow> (\<lambda>X \<in> Pow(x)-{0}. {f`X})`Z \<in> Pow(Z)-{0}"
 by auto
 
 lemma AC17_AC1_aux4:
      "\<exists>f \<in> F. f`((\<lambda>f \<in> F. Q(f))`f) \<in> (\<lambda>f \<in> F. Q(f))`f   
       \<Longrightarrow> \<exists>f \<in> F. f`Q(f) \<in> Q(f)"
 by simp
 
 lemma AC17_AC1: "AC17 \<Longrightarrow> AC1"
   unfolding AC17_def
 apply (rule classical)
 apply (erule not_AC1_imp_ex [THEN exE])
 apply (case_tac 
        "\<exists>f \<in> Pow(x)-{0} -> x. 
         x - (\<Union>a \<in> (\<mu> i. HH (\<lambda>X \<in> Pow (x) -{0}. {f`X},x,i) ={x}) . HH (\<lambda>X \<in> Pow (x) -{0}. {f`X},x,a)) = 0")
 apply (erule AC17_AC1_aux1, assumption)
 apply (drule AC17_AC1_aux2)
 apply (erule allE)
 apply (drule bspec, assumption)
 apply (drule AC17_AC1_aux4)
 apply (erule bexE)
 apply (drule apply_type, assumption)
 apply (simp add: HH_Least_eq_x del: Diff_iff ) 
 apply (drule AC17_AC1_aux3, assumption) 
 apply (fast dest!: subst_elem [OF _ HH_Least_eq_x [symmetric]]
                    f_subset_imp_HH_subset elim!: mem_irrefl)
 done
 
 
 (* **********************************************************************
     AC1 \<Longrightarrow> AC2 \<Longrightarrow> AC1
     AC1 \<Longrightarrow> AC4 \<Longrightarrow> AC3 \<Longrightarrow> AC1
     AC4 \<Longrightarrow> AC5 \<Longrightarrow> AC4
     AC1 \<longleftrightarrow> AC6
 ************************************************************************* *)
 
 (* ********************************************************************** *)
 (* AC1 \<Longrightarrow> AC2                                                            *)
 (* ********************************************************************** *)
 
 lemma AC1_AC2_aux1:
      "\<lbrakk>f:(\<Prod>X \<in> A. X);  B \<in> A;  0\<notin>A\<rbrakk> \<Longrightarrow> {f`B} \<subseteq> B \<inter> {f`C. C \<in> A}"
 by (fast elim!: apply_type)
 
 lemma AC1_AC2_aux2: 
         "\<lbrakk>pairwise_disjoint(A); B \<in> A; C \<in> A; D \<in> B; D \<in> C\<rbrakk> \<Longrightarrow> f`B = f`C"
 by (unfold pairwise_disjoint_def, fast)
 
 lemma AC1_AC2: "AC1 \<Longrightarrow> AC2"
-apply (unfold AC1_def AC2_def)
+  unfolding AC1_def AC2_def
 apply (rule allI)
 apply (rule impI)  
 apply (elim asm_rl conjE allE exE impE, assumption)
 apply (intro exI ballI equalityI)
 prefer 2 apply (rule AC1_AC2_aux1, assumption+)
 apply (fast elim!: AC1_AC2_aux2 elim: apply_type)
 done
 
 
 (* ********************************************************************** *)
 (* AC2 \<Longrightarrow> AC1                                                            *)
 (* ********************************************************************** *)
 
 lemma AC2_AC1_aux1: "0\<notin>A \<Longrightarrow> 0 \<notin> {B*{B}. B \<in> A}"
 by (fast dest!: sym [THEN Sigma_empty_iff [THEN iffD1]])
 
 lemma AC2_AC1_aux2: "\<lbrakk>X*{X} \<inter> C = {y}; X \<in> A\<rbrakk>   
                \<Longrightarrow> (THE y. X*{X} \<inter> C = {y}): X*A"
 apply (rule subst_elem [of y])
 apply (blast elim!: equalityE)
 apply (auto simp add: singleton_eq_iff) 
 done
 
 lemma AC2_AC1_aux3:
      "\<forall>D \<in> {E*{E}. E \<in> A}. \<exists>y. D \<inter> C = {y}   
       \<Longrightarrow> (\<lambda>x \<in> A. fst(THE z. (x*{x} \<inter> C = {z}))) \<in> (\<Prod>X \<in> A. X)"
 apply (rule lam_type)
 apply (drule bspec, blast)
 apply (blast intro: AC2_AC1_aux2 fst_type)
 done
 
 lemma AC2_AC1: "AC2 \<Longrightarrow> AC1"
-apply (unfold AC1_def AC2_def pairwise_disjoint_def)
+  unfolding AC1_def AC2_def pairwise_disjoint_def
 apply (intro allI impI)
 apply (elim allE impE)
 prefer 2 apply (fast elim!: AC2_AC1_aux3) 
 apply (blast intro!: AC2_AC1_aux1)
 done
 
 
 (* ********************************************************************** *)
 (* AC1 \<Longrightarrow> AC4                                                            *)
 (* ********************************************************************** *)
 
 lemma empty_notin_images: "0 \<notin> {R``{x}. x \<in> domain(R)}"
 by blast
 
 lemma AC1_AC4: "AC1 \<Longrightarrow> AC4"
-apply (unfold AC1_def AC4_def)
+  unfolding AC1_def AC4_def
 apply (intro allI impI)
 apply (drule spec, drule mp [OF _ empty_notin_images]) 
 apply (best intro!: lam_type elim!: apply_type)
 done
 
 
 (* ********************************************************************** *)
 (* AC4 \<Longrightarrow> AC3                                                            *)
 (* ********************************************************************** *)
 
 lemma AC4_AC3_aux1: "f \<in> A->B \<Longrightarrow> (\<Union>z \<in> A. {z}*f`z) \<subseteq> A*\<Union>(B)"
 by (fast dest!: apply_type)
 
 lemma AC4_AC3_aux2: "domain(\<Union>z \<in> A. {z}*f(z)) = {a \<in> A. f(a)\<noteq>0}"
 by blast
 
 lemma AC4_AC3_aux3: "x \<in> A \<Longrightarrow> (\<Union>z \<in> A. {z}*f(z))``{x} = f(x)"
 by fast
 
 lemma AC4_AC3: "AC4 \<Longrightarrow> AC3"
-apply (unfold AC3_def AC4_def)
+  unfolding AC3_def AC4_def
 apply (intro allI ballI)
 apply (elim allE impE)
 apply (erule AC4_AC3_aux1)
 apply (simp add: AC4_AC3_aux2 AC4_AC3_aux3 cong add: Pi_cong)
 done
 
 (* ********************************************************************** *)
 (* AC3 \<Longrightarrow> AC1                                                            *)
 (* ********************************************************************** *)
 
 lemma AC3_AC1_lemma:
      "b\<notin>A \<Longrightarrow> (\<Prod>x \<in> {a \<in> A. id(A)`a\<noteq>b}. id(A)`x) = (\<Prod>x \<in> A. x)"
 apply (simp add: id_def cong add: Pi_cong)
 apply (rule_tac b = A in subst_context, fast)
 done
 
 lemma AC3_AC1: "AC3 \<Longrightarrow> AC1"
-apply (unfold AC1_def AC3_def)
+  unfolding AC1_def AC3_def
 apply (fast intro!: id_type elim: AC3_AC1_lemma [THEN subst])
 done
 
 (* ********************************************************************** *)
 (* AC4 \<Longrightarrow> AC5                                                            *)
 (* ********************************************************************** *)
 
 lemma AC4_AC5: "AC4 \<Longrightarrow> AC5"
-apply (unfold range_def AC4_def AC5_def)
+  unfolding range_def AC4_def AC5_def
 apply (intro allI ballI)
 apply (elim allE impE)
 apply (erule fun_is_rel [THEN converse_type])
 apply (erule exE)
 apply (rename_tac g)
 apply (rule_tac x=g in bexI)
 apply (blast dest: apply_equality range_type) 
 apply (blast intro: Pi_type dest: apply_type fun_is_rel)
 done
 
 
 (* ********************************************************************** *)
 (* AC5 \<Longrightarrow> AC4, Rubin \<and> Rubin, p. 11                                      *)
 (* ********************************************************************** *)
 
 lemma AC5_AC4_aux1: "R \<subseteq> A*B \<Longrightarrow> (\<lambda>x \<in> R. fst(x)) \<in> R -> A"
 by (fast intro!: lam_type fst_type)
 
 lemma AC5_AC4_aux2: "R \<subseteq> A*B \<Longrightarrow> range(\<lambda>x \<in> R. fst(x)) = domain(R)"
 by (unfold lam_def, force)
 
 lemma AC5_AC4_aux3: "\<lbrakk>\<exists>f \<in> A->C. P(f,domain(f)); A=B\<rbrakk> \<Longrightarrow>  \<exists>f \<in> B->C. P(f,B)"
 apply (erule bexE)
 apply (frule domain_of_fun, fast)
 done
 
 lemma AC5_AC4_aux4: "\<lbrakk>R \<subseteq> A*B; g \<in> C->R; \<forall>x \<in> C. (\<lambda>z \<in> R. fst(z))` (g`x) = x\<rbrakk>  
                 \<Longrightarrow> (\<lambda>x \<in> C. snd(g`x)): (\<Prod>x \<in> C. R``{x})"
 apply (rule lam_type)
 apply (force dest: apply_type)
 done
 
 lemma AC5_AC4: "AC5 \<Longrightarrow> AC4"
 apply (unfold AC4_def AC5_def, clarify)
 apply (elim allE ballE)
 apply (drule AC5_AC4_aux3 [OF _ AC5_AC4_aux2], assumption)
 apply (fast elim!: AC5_AC4_aux4)
 apply (blast intro: AC5_AC4_aux1) 
 done
 
 
 (* ********************************************************************** *)
 (* AC1 \<longleftrightarrow> AC6                                                            *)
 (* ********************************************************************** *)
 
 lemma AC1_iff_AC6: "AC1 \<longleftrightarrow> AC6"
 by (unfold AC1_def AC6_def, blast)
 
 end
diff --git a/src/ZF/AC/AC7_AC9.thy b/src/ZF/AC/AC7_AC9.thy
--- a/src/ZF/AC/AC7_AC9.thy
+++ b/src/ZF/AC/AC7_AC9.thy
@@ -1,169 +1,169 @@
 (*  Title:      ZF/AC/AC7_AC9.thy
     Author:     Krzysztof Grabczewski
 
 The proofs needed to state that AC7, AC8 and AC9 are equivalent to the previous
 instances of AC.
 *)
 
 theory AC7_AC9
 imports AC_Equiv
 begin
 
 (* ********************************************************************** *)
 (* Lemmas used in the proofs AC7 \<Longrightarrow> AC6 and AC9 \<Longrightarrow> AC1                  *)
 (*  - Sigma_fun_space_not0                                                *)
 (*  - Sigma_fun_space_eqpoll                                              *)
 (* ********************************************************************** *)
 
 lemma Sigma_fun_space_not0: "\<lbrakk>0\<notin>A; B \<in> A\<rbrakk> \<Longrightarrow> (nat->\<Union>(A)) * B \<noteq> 0"
 by (blast dest!: Sigma_empty_iff [THEN iffD1] Union_empty_iff [THEN iffD1])
 
 lemma inj_lemma: 
         "C \<in> A \<Longrightarrow> (\<lambda>g \<in> (nat->\<Union>(A))*C.   
                 (\<lambda>n \<in> nat. if(n=0, snd(g), fst(g)`(n #- 1))))   
                 \<in> inj((nat->\<Union>(A))*C, (nat->\<Union>(A)) ) "
   unfolding inj_def
 apply (rule CollectI)
 apply (fast intro!: lam_type if_type apply_type fst_type snd_type, auto) 
 apply (rule fun_extension, assumption+)
 apply (drule lam_eqE [OF _ nat_succI], assumption, simp) 
 apply (drule lam_eqE [OF _ nat_0I], simp) 
 done
 
 lemma Sigma_fun_space_eqpoll:
      "\<lbrakk>C \<in> A; 0\<notin>A\<rbrakk> \<Longrightarrow> (nat->\<Union>(A)) * C \<approx> (nat->\<Union>(A))"
 apply (rule eqpollI)
 apply (simp add: lepoll_def)
 apply (fast intro!: inj_lemma)
 apply (fast elim!: prod_lepoll_self not_sym [THEN not_emptyE] subst_elem 
             elim: swap)
 done
 
 
 (* ********************************************************************** *)
 (* AC6 \<Longrightarrow> AC7                                                            *)
 (* ********************************************************************** *)
 
 lemma AC6_AC7: "AC6 \<Longrightarrow> AC7"
 by (unfold AC6_def AC7_def, blast)
 
 (* ********************************************************************** *)
 (* AC7 \<Longrightarrow> AC6, Rubin \<and> Rubin p. 12, Theorem 2.8                          *)
 (* The case of the empty family of sets added in order to complete        *)
 (* the proof.                                                             *)
 (* ********************************************************************** *)
 
 lemma lemma1_1: "y \<in> (\<Prod>B \<in> A. Y*B) \<Longrightarrow> (\<lambda>B \<in> A. snd(y`B)) \<in> (\<Prod>B \<in> A. B)"
 by (fast intro!: lam_type snd_type apply_type)
 
 lemma lemma1_2:
      "y \<in> (\<Prod>B \<in> {Y*C. C \<in> A}. B) \<Longrightarrow> (\<lambda>B \<in> A. y`(Y*B)) \<in> (\<Prod>B \<in> A. Y*B)"
 apply (fast intro!: lam_type apply_type)
 done
 
 lemma AC7_AC6_lemma1:
      "(\<Prod>B \<in> {(nat->\<Union>(A))*C. C \<in> A}. B) \<noteq> 0 \<Longrightarrow> (\<Prod>B \<in> A. B) \<noteq> 0"
 by (fast intro!: equals0I lemma1_1 lemma1_2)
 
 lemma AC7_AC6_lemma2: "0 \<notin> A \<Longrightarrow> 0 \<notin> {(nat -> \<Union>(A)) * C. C \<in> A}"
 by (blast dest: Sigma_fun_space_not0)
 
 lemma AC7_AC6: "AC7 \<Longrightarrow> AC6"
-apply (unfold AC6_def AC7_def)
+  unfolding AC6_def AC7_def
 apply (rule allI)
 apply (rule impI)
 apply (case_tac "A=0", simp)
 apply (rule AC7_AC6_lemma1)
 apply (erule allE) 
 apply (blast del: notI
              intro!: AC7_AC6_lemma2 intro: eqpoll_sym eqpoll_trans 
                     Sigma_fun_space_eqpoll)
 done
 
 
 (* ********************************************************************** *)
 (* AC1 \<Longrightarrow> AC8                                                            *)
 (* ********************************************************************** *)
 
 lemma AC1_AC8_lemma1: 
         "\<forall>B \<in> A. \<exists>B1 B2. B=\<langle>B1,B2\<rangle> \<and> B1 \<approx> B2   
         \<Longrightarrow> 0 \<notin> { bij(fst(B),snd(B)). B \<in> A }"
 apply (unfold eqpoll_def, auto)
 done
 
 lemma AC1_AC8_lemma2:
      "\<lbrakk>f \<in> (\<Prod>X \<in> RepFun(A,p). X); D \<in> A\<rbrakk> \<Longrightarrow> (\<lambda>x \<in> A. f`p(x))`D \<in> p(D)" 
 apply (simp, fast elim!: apply_type)
 done
 
 lemma AC1_AC8: "AC1 \<Longrightarrow> AC8"
-apply (unfold AC1_def AC8_def)
+  unfolding AC1_def AC8_def
 apply (fast dest: AC1_AC8_lemma1 AC1_AC8_lemma2)
 done
 
 
 (* ********************************************************************** *)
 (* AC8 \<Longrightarrow> AC9                                                            *)
 (*  - this proof replaces the following two from Rubin \<and> Rubin:           *)
 (*    AC8 \<Longrightarrow> AC1 and AC1 \<Longrightarrow> AC9                                         *)
 (* ********************************************************************** *)
 
 lemma AC8_AC9_lemma:
      "\<forall>B1 \<in> A. \<forall>B2 \<in> A. B1 \<approx> B2 
       \<Longrightarrow> \<forall>B \<in> A*A. \<exists>B1 B2. B=\<langle>B1,B2\<rangle> \<and> B1 \<approx> B2"
 by fast
 
 lemma AC8_AC9: "AC8 \<Longrightarrow> AC9"
-apply (unfold AC8_def AC9_def)
+  unfolding AC8_def AC9_def
 apply (intro allI impI)
 apply (erule allE)
 apply (erule impE, erule AC8_AC9_lemma, force) 
 done
 
 
 (* ********************************************************************** *)
 (* AC9 \<Longrightarrow> AC1                                                            *)
 (* The idea of this proof comes from "Equivalents of the Axiom of Choice" *)
 (* by Rubin \<and> Rubin. But (x * y) is not necessarily equipollent to        *)
 (* (x * y) \<union> {0} when y is a set of total functions acting from nat to   *)
 (* \<Union>(A) -- therefore we have used the set (y * nat) instead of y.     *)
 (* ********************************************************************** *)
 
 lemma snd_lepoll_SigmaI: "b \<in> B \<Longrightarrow> X \<lesssim> B \<times> X"
 by (blast intro: lepoll_trans prod_lepoll_self eqpoll_imp_lepoll 
                  prod_commute_eqpoll) 
 
 lemma nat_lepoll_lemma:
      "\<lbrakk>0 \<notin> A; B \<in> A\<rbrakk> \<Longrightarrow> nat \<lesssim> ((nat \<rightarrow> \<Union>(A)) \<times> B) \<times> nat"
 by (blast dest: Sigma_fun_space_not0 intro: snd_lepoll_SigmaI)
 
 lemma AC9_AC1_lemma1:
      "\<lbrakk>0\<notin>A;  A\<noteq>0;   
          C = {((nat->\<Union>(A))*B)*nat. B \<in> A}  \<union>  
              {cons(0,((nat->\<Union>(A))*B)*nat). B \<in> A};  
          B1 \<in> C;  B2 \<in> C\<rbrakk>   
       \<Longrightarrow> B1 \<approx> B2"
 by (blast intro!: nat_lepoll_lemma Sigma_fun_space_eqpoll
                      nat_cons_eqpoll [THEN eqpoll_trans] 
                      prod_eqpoll_cong [OF _ eqpoll_refl]
              intro: eqpoll_trans eqpoll_sym )
 
 lemma AC9_AC1_lemma2:
      "\<forall>B1 \<in> {(F*B)*N. B \<in> A} \<union> {cons(0,(F*B)*N). B \<in> A}.   
       \<forall>B2 \<in> {(F*B)*N. B \<in> A} \<union> {cons(0,(F*B)*N). B \<in> A}.   
         f`\<langle>B1,B2\<rangle> \<in> bij(B1, B2)   
       \<Longrightarrow> (\<lambda>B \<in> A. snd(fst((f`<cons(0,(F*B)*N),(F*B)*N>)`0))) \<in> (\<Prod>X \<in> A. X)"
 apply (intro lam_type snd_type fst_type)
 apply (rule apply_type [OF _ consI1]) 
 apply (fast intro!: fun_weaken_type bij_is_fun)
 done
 
 lemma AC9_AC1: "AC9 \<Longrightarrow> AC1"
-apply (unfold AC1_def AC9_def)
+  unfolding AC1_def AC9_def
 apply (intro allI impI)
 apply (erule allE)
 apply (case_tac "A\<noteq>0")
 apply (blast dest: AC9_AC1_lemma1 AC9_AC1_lemma2, force) 
 done
 
 end
diff --git a/src/ZF/AC/DC.thy b/src/ZF/AC/DC.thy
--- a/src/ZF/AC/DC.thy
+++ b/src/ZF/AC/DC.thy
@@ -1,585 +1,585 @@
 (*  Title:      ZF/AC/DC.thy
     Author:     Krzysztof Grabczewski
 
 The proofs concerning the Axiom of Dependent Choice.
 *)
 
 theory DC
 imports AC_Equiv Hartog Cardinal_aux
 begin
 
 lemma RepFun_lepoll: "Ord(a) \<Longrightarrow> {P(b). b \<in> a} \<lesssim> a"
   unfolding lepoll_def
 apply (rule_tac x = "\<lambda>z \<in> RepFun (a,P) . \<mu> i. z=P (i) " in exI)
 apply (rule_tac d="\<lambda>z. P (z)" in lam_injective)
  apply (fast intro!: Least_in_Ord)
 apply (rule sym) 
 apply (fast intro: LeastI Ord_in_Ord) 
 done
 
 text\<open>Trivial in the presence of AC, but here we need a wellordering of X\<close>
 lemma image_Ord_lepoll: "\<lbrakk>f \<in> X->Y; Ord(X)\<rbrakk> \<Longrightarrow> f``X \<lesssim> X"
   unfolding lepoll_def
 apply (rule_tac x = "\<lambda>x \<in> f``X. \<mu> y. f`y = x" in exI)
 apply (rule_tac d = "\<lambda>z. f`z" in lam_injective)
 apply (fast intro!: Least_in_Ord apply_equality, clarify) 
 apply (rule LeastI) 
  apply (erule apply_equality, assumption+) 
 apply (blast intro: Ord_in_Ord)
 done
 
 lemma range_subset_domain: 
       "\<lbrakk>R \<subseteq> X*X;   \<And>g. g \<in> X \<Longrightarrow> \<exists>u. \<langle>g,u\<rangle> \<in> R\<rbrakk> 
        \<Longrightarrow> range(R) \<subseteq> domain(R)"
 by blast 
 
 lemma cons_fun_type: "g \<in> n->X \<Longrightarrow> cons(\<langle>n,x\<rangle>, g) \<in> succ(n) -> cons(x, X)"
   unfolding succ_def
 apply (fast intro!: fun_extend elim!: mem_irrefl)
 done
 
 lemma cons_fun_type2:
      "\<lbrakk>g \<in> n->X; x \<in> X\<rbrakk> \<Longrightarrow> cons(\<langle>n,x\<rangle>, g) \<in> succ(n) -> X"
 by (erule cons_absorb [THEN subst], erule cons_fun_type)
 
 lemma cons_image_n: "n \<in> nat \<Longrightarrow> cons(\<langle>n,x\<rangle>, g)``n = g``n"
 by (fast elim!: mem_irrefl)
 
 lemma cons_val_n: "g \<in> n->X \<Longrightarrow> cons(\<langle>n,x\<rangle>, g)`n = x"
 by (fast intro!: apply_equality elim!: cons_fun_type)
 
 lemma cons_image_k: "k \<in> n \<Longrightarrow> cons(\<langle>n,x\<rangle>, g)``k = g``k"
 by (fast elim: mem_asym)
 
 lemma cons_val_k: "\<lbrakk>k \<in> n; g \<in> n->X\<rbrakk> \<Longrightarrow> cons(\<langle>n,x\<rangle>, g)`k = g`k"
 by (fast intro!: apply_equality consI2 elim!: cons_fun_type apply_Pair)
 
 lemma domain_cons_eq_succ: "domain(f)=x \<Longrightarrow> domain(cons(\<langle>x,y\<rangle>, f)) = succ(x)"
 by (simp add: domain_cons succ_def)
 
 lemma restrict_cons_eq: "g \<in> n->X \<Longrightarrow> restrict(cons(\<langle>n,x\<rangle>, g), n) = g"
 apply (simp add: restrict_def Pi_iff)
 apply (blast intro: elim: mem_irrefl)  
 done
 
 lemma succ_in_succ: "\<lbrakk>Ord(k); i \<in> k\<rbrakk> \<Longrightarrow> succ(i) \<in> succ(k)"
 apply (rule Ord_linear [of "succ(i)" "succ(k)", THEN disjE])
 apply (fast elim: Ord_in_Ord mem_irrefl mem_asym)+
 done
 
 lemma restrict_eq_imp_val_eq: 
       "\<lbrakk>restrict(f, domain(g)) = g; x \<in> domain(g)\<rbrakk> 
        \<Longrightarrow> f`x = g`x" 
 by (erule subst, simp add: restrict)
 
 lemma domain_eq_imp_fun_type: "\<lbrakk>domain(f)=A; f \<in> B->C\<rbrakk> \<Longrightarrow> f \<in> A->C"
 by (frule domain_of_fun, fast)
 
 lemma ex_in_domain: "\<lbrakk>R \<subseteq> A * B; R \<noteq> 0\<rbrakk> \<Longrightarrow> \<exists>x. x \<in> domain(R)"
 by (fast elim!: not_emptyE)
 
 
 definition
   DC  :: "i \<Rightarrow> o"  where
     "DC(a) \<equiv> \<forall>X R. R \<subseteq> Pow(X)*X  \<and>
                     (\<forall>Y \<in> Pow(X). Y \<prec> a \<longrightarrow> (\<exists>x \<in> X. \<langle>Y,x\<rangle> \<in> R)) 
                     \<longrightarrow> (\<exists>f \<in> a->X. \<forall>b<a. <f``b,f`b> \<in> R)"
 
 definition
   DC0 :: o  where
     "DC0 \<equiv> \<forall>A B R. R \<subseteq> A*B \<and> R\<noteq>0 \<and> range(R) \<subseteq> domain(R) 
                     \<longrightarrow> (\<exists>f \<in> nat->domain(R). \<forall>n \<in> nat. <f`n,f`succ(n)>:R)"
 
 definition
   ff  :: "[i, i, i, i] \<Rightarrow> i"  where
     "ff(b, X, Q, R) \<equiv>
            transrec(b, \<lambda>c r. THE x. first(x, {x \<in> X. <r``c, x> \<in> R}, Q))"
 
 
 locale DC0_imp =
   fixes XX and RR and X and R
 
   assumes all_ex: "\<forall>Y \<in> Pow(X). Y \<prec> nat \<longrightarrow> (\<exists>x \<in> X. \<langle>Y, x\<rangle> \<in> R)"
 
   defines XX_def: "XX \<equiv> (\<Union>n \<in> nat. {f \<in> n->X. \<forall>k \<in> n. <f``k, f`k> \<in> R})"
      and RR_def:  "RR \<equiv> {\<langle>z1,z2\<rangle>:XX*XX. domain(z2)=succ(domain(z1))  
                                        \<and> restrict(z2, domain(z1)) = z1}"
 begin
 
 (* ********************************************************************** *)
 (* DC \<Longrightarrow> DC(omega)                                                       *)
 (*                                                                        *)
 (* The scheme of the proof:                                               *)
 (*                                                                        *)
 (* Assume DC. Let R and X satisfy the premise of DC(omega).               *)
 (*                                                                        *)
 (* Define XX and RR as follows:                                           *)
 (*                                                                        *)
 (*       XX = (\<Union>n \<in> nat. {f \<in> n->X. \<forall>k \<in> n. <f``k, f`k> \<in> R})           *)
 (*       f RR g iff domain(g)=succ(domain(f)) \<and>                           *)
 (*              restrict(g, domain(f)) = f                                *)
 (*                                                                        *)
 (* Then RR satisfies the hypotheses of DC.                                *)
 (* So applying DC:                                                        *)
 (*                                                                        *)
 (*       \<exists>f \<in> nat->XX. \<forall>n \<in> nat. f`n RR f`succ(n)                        *)
 (*                                                                        *)
 (* Thence                                                                 *)
 (*                                                                        *)
 (*       ff = {<n, f`succ(n)`n>. n \<in> nat}                                 *)
 (*                                                                        *)
 (* is the desired function.                                               *)
 (*                                                                        *)
 (* ********************************************************************** *)
 
 lemma lemma1_1: "RR \<subseteq> XX*XX"
 by (unfold RR_def, fast)
 
 lemma lemma1_2: "RR \<noteq> 0"
-apply (unfold RR_def XX_def)
+  unfolding RR_def XX_def
 apply (rule all_ex [THEN ballE])
 apply (erule_tac [2] notE [OF _ empty_subsetI [THEN PowI]])
 apply (erule_tac impE [OF _ nat_0I [THEN n_lesspoll_nat]])
 apply (erule bexE)
 apply (rule_tac a = "<0, {\<langle>0, x\<rangle>}>" in not_emptyI)
 apply (rule CollectI)
 apply (rule SigmaI)
 apply (rule nat_0I [THEN UN_I])
 apply (simp (no_asm_simp) add: nat_0I [THEN UN_I])
 apply (rule nat_1I [THEN UN_I])
 apply (force intro!: singleton_fun [THEN Pi_type]
              simp add: singleton_0 [symmetric])
 apply (simp add: singleton_0)
 done
 
 lemma lemma1_3: "range(RR) \<subseteq> domain(RR)"
-apply (unfold RR_def XX_def)
+  unfolding RR_def XX_def
 apply (rule range_subset_domain, blast, clarify)
 apply (frule fun_is_rel [THEN image_subset, THEN PowI, 
                          THEN all_ex [THEN bspec]])
 apply (erule impE[OF _ lesspoll_trans1[OF image_Ord_lepoll 
                                           [OF _ nat_into_Ord] n_lesspoll_nat]],
        assumption+)
 apply (erule bexE)
 apply (rule_tac x = "cons (\<langle>n,x\<rangle>, g) " in exI)
 apply (rule CollectI)
 apply (force elim!: cons_fun_type2 
              simp add: cons_image_n cons_val_n cons_image_k cons_val_k)
 apply (simp add: domain_of_fun succ_def restrict_cons_eq)
 done
 
 lemma lemma2:
      "\<lbrakk>\<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  n \<in> nat\<rbrakk>   
       \<Longrightarrow> \<exists>k \<in> nat. f`succ(n) \<in> k -> X \<and> n \<in> k   
                   \<and> <f`succ(n)``n, f`succ(n)`n> \<in> R"
 apply (induct_tac "n")
 apply (drule apply_type [OF _ nat_1I])
 apply (drule bspec [OF _ nat_0I])
 apply (simp add: XX_def, safe)
 apply (rule rev_bexI, assumption)
 apply (subgoal_tac "0 \<in> y", force)
 apply (force simp add: RR_def
              intro: ltD elim!: nat_0_le [THEN leE])
 (** LEVEL 7, other subgoal **)
 apply (drule bspec [OF _ nat_succI], assumption)
 apply (subgoal_tac "f ` succ (succ (x)) \<in> succ (k) ->X")
 apply (drule apply_type [OF _ nat_succI [THEN nat_succI]], assumption)
 apply (simp (no_asm_use) add: XX_def RR_def)
 apply safe
 apply (frule_tac a="succ(k)" in domain_of_fun [symmetric, THEN trans], 
        assumption)
 apply (frule_tac a=y in domain_of_fun [symmetric, THEN trans], 
        assumption)
 apply (fast elim!: nat_into_Ord [THEN succ_in_succ] 
             dest!: bspec [OF _ nat_into_Ord [THEN succ_in_succ]])
 apply (drule domain_of_fun)
 apply (simp add: XX_def RR_def, clarify) 
 apply (blast dest: domain_of_fun [symmetric, THEN trans] )
 done
 
 lemma lemma3_1:
      "\<lbrakk>\<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  m \<in> nat\<rbrakk>   
       \<Longrightarrow>  {f`succ(x)`x. x \<in> m} = {f`succ(m)`x. x \<in> m}"
 apply (subgoal_tac "\<forall>x \<in> m. f`succ (m) `x = f`succ (x) `x")
 apply simp
 apply (induct_tac "m", blast)
 apply (rule ballI)
 apply (erule succE)
  apply (rule restrict_eq_imp_val_eq)
   apply (drule bspec [OF _ nat_succI], assumption)
   apply (simp add: RR_def)
  apply (drule lemma2, assumption+)
  apply (fast dest!: domain_of_fun)
 apply (drule_tac x = xa in bspec, assumption)
 apply (erule sym [THEN trans, symmetric])
 apply (rule restrict_eq_imp_val_eq [symmetric])
  apply (drule bspec [OF _ nat_succI], assumption)
  apply (simp add: RR_def)
 apply (drule lemma2, assumption+)
 apply (blast dest!: domain_of_fun 
              intro: nat_into_Ord OrdmemD [THEN subsetD])
 done
 
 lemma lemma3:
      "\<lbrakk>\<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  m \<in> nat\<rbrakk>  
       \<Longrightarrow> (\<lambda>x \<in> nat. f`succ(x)`x) `` m = f`succ(m)``m"
 apply (erule natE, simp)
 apply (subst image_lam)
  apply (fast elim!: OrdmemD [OF nat_succI Ord_nat])
 apply (subst lemma3_1, assumption+)
  apply fast
 apply (fast dest!: lemma2 
             elim!: image_fun [symmetric, OF _ OrdmemD [OF _ nat_into_Ord]])
 done
 
 end
 
 theorem DC0_imp_DC_nat: "DC0 \<Longrightarrow> DC(nat)"
 apply (unfold DC_def DC0_def, clarify)
 apply (elim allE)
 apply (erule impE)
    (*these three results comprise Lemma 1*)
 apply (blast intro!: DC0_imp.lemma1_1 [OF DC0_imp.intro] DC0_imp.lemma1_2 [OF DC0_imp.intro] DC0_imp.lemma1_3 [OF DC0_imp.intro])
 apply (erule bexE)
 apply (rule_tac x = "\<lambda>n \<in> nat. f`succ (n) `n" in rev_bexI)
  apply (rule lam_type, blast dest!: DC0_imp.lemma2 [OF DC0_imp.intro] intro: fun_weaken_type)
 apply (rule oallI)
 apply (frule DC0_imp.lemma2 [OF DC0_imp.intro], assumption)
   apply (blast intro: fun_weaken_type)
  apply (erule ltD) 
 (** LEVEL 11: last subgoal **)
 apply (subst DC0_imp.lemma3 [OF DC0_imp.intro], assumption+) 
   apply (fast elim!: fun_weaken_type)
  apply (erule ltD) 
 apply (force simp add: lt_def) 
 done
 
 
 (* ************************************************************************
    DC(omega) \<Longrightarrow> DC                                                       
                                                                           
    The scheme of the proof:                                               
                                                                           
    Assume DC(omega). Let R and x satisfy the premise of DC.               
                                                                           
    Define XX and RR as follows:                                           
                                                                           
     XX = (\<Union>n \<in> nat. {f \<in> succ(n)->domain(R). \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})
 
     RR = {\<langle>z1,z2\<rangle>:Fin(XX)*XX. 
            (domain(z2)=succ(\<Union>f \<in> z1. domain(f)) \<and>
             (\<forall>f \<in> z1. restrict(z2, domain(f)) = f)) |      
            (\<not> (\<exists>g \<in> XX. domain(g)=succ(\<Union>f \<in> z1. domain(f)) \<and>
                         (\<forall>f \<in> z1. restrict(g, domain(f)) = f)) \<and>           
             z2={\<langle>0,x\<rangle>})}                                          
                                                                           
    Then XX and RR satisfy the hypotheses of DC(omega).                    
    So applying DC:                                                        
                                                                           
          \<exists>f \<in> nat->XX. \<forall>n \<in> nat. f``n RR f`n                             
                                                                           
    Thence                                                                 
                                                                           
          ff = {<n, f`n`n>. n \<in> nat}                                         
                                                                           
    is the desired function.                                               
                                                                           
 ************************************************************************* *)
 
 lemma singleton_in_funs: 
  "x \<in> X \<Longrightarrow> {\<langle>0,x\<rangle>} \<in> 
             (\<Union>n \<in> nat. {f \<in> succ(n)->X. \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})"
 apply (rule nat_0I [THEN UN_I])
 apply (force simp add: singleton_0 [symmetric]
              intro!: singleton_fun [THEN Pi_type])
 done
 
 
 locale imp_DC0 =
   fixes XX and RR and x and R and f and allRR
   defines XX_def: "XX \<equiv> (\<Union>n \<in> nat.
                       {f \<in> succ(n)->domain(R). \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})"
       and RR_def:
          "RR \<equiv> {\<langle>z1,z2\<rangle>:Fin(XX)*XX. 
                   (domain(z2)=succ(\<Union>f \<in> z1. domain(f))  
                     \<and> (\<forall>f \<in> z1. restrict(z2, domain(f)) = f))
                   | (\<not> (\<exists>g \<in> XX. domain(g)=succ(\<Union>f \<in> z1. domain(f))  
                      \<and> (\<forall>f \<in> z1. restrict(g, domain(f)) = f)) \<and> z2={\<langle>0,x\<rangle>})}"
       and allRR_def:
         "allRR \<equiv> \<forall>b<nat.
                    <f``b, f`b> \<in>  
                     {\<langle>z1,z2\<rangle>\<in>Fin(XX)*XX. (domain(z2)=succ(\<Union>f \<in> z1. domain(f))
                                     \<and> (\<Union>f \<in> z1. domain(f)) = b  
                                     \<and> (\<forall>f \<in> z1. restrict(z2,domain(f)) = f))}"
 begin
 
 lemma lemma4:
      "\<lbrakk>range(R) \<subseteq> domain(R);  x \<in> domain(R)\<rbrakk>   
       \<Longrightarrow> RR \<subseteq> Pow(XX)*XX \<and>   
              (\<forall>Y \<in> Pow(XX). Y \<prec> nat \<longrightarrow> (\<exists>x \<in> XX. \<langle>Y,x\<rangle>:RR))"
 apply (rule conjI)
 apply (force dest!: FinD [THEN PowI] simp add: RR_def)
 apply (rule impI [THEN ballI])
 apply (drule Finite_Fin [OF lesspoll_nat_is_Finite PowD], assumption)
 apply (case_tac
        "\<exists>g \<in> XX. domain (g) =
              succ(\<Union>f \<in> Y. domain(f)) \<and> (\<forall>f\<in>Y. restrict(g, domain(f)) = f)")
 apply (simp add: RR_def, blast)
 apply (safe del: domainE)
-apply (unfold XX_def RR_def)
+  unfolding XX_def RR_def
 apply (rule rev_bexI, erule singleton_in_funs)
 apply (simp add: nat_0I [THEN rev_bexI] cons_fun_type2)
 done
 
 lemma UN_image_succ_eq:
      "\<lbrakk>f \<in> nat->X; n \<in> nat\<rbrakk> 
       \<Longrightarrow> (\<Union>x \<in> f``succ(n). P(x)) =  P(f`n) \<union> (\<Union>x \<in> f``n. P(x))"
 by (simp add: image_fun OrdmemD) 
 
 lemma UN_image_succ_eq_succ:
      "\<lbrakk>(\<Union>x \<in> f``n. P(x)) = y; P(f`n) = succ(y);   
          f \<in> nat -> X; n \<in> nat\<rbrakk> \<Longrightarrow> (\<Union>x \<in> f``succ(n). P(x)) = succ(y)"
 by (simp add: UN_image_succ_eq, blast)
 
 lemma apply_domain_type:
      "\<lbrakk>h \<in> succ(n) -> D;  n \<in> nat; domain(h)=succ(y)\<rbrakk> \<Longrightarrow> h`y \<in> D"
 by (fast elim: apply_type dest!: trans [OF sym domain_of_fun])
 
 lemma image_fun_succ:
      "\<lbrakk>h \<in> nat -> X; n \<in> nat\<rbrakk> \<Longrightarrow> h``succ(n) = cons(h`n, h``n)"
 by (simp add: image_fun OrdmemD) 
 
 lemma f_n_type:
      "\<lbrakk>domain(f`n) = succ(k); f \<in> nat -> XX;  n \<in> nat\<rbrakk>    
       \<Longrightarrow> f`n \<in> succ(k) -> domain(R)"
   unfolding XX_def
 apply (drule apply_type, assumption)
 apply (fast elim: domain_eq_imp_fun_type)
 done
 
 lemma f_n_pairs_in_R [rule_format]: 
      "\<lbrakk>h \<in> nat -> XX;  domain(h`n) = succ(k);  n \<in> nat\<rbrakk>   
       \<Longrightarrow> \<forall>i \<in> k. <h`n`i, h`n`succ(i)> \<in> R"
   unfolding XX_def
 apply (drule apply_type, assumption)
 apply (elim UN_E CollectE)
 apply (drule domain_of_fun [symmetric, THEN trans], assumption, simp)
 done
 
 lemma restrict_cons_eq_restrict: 
      "\<lbrakk>restrict(h, domain(u))=u;  h \<in> n->X;  domain(u) \<subseteq> n\<rbrakk>   
       \<Longrightarrow> restrict(cons(\<langle>n, y\<rangle>, h), domain(u)) = u"
   unfolding restrict_def
 apply (simp add: restrict_def Pi_iff)
 apply (erule sym [THEN trans, symmetric])
 apply (blast elim: mem_irrefl)  
 done
 
 lemma all_in_image_restrict_eq:
      "\<lbrakk>\<forall>x \<in> f``n. restrict(f`n, domain(x))=x;   
          f \<in> nat -> XX;   
          n \<in> nat;  domain(f`n) = succ(n);   
          (\<Union>x \<in> f``n. domain(x)) \<subseteq> n\<rbrakk>  
       \<Longrightarrow> \<forall>x \<in> f``succ(n). restrict(cons(<succ(n),y>, f`n), domain(x)) = x"
 apply (rule ballI)
 apply (simp add: image_fun_succ)
 apply (drule f_n_type, assumption+)
 apply (erule disjE)
  apply (simp add: domain_of_fun restrict_cons_eq) 
 apply (blast intro!: restrict_cons_eq_restrict)
 done
 
 lemma simplify_recursion: 
      "\<lbrakk>\<forall>b<nat. <f``b, f`b> \<in> RR;   
          f \<in> nat -> XX; range(R) \<subseteq> domain(R); x \<in> domain(R)\<rbrakk>    
       \<Longrightarrow> allRR"
-apply (unfold RR_def allRR_def)
+  unfolding RR_def allRR_def
 apply (rule oallI, drule ltD)
 apply (erule nat_induct)
 apply (drule_tac x=0 in ospec, blast intro: Limit_has_0) 
 apply (force simp add: singleton_fun [THEN domain_of_fun] singleton_in_funs) 
 (*induction step*) (** LEVEL 5 **)
 (*prevent simplification of \<not>\<exists> to \<forall>\<not> *)
 apply (simp only: separation split)
 apply (drule_tac x="succ(xa)" in ospec, blast intro: ltI)
 apply (elim conjE disjE)
 apply (force elim!: trans subst_context
              intro!: UN_image_succ_eq_succ)
 apply (erule notE)
 apply (simp add: XX_def UN_image_succ_eq_succ)
 apply (elim conjE bexE)
 apply (drule apply_domain_type, assumption+)
 apply (erule domainE)+
 apply (frule f_n_type)
 apply (simp add: XX_def, assumption+)
 apply (rule rev_bexI, erule nat_succI)
 apply (rename_tac m i j y z) 
 apply (rule_tac x = "cons(<succ(m), z>, f`m)" in bexI)
 prefer 2 apply (blast intro: cons_fun_type2) 
 apply (rule conjI)
 prefer 2 apply (fast del: ballI subsetI
                  elim: trans [OF _ subst_context, THEN domain_cons_eq_succ]
                        subst_context
                        all_in_image_restrict_eq [simplified XX_def]
                        trans equalityD1)
 (*one remaining subgoal*)
 apply (rule ballI)
 apply (erule succE)
 (** LEVEL 25 **)
  apply (simp add: cons_val_n cons_val_k)
 (*assumption+ will not perform the required backtracking!*)
 apply (drule f_n_pairs_in_R [simplified XX_def, OF _ domain_of_fun], 
        assumption, assumption, assumption)
 apply (simp add: nat_into_Ord [THEN succ_in_succ] succI2 cons_val_k)
 done
 
 
 lemma lemma2: 
      "\<lbrakk>allRR; f \<in> nat->XX; range(R) \<subseteq> domain(R); x \<in> domain(R); n \<in> nat\<rbrakk>
       \<Longrightarrow> f`n \<in> succ(n) -> domain(R) \<and> (\<forall>i \<in> n. <f`n`i, f`n`succ(i)>:R)"
   unfolding allRR_def
 apply (drule ospec)
 apply (erule ltI [OF _ Ord_nat])
 apply (erule CollectE, simp)
 apply (rule conjI)
 prefer 2 apply (fast elim!: f_n_pairs_in_R trans subst_context)
   unfolding XX_def
 apply (fast elim!: trans [THEN domain_eq_imp_fun_type] subst_context)
 done
 
 lemma lemma3:
      "\<lbrakk>allRR; f \<in> nat->XX; n\<in>nat; range(R) \<subseteq> domain(R);  x \<in> domain(R)\<rbrakk>
       \<Longrightarrow> f`n`n = f`succ(n)`n"
 apply (frule lemma2 [THEN conjunct1, THEN domain_of_fun], assumption+)
   unfolding allRR_def
 apply (drule ospec) 
 apply (drule ltI [OF nat_succI Ord_nat], assumption, simp)
 apply (elim conjE ballE)
 apply (erule restrict_eq_imp_val_eq [symmetric], force) 
 apply (simp add: image_fun OrdmemD) 
 done
 
 end
 
 
 theorem DC_nat_imp_DC0: "DC(nat) \<Longrightarrow> DC0"
-apply (unfold DC_def DC0_def)
+  unfolding DC_def DC0_def
 apply (intro allI impI)
 apply (erule asm_rl conjE ex_in_domain [THEN exE] allE)+
 apply (erule impE [OF _ imp_DC0.lemma4], assumption+)
 apply (erule bexE)
 apply (drule imp_DC0.simplify_recursion, assumption+)
 apply (rule_tac x = "\<lambda>n \<in> nat. f`n`n" in bexI)
 apply (rule_tac [2] lam_type)
 apply (erule_tac [2] apply_type [OF imp_DC0.lemma2 [THEN conjunct1] succI1])
 apply (rule ballI)
 apply (frule_tac n="succ(n)" in imp_DC0.lemma2, 
        (assumption|erule nat_succI)+)
 apply (drule imp_DC0.lemma3, auto)
 done
 
 (* ********************************************************************** *)
 (* \<forall>K. Card(K) \<longrightarrow> DC(K) \<Longrightarrow> WO3                                       *)
 (* ********************************************************************** *)
 
 lemma fun_Ord_inj:
       "\<lbrakk>f \<in> a->X;  Ord(a); 
           \<And>b c. \<lbrakk>b<c; c \<in> a\<rbrakk> \<Longrightarrow> f`b\<noteq>f`c\<rbrakk>    
        \<Longrightarrow> f \<in> inj(a, X)"
 apply (unfold inj_def, simp) 
 apply (intro ballI impI)
 apply (rule_tac j=x in Ord_in_Ord [THEN Ord_linear_lt], assumption+)
 apply (blast intro: Ord_in_Ord, auto) 
 apply (atomize, blast dest: not_sym) 
 done
 
 lemma value_in_image: "\<lbrakk>f \<in> X->Y; A \<subseteq> X; a \<in> A\<rbrakk> \<Longrightarrow> f`a \<in> f``A"
 by (fast elim!: image_fun [THEN ssubst])
 
 lemma lesspoll_lemma: "\<lbrakk>\<not> A \<prec> B; C \<prec> B\<rbrakk> \<Longrightarrow> A - C \<noteq> 0"
   unfolding lesspoll_def
 apply (fast dest!: Diff_eq_0_iff [THEN iffD1, THEN subset_imp_lepoll]
             intro!: eqpollI elim: notE
             elim!: eqpollE lepoll_trans)
 done
 
 theorem DC_WO3: "(\<forall>K. Card(K) \<longrightarrow> DC(K)) \<Longrightarrow> WO3"
-apply (unfold DC_def WO3_def)
+  unfolding DC_def WO3_def
 apply (rule allI)
 apply (case_tac "A \<prec> Hartog (A)")
 apply (fast dest!: lesspoll_imp_ex_lt_eqpoll 
             intro!: Ord_Hartog leI [THEN le_imp_subset])
 apply (erule allE impE)+
 apply (rule Card_Hartog)
 apply (erule_tac x = A in allE)
 apply (erule_tac x = "{\<langle>z1,z2\<rangle> \<in> Pow (A) *A . z1 \<prec> Hartog (A) \<and> z2 \<notin> z1}" 
                  in allE)
 apply simp
 apply (erule impE, fast elim: lesspoll_lemma [THEN not_emptyE])
 apply (erule bexE)
 apply (rule Hartog_lepoll_selfE) 
 apply (rule lepoll_def [THEN def_imp_iff, THEN iffD2])
 apply (rule exI, rule fun_Ord_inj, assumption, rule Ord_Hartog)
 apply (drule value_in_image) 
 apply (drule OrdmemD, rule Ord_Hartog, assumption+, erule ltD) 
 apply (drule ospec)
 apply (blast intro: ltI Ord_Hartog, force) 
 done
 
 (* ********************************************************************** *)
 (* WO1 \<Longrightarrow> \<forall>K. Card(K) \<longrightarrow> DC(K)                                       *)
 (* ********************************************************************** *)
 
 lemma images_eq:
      "\<lbrakk>\<forall>x \<in> A. f`x=g`x; f \<in> Df->Cf; g \<in> Dg->Cg; A \<subseteq> Df; A \<subseteq> Dg\<rbrakk> 
       \<Longrightarrow> f``A = g``A"
 apply (simp (no_asm_simp) add: image_fun)
 done
 
 lemma lam_images_eq:
      "\<lbrakk>Ord(a); b \<in> a\<rbrakk> \<Longrightarrow> (\<lambda>x \<in> a. h(x))``b = (\<lambda>x \<in> b. h(x))``b"
 apply (rule images_eq)
     apply (rule ballI)
     apply (drule OrdmemD [THEN subsetD], assumption+)
     apply simp
    apply (fast elim!: RepFunI OrdmemD intro!: lam_type)+
 done
 
 lemma lam_type_RepFun: "(\<lambda>b \<in> a. h(b)) \<in> a -> {h(b). b \<in> a}"
 by (fast intro!: lam_type RepFunI)
 
 lemma lemmaX:
      "\<lbrakk>\<forall>Y \<in> Pow(X). Y \<prec> K \<longrightarrow> (\<exists>x \<in> X. \<langle>Y, x\<rangle> \<in> R);   
          b \<in> K; Z \<in> Pow(X); Z \<prec> K\<rbrakk>   
       \<Longrightarrow> {x \<in> X. \<langle>Z,x\<rangle> \<in> R} \<noteq> 0"
 by blast
 
 
 lemma WO1_DC_lemma:
      "\<lbrakk>Card(K); well_ord(X,Q);   
          \<forall>Y \<in> Pow(X). Y \<prec> K \<longrightarrow> (\<exists>x \<in> X. \<langle>Y, x\<rangle> \<in> R); b \<in> K\<rbrakk>   
       \<Longrightarrow> ff(b, X, Q, R) \<in> {x \<in> X. <(\<lambda>c \<in> b. ff(c, X, Q, R))``b, x> \<in> R}"
 apply (rule_tac P = "b \<in> K" in impE, (erule_tac [2] asm_rl)+)
 apply (rule_tac i=b in Card_is_Ord [THEN Ord_in_Ord, THEN trans_induct], 
        assumption+)
 apply (rule impI)
 apply (rule ff_def [THEN def_transrec, THEN ssubst])
 apply (erule the_first_in, fast)
 apply (simp add: image_fun [OF lam_type_RepFun subset_refl])
 apply (erule lemmaX, assumption)
  apply (blast intro: Card_is_Ord OrdmemD [THEN subsetD])
 apply (blast intro: lesspoll_trans1 in_Card_imp_lesspoll RepFun_lepoll)
 done
 
 theorem WO1_DC_Card: "WO1 \<Longrightarrow> \<forall>K. Card(K) \<longrightarrow> DC(K)"
-apply (unfold DC_def WO1_def)
+  unfolding DC_def WO1_def
 apply (rule allI impI)+
 apply (erule allE exE conjE)+
 apply (rule_tac x = "\<lambda>b \<in> K. ff (b, X, Ra, R) " in bexI)
  apply (simp add: lam_images_eq [OF Card_is_Ord ltD])
  apply (fast elim!: ltE WO1_DC_lemma [THEN CollectD2])
 apply (rule_tac lam_type)
 apply (rule WO1_DC_lemma [THEN CollectD1], assumption+)
 done
 
 end
diff --git a/src/ZF/AC/HH.thy b/src/ZF/AC/HH.thy
--- a/src/ZF/AC/HH.thy
+++ b/src/ZF/AC/HH.thy
@@ -1,245 +1,245 @@
 (*  Title:      ZF/AC/HH.thy
     Author:     Krzysztof Grabczewski
 
 Some properties of the recursive definition of HH used in the proofs of
   AC17 \<Longrightarrow> AC1
   AC1 \<Longrightarrow> WO2
   AC15 \<Longrightarrow> WO6
 *)
 
 theory HH
 imports AC_Equiv Hartog
 begin
 
 definition
   HH :: "[i, i, i] \<Rightarrow> i"  where
     "HH(f,x,a) \<equiv> transrec(a, \<lambda>b r. let z = x - (\<Union>c \<in> b. r`c)
                                     in  if f`z \<in> Pow(z)-{0} then f`z else {x})"
 
 subsection\<open>Lemmas useful in each of the three proofs\<close>
 
 lemma HH_def_satisfies_eq:
      "HH(f,x,a) = (let z = x - (\<Union>b \<in> a. HH(f,x,b))   
                    in  if f`z \<in> Pow(z)-{0} then f`z else {x})"
 by (rule HH_def [THEN def_transrec, THEN trans], simp)
 
 lemma HH_values: "HH(f,x,a) \<in> Pow(x)-{0} | HH(f,x,a)={x}"
 apply (rule HH_def_satisfies_eq [THEN ssubst])
 apply (simp add: Let_def Diff_subset [THEN PowI], fast)
 done
 
 lemma subset_imp_Diff_eq:
      "B \<subseteq> A \<Longrightarrow> X-(\<Union>a \<in> A. P(a)) = X-(\<Union>a \<in> A-B. P(a))-(\<Union>b \<in> B. P(b))"
 by fast
 
 lemma Ord_DiffE: "\<lbrakk>c \<in> a-b; b<a\<rbrakk> \<Longrightarrow> c=b | b<c \<and> c<a"
 apply (erule ltE)
 apply (drule Ord_linear [of _ c])
 apply (fast elim: Ord_in_Ord)
 apply (fast intro!: ltI intro: Ord_in_Ord)
 done
 
 lemma Diff_UN_eq_self: "(\<And>y. y\<in>A \<Longrightarrow> P(y) = {x}) \<Longrightarrow> x - (\<Union>y \<in> A. P(y)) = x" 
 by (simp, fast elim!: mem_irrefl)
 
 lemma HH_eq: "x - (\<Union>b \<in> a. HH(f,x,b)) = x - (\<Union>b \<in> a1. HH(f,x,b))   
               \<Longrightarrow> HH(f,x,a) = HH(f,x,a1)"
 apply (subst HH_def_satisfies_eq [of _ _ a1]) 
 apply (rule HH_def_satisfies_eq [THEN trans], simp) 
 done
 
 lemma HH_is_x_gt_too: "\<lbrakk>HH(f,x,b)={x}; b<a\<rbrakk> \<Longrightarrow> HH(f,x,a)={x}"
 apply (rule_tac P = "b<a" in impE)
 prefer 2 apply assumption+
 apply (erule lt_Ord2 [THEN trans_induct])
 apply (rule impI)
 apply (rule HH_eq [THEN trans])
 prefer 2 apply assumption+
 apply (rule leI [THEN le_imp_subset, THEN subset_imp_Diff_eq, THEN ssubst], 
        assumption)
 apply (rule_tac t = "\<lambda>z. z-X" for X in subst_context)
 apply (rule Diff_UN_eq_self)
 apply (drule Ord_DiffE, assumption) 
 apply (fast elim: ltE, auto) 
 done
 
 lemma HH_subset_x_lt_too:
      "\<lbrakk>HH(f,x,a) \<in> Pow(x)-{0}; b<a\<rbrakk> \<Longrightarrow> HH(f,x,b) \<in> Pow(x)-{0}"
 apply (rule HH_values [THEN disjE], assumption)
 apply (drule HH_is_x_gt_too, assumption)
 apply (drule subst, assumption)
 apply (fast elim!: mem_irrefl)
 done
 
 lemma HH_subset_x_imp_subset_Diff_UN:
     "HH(f,x,a) \<in> Pow(x)-{0} \<Longrightarrow> HH(f,x,a) \<in> Pow(x - (\<Union>b \<in> a. HH(f,x,b)))-{0}"
 apply (drule HH_def_satisfies_eq [THEN subst])
 apply (rule HH_def_satisfies_eq [THEN ssubst])
 apply (simp add: Let_def Diff_subset [THEN PowI])
 apply (drule split_if [THEN iffD1])
 apply (fast elim!: mem_irrefl)
 done
 
 lemma HH_eq_arg_lt:
      "\<lbrakk>HH(f,x,v)=HH(f,x,w); HH(f,x,v) \<in> Pow(x)-{0}; v \<in> w\<rbrakk> \<Longrightarrow> P"
 apply (frule_tac P = "\<lambda>y. y \<in> Pow (x) -{0}" in subst, assumption)
 apply (drule_tac a = w in HH_subset_x_imp_subset_Diff_UN)
 apply (drule subst_elem, assumption)
 apply (fast intro!: singleton_iff [THEN iffD2] equals0I)
 done
 
 lemma HH_eq_imp_arg_eq:
   "\<lbrakk>HH(f,x,v)=HH(f,x,w); HH(f,x,w) \<in> Pow(x)-{0}; Ord(v); Ord(w)\<rbrakk> \<Longrightarrow> v=w"
 apply (rule_tac j = w in Ord_linear_lt)
 apply (simp_all (no_asm_simp))
  apply (drule subst_elem, assumption) 
  apply (blast dest: ltD HH_eq_arg_lt)
 apply (blast dest: HH_eq_arg_lt [OF sym] ltD) 
 done
 
 lemma HH_subset_x_imp_lepoll: 
      "\<lbrakk>HH(f, x, i) \<in> Pow(x)-{0}; Ord(i)\<rbrakk> \<Longrightarrow> i \<lesssim> Pow(x)-{0}"
-apply (unfold lepoll_def inj_def)
+  unfolding lepoll_def inj_def
 apply (rule_tac x = "\<lambda>j \<in> i. HH (f, x, j) " in exI)
 apply (simp (no_asm_simp))
 apply (fast del: DiffE
             elim!: HH_eq_imp_arg_eq Ord_in_Ord HH_subset_x_lt_too 
             intro!: lam_type ballI ltI intro: bexI)
 done
 
 lemma HH_Hartog_is_x: "HH(f, x, Hartog(Pow(x)-{0})) = {x}"
 apply (rule HH_values [THEN disjE])
 prefer 2 apply assumption 
 apply (fast del: DiffE
             intro!: Ord_Hartog 
             dest!: HH_subset_x_imp_lepoll 
             elim!: Hartog_lepoll_selfE)
 done
 
 lemma HH_Least_eq_x: "HH(f, x, \<mu> i. HH(f, x, i) = {x}) = {x}"
 by (fast intro!: Ord_Hartog HH_Hartog_is_x LeastI)
 
 lemma less_Least_subset_x:
      "a \<in> (\<mu> i. HH(f,x,i)={x}) \<Longrightarrow> HH(f,x,a) \<in> Pow(x)-{0}"
 apply (rule HH_values [THEN disjE], assumption)
 apply (rule less_LeastE)
 apply (erule_tac [2] ltI [OF _ Ord_Least], assumption)
 done
 
 subsection\<open>Lemmas used in the proofs of AC1 \<Longrightarrow> WO2 and AC17 \<Longrightarrow> AC1\<close>
 
 lemma lam_Least_HH_inj_Pow: 
         "(\<lambda>a \<in> (\<mu> i. HH(f,x,i)={x}). HH(f,x,a))   
          \<in> inj(\<mu> i. HH(f,x,i)={x}, Pow(x)-{0})"
 apply (unfold inj_def, simp)
 apply (fast intro!: lam_type dest: less_Least_subset_x 
             elim!: HH_eq_imp_arg_eq Ord_Least [THEN Ord_in_Ord])
 done
 
 lemma lam_Least_HH_inj:
      "\<forall>a \<in> (\<mu> i. HH(f,x,i)={x}). \<exists>z \<in> x. HH(f,x,a) = {z}   
       \<Longrightarrow> (\<lambda>a \<in> (\<mu> i. HH(f,x,i)={x}). HH(f,x,a))   
           \<in> inj(\<mu> i. HH(f,x,i)={x}, {{y}. y \<in> x})"
 by (rule lam_Least_HH_inj_Pow [THEN inj_strengthen_type], simp)
 
 lemma lam_surj_sing: 
         "\<lbrakk>x - (\<Union>a \<in> A. F(a)) = 0;  \<forall>a \<in> A. \<exists>z \<in> x. F(a) = {z}\<rbrakk>   
          \<Longrightarrow> (\<lambda>a \<in> A. F(a)) \<in> surj(A, {{y}. y \<in> x})"
 apply (simp add: surj_def lam_type Diff_eq_0_iff)
 apply (blast elim: equalityE) 
 done
 
 lemma not_emptyI2: "y \<in> Pow(x)-{0} \<Longrightarrow> x \<noteq> 0"
 by auto
 
 lemma f_subset_imp_HH_subset:
      "f`(x - (\<Union>j \<in> i. HH(f,x,j))) \<in> Pow(x - (\<Union>j \<in> i. HH(f,x,j)))-{0}   
       \<Longrightarrow> HH(f, x, i) \<in> Pow(x) - {0}"
 apply (rule HH_def_satisfies_eq [THEN ssubst])
 apply (simp add: Let_def Diff_subset [THEN PowI] not_emptyI2 [THEN if_P], fast)
 done
 
 lemma f_subsets_imp_UN_HH_eq_x:
      "\<forall>z \<in> Pow(x)-{0}. f`z \<in> Pow(z)-{0}
       \<Longrightarrow> x - (\<Union>j \<in> (\<mu> i. HH(f,x,i)={x}). HH(f,x,j)) = 0"
 apply (case_tac "P \<in> {0}" for P, fast)
 apply (drule Diff_subset [THEN PowI, THEN DiffI])
 apply (drule bspec, assumption) 
 apply (drule f_subset_imp_HH_subset) 
 apply (blast dest!: subst_elem [OF _ HH_Least_eq_x [symmetric]] 
              elim!: mem_irrefl)
 done
 
 lemma HH_values2: "HH(f,x,i) = f`(x - (\<Union>j \<in> i. HH(f,x,j))) | HH(f,x,i)={x}"
 apply (rule HH_def_satisfies_eq [THEN ssubst])
 apply (simp add: Let_def Diff_subset [THEN PowI])
 done
 
 lemma HH_subset_imp_eq:
      "HH(f,x,i): Pow(x)-{0} \<Longrightarrow> HH(f,x,i)=f`(x - (\<Union>j \<in> i. HH(f,x,j)))"
 apply (rule HH_values2 [THEN disjE], assumption)
 apply (fast elim!: equalityE mem_irrefl dest!: singleton_subsetD)
 done
 
 lemma f_sing_imp_HH_sing:
      "\<lbrakk>f \<in> (Pow(x)-{0}) -> {{z}. z \<in> x};   
          a \<in> (\<mu> i. HH(f,x,i)={x})\<rbrakk> \<Longrightarrow> \<exists>z \<in> x. HH(f,x,a) = {z}"
 apply (drule less_Least_subset_x)
 apply (frule HH_subset_imp_eq)
 apply (drule apply_type)
 apply (rule Diff_subset [THEN PowI, THEN DiffI])
 apply (fast dest!: HH_subset_x_imp_subset_Diff_UN [THEN not_emptyI2], force) 
 done
 
 lemma f_sing_lam_bij: 
      "\<lbrakk>x - (\<Union>j \<in> (\<mu> i. HH(f,x,i)={x}). HH(f,x,j)) = 0;   
          f \<in> (Pow(x)-{0}) -> {{z}. z \<in> x}\<rbrakk>   
       \<Longrightarrow> (\<lambda>a \<in> (\<mu> i. HH(f,x,i)={x}). HH(f,x,a))   
           \<in> bij(\<mu> i. HH(f,x,i)={x}, {{y}. y \<in> x})"
   unfolding bij_def
 apply (fast intro!: lam_Least_HH_inj lam_surj_sing f_sing_imp_HH_sing)
 done
 
 lemma lam_singI:
      "f \<in> (\<Prod>X \<in> Pow(x)-{0}. F(X))   
       \<Longrightarrow> (\<lambda>X \<in> Pow(x)-{0}. {f`X}) \<in> (\<Prod>X \<in> Pow(x)-{0}. {{z}. z \<in> F(X)})"
 by (fast del: DiffI DiffE
             intro!: lam_type singleton_eq_iff [THEN iffD2] dest: apply_type)
 
 (*FIXME: both uses have the form ...[THEN bij_converse_bij], so 
   simplification is needed!*)
 lemmas bij_Least_HH_x =  
     comp_bij [OF f_sing_lam_bij [OF _ lam_singI] 
               lam_sing_bij [THEN bij_converse_bij]]
 
 
 subsection\<open>The proof of AC1 \<Longrightarrow> WO2\<close>
 
 (*Establishing the existence of a bijection, namely
 converse
  (converse(\<lambda>x\<in>x. {x}) O
   Lambda
    (\<mu> i. HH(\<lambda>X\<in>Pow(x) - {0}. {f ` X}, x, i) = {x},
     HH(\<lambda>X\<in>Pow(x) - {0}. {f ` X}, x)))
 Perhaps it could be simplified. *)
 
 lemma bijection:
      "f \<in> (\<Prod>X \<in> Pow(x) - {0}. X) 
       \<Longrightarrow> \<exists>g. g \<in> bij(x, \<mu> i. HH(\<lambda>X \<in> Pow(x)-{0}. {f`X}, x, i) = {x})"
 apply (rule exI) 
 apply (rule bij_Least_HH_x [THEN bij_converse_bij])
 apply (rule f_subsets_imp_UN_HH_eq_x)
 apply (intro ballI apply_type) 
 apply (fast intro: lam_type apply_type del: DiffE, assumption) 
 apply (fast intro: Pi_weaken_type)
 done
 
 lemma AC1_WO2: "AC1 \<Longrightarrow> WO2"
-apply (unfold AC1_def WO2_def eqpoll_def)
+  unfolding AC1_def WO2_def eqpoll_def
 apply (intro allI) 
 apply (drule_tac x = "Pow(A) - {0}" in spec) 
 apply (blast dest: bijection)
 done
 
 end
 
diff --git a/src/ZF/AC/WO1_AC.thy b/src/ZF/AC/WO1_AC.thy
--- a/src/ZF/AC/WO1_AC.thy
+++ b/src/ZF/AC/WO1_AC.thy
@@ -1,106 +1,106 @@
 (*  Title:      ZF/AC/WO1_AC.thy
     Author:     Krzysztof Grabczewski
 
 The proofs of WO1 \<Longrightarrow> AC1 and WO1 \<Longrightarrow> AC10(n) for n >= 1
 
 The latter proof is referred to as clear by the Rubins.
 However it seems to be quite complicated.
 The formal proof presented below is a mechanisation of the proof 
 by Lawrence C. Paulson which is the following:
 
 Assume WO1.  Let s be a set of infinite sets.
  
 Suppose x \<in> s.  Then x is equipollent to |x| (by WO1), an infinite cardinal
 call it K.  Since K = K \<oplus> K = |K+K| (by InfCard_cdouble_eq) there is an 
 isomorphism h \<in> bij(K+K, x).  (Here + means disjoint sum.)
  
 So there is a partition of x into 2-element sets, namely
  
         {{h(Inl(i)), h(Inr(i))} . i \<in> K}
  
 So for all x \<in> s the desired partition exists.  By AC1 (which follows from WO1) 
 there exists a function f that chooses a partition for each x \<in> s.  Therefore we 
 have AC10(2).
 
 *)
 
 theory WO1_AC
 imports AC_Equiv
 begin
 
 (* ********************************************************************** *)
 (* WO1 \<Longrightarrow> AC1                                                            *)
 (* ********************************************************************** *)
 
 theorem WO1_AC1: "WO1 \<Longrightarrow> AC1"
 by (unfold AC1_def WO1_def, fast elim!: ex_choice_fun)
 
 (* ********************************************************************** *)
 (* WO1 \<Longrightarrow> AC10(n) (n >= 1)                                               *)
 (* ********************************************************************** *)
 
 lemma lemma1: "\<lbrakk>WO1; \<forall>B \<in> A. \<exists>C \<in> D(B). P(C,B)\<rbrakk> \<Longrightarrow> \<exists>f. \<forall>B \<in> A. P(f`B,B)"
   unfolding WO1_def
 apply (erule_tac x = "\<Union>({{C \<in> D (B) . P (C,B) }. B \<in> A}) " in allE)
 apply (erule exE, drule ex_choice_fun, fast)
 apply (erule exE)
 apply (rule_tac x = "\<lambda>x \<in> A. f`{C \<in> D (x) . P (C,x) }" in exI)
 apply (simp, blast dest!: apply_type [OF _ RepFunI])
 done
 
 lemma lemma2_1: "\<lbrakk>\<not>Finite(B); WO1\<rbrakk> \<Longrightarrow> |B| + |B| \<approx>  B"
   unfolding WO1_def
 apply (rule eqpoll_trans)
 prefer 2 apply (fast elim!: well_ord_cardinal_eqpoll)
 apply (rule eqpoll_sym [THEN eqpoll_trans])
 apply (fast elim!: well_ord_cardinal_eqpoll)
 apply (drule spec [of _ B]) 
 apply (clarify dest!: eqpoll_imp_Finite_iff [OF well_ord_cardinal_eqpoll]) 
 apply (simp add: cadd_def [symmetric] 
             eqpoll_refl InfCard_cdouble_eq Card_cardinal Inf_Card_is_InfCard) 
 done
 
 lemma lemma2_2:
      "f \<in> bij(D+D, B) \<Longrightarrow> {{f`Inl(i), f`Inr(i)}. i \<in> D} \<in> Pow(Pow(B))"
 by (fast elim!: bij_is_fun [THEN apply_type])
 
 
 lemma lemma2_3: 
         "f \<in> bij(D+D, B) \<Longrightarrow> pairwise_disjoint({{f`Inl(i), f`Inr(i)}. i \<in> D})"
   unfolding pairwise_disjoint_def
 apply (blast dest: bij_is_inj [THEN inj_apply_equality])
 done
 
 lemma lemma2_4:
      "\<lbrakk>f \<in> bij(D+D, B); 1\<le>n\<rbrakk> 
       \<Longrightarrow> sets_of_size_between({{f`Inl(i), f`Inr(i)}. i \<in> D}, 2, succ(n))"
 apply (simp (no_asm_simp) add: sets_of_size_between_def succ_def)
 apply (blast intro!: cons_lepoll_cong 
             intro: singleton_eqpoll_1 [THEN eqpoll_imp_lepoll]  
                    le_imp_subset [THEN subset_imp_lepoll]  lepoll_trans 
             dest: bij_is_inj [THEN inj_apply_equality] elim!: mem_irrefl)
 done
 
 lemma lemma2_5: 
      "f \<in> bij(D+D, B) \<Longrightarrow> \<Union>({{f`Inl(i), f`Inr(i)}. i \<in> D})=B"
-apply (unfold bij_def surj_def)
+  unfolding bij_def surj_def
 apply (fast elim!: inj_is_fun [THEN apply_type])
 done
 
 lemma lemma2:
      "\<lbrakk>WO1; \<not>Finite(B); 1\<le>n\<rbrakk>   
       \<Longrightarrow> \<exists>C \<in> Pow(Pow(B)). pairwise_disjoint(C) \<and>   
                 sets_of_size_between(C, 2, succ(n)) \<and>   
                 \<Union>(C)=B"
 apply (drule lemma2_1 [THEN eqpoll_def [THEN def_imp_iff, THEN iffD1]], 
        assumption)
 apply (blast intro!: lemma2_2 lemma2_3 lemma2_4 lemma2_5)
 done
 
 theorem WO1_AC10: "\<lbrakk>WO1; 1\<le>n\<rbrakk> \<Longrightarrow> AC10(n)"
   unfolding AC10_def
 apply (fast intro!: lemma1 elim!: lemma2)
 done
 
 end
 
diff --git a/src/ZF/AC/WO1_WO7.thy b/src/ZF/AC/WO1_WO7.thy
--- a/src/ZF/AC/WO1_WO7.thy
+++ b/src/ZF/AC/WO1_WO7.thy
@@ -1,114 +1,114 @@
 (*  Title:      ZF/AC/WO1_WO7.thy
     Author:     Lawrence C Paulson, CU Computer Laboratory
     Copyright   1998  University of Cambridge
 
 WO7 \<longleftrightarrow> LEMMA \<longleftrightarrow> WO1 (Rubin \<and> Rubin p. 5)
 LEMMA is the sentence denoted by (**)
 
 Also, WO1 \<longleftrightarrow> WO8
 *)
 
 theory WO1_WO7
 imports AC_Equiv
 begin
 
 definition
     "LEMMA \<equiv>
      \<forall>X. \<not>Finite(X) \<longrightarrow> (\<exists>R. well_ord(X,R) \<and> \<not>well_ord(X,converse(R)))"
 
 (* ********************************************************************** *)
 (* It is easy to see that WO7 is equivalent to (**)                       *)
 (* ********************************************************************** *)
 
 lemma WO7_iff_LEMMA: "WO7 \<longleftrightarrow> LEMMA"
-apply (unfold WO7_def LEMMA_def)
+  unfolding WO7_def LEMMA_def
 apply (blast intro: Finite_well_ord_converse)
 done
 
 (* ********************************************************************** *)
 (* It is also easy to show that LEMMA implies WO1.                        *)
 (* ********************************************************************** *)
 
 lemma LEMMA_imp_WO1: "LEMMA \<Longrightarrow> WO1"
-apply (unfold WO1_def LEMMA_def Finite_def eqpoll_def)
+  unfolding WO1_def LEMMA_def Finite_def eqpoll_def
 apply (blast intro!: well_ord_rvimage [OF bij_is_inj nat_implies_well_ord])
 done
 
 (* ********************************************************************** *)
 (* The Rubins' proof of the other implication is contained within the     *)
 (* following sentence \<in>                                                   *)
 (* "... each infinite ordinal is well ordered by < but not by >."         *)
 (* This statement can be proved by the following two theorems.            *)
 (* But moreover we need to show similar property for any well ordered     *)
 (* infinite set. It is not very difficult thanks to Isabelle order types  *)
 (* We show that if a set is well ordered by some relation and by its     *)
 (* converse, then apropriate order type is well ordered by the converse   *)
 (* of it's membership relation, which in connection with the previous     *)
 (* gives the conclusion.                                                  *)
 (* ********************************************************************** *)
 
 lemma converse_Memrel_not_wf_on: 
     "\<lbrakk>Ord(a); \<not>Finite(a)\<rbrakk> \<Longrightarrow> \<not>wf[a](converse(Memrel(a)))"
-apply (unfold wf_on_def wf_def)
+  unfolding wf_on_def wf_def
 apply (drule nat_le_infinite_Ord [THEN le_imp_subset], assumption)
 apply (rule notI)
 apply (erule_tac x = nat in allE, blast)
 done
 
 lemma converse_Memrel_not_well_ord: 
     "\<lbrakk>Ord(a); \<not>Finite(a)\<rbrakk> \<Longrightarrow> \<not>well_ord(a,converse(Memrel(a)))"
   unfolding well_ord_def
 apply (blast dest: converse_Memrel_not_wf_on)
 done
 
 lemma well_ord_rvimage_ordertype:
      "well_ord(A,r) \<Longrightarrow>
        rvimage (ordertype(A,r), converse(ordermap(A,r)),r) =
        Memrel(ordertype(A,r))" 
 by (blast intro: ordertype_ord_iso [THEN ord_iso_sym] ord_iso_rvimage_eq
              Memrel_type [THEN subset_Int_iff [THEN iffD1]] trans)
 
 lemma well_ord_converse_Memrel:
      "\<lbrakk>well_ord(A,r); well_ord(A,converse(r))\<rbrakk>   
       \<Longrightarrow> well_ord(ordertype(A,r), converse(Memrel(ordertype(A,r))))" 
 apply (subst well_ord_rvimage_ordertype [symmetric], assumption) 
 apply (rule rvimage_converse [THEN subst])
 apply (blast intro: ordertype_ord_iso ord_iso_sym ord_iso_is_bij
                     bij_is_inj well_ord_rvimage)
 done
 
 lemma WO1_imp_LEMMA: "WO1 \<Longrightarrow> LEMMA"
 apply (unfold WO1_def LEMMA_def, clarify) 
 apply (blast dest: well_ord_converse_Memrel
                    Ord_ordertype [THEN converse_Memrel_not_well_ord]
              intro: ordertype_ord_iso ord_iso_is_bij bij_is_inj lepoll_Finite
                     lepoll_def [THEN def_imp_iff, THEN iffD2] )
 done
 
 lemma WO1_iff_WO7: "WO1 \<longleftrightarrow> WO7"
 apply (simp add: WO7_iff_LEMMA)
 apply (blast intro: LEMMA_imp_WO1 WO1_imp_LEMMA)
 done
 
 
 
 (* ********************************************************************** *)
 (*            The proof of WO8 \<longleftrightarrow> WO1 (Rubin \<and> Rubin p. 6)               *)
 (* ********************************************************************** *)
 
 lemma WO1_WO8: "WO1 \<Longrightarrow> WO8"
 by (unfold WO1_def WO8_def, fast)
 
 
 (* The implication "WO8 \<Longrightarrow> WO1": a faithful image of Rubin \<and> Rubin's proof*)
 lemma WO8_WO1: "WO8 \<Longrightarrow> WO1"
-apply (unfold WO1_def WO8_def)
+  unfolding WO1_def WO8_def
 apply (rule allI)
 apply (erule_tac x = "{{x}. x \<in> A}" in allE)
 apply (erule impE)
  apply (rule_tac x = "\<lambda>a \<in> {{x}. x \<in> A}. THE x. a={x}" in exI)
  apply (force intro!: lam_type simp add: singleton_eq_iff the_equality)
 apply (blast intro: lam_sing_bij bij_is_inj well_ord_rvimage)
 done
 
 end
diff --git a/src/ZF/AC/WO2_AC16.thy b/src/ZF/AC/WO2_AC16.thy
--- a/src/ZF/AC/WO2_AC16.thy
+++ b/src/ZF/AC/WO2_AC16.thy
@@ -1,579 +1,579 @@
 (*  Title:      ZF/AC/WO2_AC16.thy
     Author:     Krzysztof Grabczewski
 
 The proof of WO2 \<Longrightarrow> AC16(k #+ m, k)
   
 The main part of the proof is the inductive reasoning concerning
 properties of constructed family T_gamma.
 The proof deals with three cases for ordinals: 0, succ and limit ordinal.
 The first instance is trivial, the third not difficult, but the second
 is very complicated requiring many lemmas.
 We also need to prove that at any stage gamma the set 
 (s - \<Union>(...) - k_gamma)   (Rubin \<and> Rubin page 15)
 contains m distinct elements (in fact is equipollent to s)
 *)
 
 theory WO2_AC16 imports AC_Equiv AC16_lemmas Cardinal_aux begin
 
 (**** A recursive definition used in the proof of WO2 \<Longrightarrow> AC16 ****)
 
 definition
   recfunAC16 :: "[i,i,i,i] \<Rightarrow> i"  where
     "recfunAC16(f,h,i,a) \<equiv> 
          transrec2(i, 0, 
               \<lambda>g r. if (\<exists>y \<in> r. h`g \<subseteq> y) then r
                     else r \<union> {f`(\<mu> i. h`g \<subseteq> f`i \<and> 
                          (\<forall>b<a. (h`b \<subseteq> f`i \<longrightarrow> (\<forall>t \<in> r. \<not> h`b \<subseteq> t))))})"
 
 (* ********************************************************************** *)
 (* Basic properties of recfunAC16                                         *)
 (* ********************************************************************** *)
 
 lemma recfunAC16_0: "recfunAC16(f,h,0,a) = 0"
 by (simp add: recfunAC16_def)
 
 lemma recfunAC16_succ: 
      "recfunAC16(f,h,succ(i),a) =   
       (if (\<exists>y \<in> recfunAC16(f,h,i,a). h ` i \<subseteq> y) then recfunAC16(f,h,i,a)  
        else recfunAC16(f,h,i,a) \<union>  
             {f ` (\<mu> j. h ` i \<subseteq> f ` j \<and>   
              (\<forall>b<a. (h`b \<subseteq> f`j   
               \<longrightarrow> (\<forall>t \<in> recfunAC16(f,h,i,a). \<not> h`b \<subseteq> t))))})"
 apply (simp add: recfunAC16_def)
 done
 
 lemma recfunAC16_Limit: "Limit(i)   
         \<Longrightarrow> recfunAC16(f,h,i,a) = (\<Union>j<i. recfunAC16(f,h,j,a))"
 by (simp add: recfunAC16_def transrec2_Limit)
 
 (* ********************************************************************** *)
 (* Monotonicity of transrec2                                              *)
 (* ********************************************************************** *)
 
 lemma transrec2_mono_lemma [rule_format]:
      "\<lbrakk>\<And>g r. r \<subseteq> B(g,r);  Ord(i)\<rbrakk>   
       \<Longrightarrow> j<i \<longrightarrow> transrec2(j, 0, B) \<subseteq> transrec2(i, 0, B)"
 apply (erule trans_induct)
 apply (rule Ord_cases, assumption+, fast)
 apply (simp (no_asm_simp))
 apply (blast elim!: leE) 
 apply (simp add: transrec2_Limit) 
 apply (blast intro: OUN_I ltI Ord_in_Ord [THEN le_refl]
              elim!: Limit_has_succ [THEN ltE])
 done
 
 lemma transrec2_mono:
      "\<lbrakk>\<And>g r. r \<subseteq> B(g,r); j\<le>i\<rbrakk> 
       \<Longrightarrow> transrec2(j, 0, B) \<subseteq> transrec2(i, 0, B)"
 apply (erule leE)
 apply (rule transrec2_mono_lemma)
 apply (auto intro: lt_Ord2 ) 
 done
 
 (* ********************************************************************** *)
 (* Monotonicity of recfunAC16                                             *)
 (* ********************************************************************** *)
 
 lemma recfunAC16_mono: 
        "i\<le>j \<Longrightarrow> recfunAC16(f, g, i, a) \<subseteq> recfunAC16(f, g, j, a)"
   unfolding recfunAC16_def
 apply (rule transrec2_mono, auto) 
 done
 
 (* ********************************************************************** *)
 (* case of limit ordinal                                                  *)
 (* ********************************************************************** *)
 
 
 lemma lemma3_1:
     "\<lbrakk>\<forall>y<x. \<forall>z<a. z<y | (\<exists>Y \<in> F(y). f(z)<=Y) \<longrightarrow> (\<exists>! Y. Y \<in> F(y) \<and> f(z)<=Y);
         \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j); j\<le>i; i<x; z<a;
         V \<in> F(i); f(z)<=V; W \<in> F(j); f(z)<=W\<rbrakk>   
      \<Longrightarrow> V = W"
 apply (erule asm_rl allE impE)+
 apply (drule subsetD, assumption, blast) 
 done
 
 
 lemma lemma3:
     "\<lbrakk>\<forall>y<x. \<forall>z<a. z<y | (\<exists>Y \<in> F(y). f(z)<=Y) \<longrightarrow> (\<exists>! Y. Y \<in> F(y) \<and> f(z)<=Y);
         \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j); i<x; j<x; z<a;   
         V \<in> F(i); f(z)<=V; W \<in> F(j); f(z)<=W\<rbrakk>   
      \<Longrightarrow> V = W"
 apply (rule_tac j=j in Ord_linear_le [OF lt_Ord lt_Ord], assumption+)
 apply (erule lemma3_1 [symmetric], assumption+)
 apply (erule lemma3_1, assumption+)
 done
 
 lemma lemma4:
      "\<lbrakk>\<forall>y<x. F(y) \<subseteq> X \<and>   
                 (\<forall>x<a. x < y | (\<exists>Y \<in> F(y). h(x) \<subseteq> Y) \<longrightarrow>   
                  (\<exists>! Y. Y \<in> F(y) \<and> h(x) \<subseteq> Y)); 
          x < a\<rbrakk>   
       \<Longrightarrow> \<forall>y<x. \<forall>z<a. z < y | (\<exists>Y \<in> F(y). h(z) \<subseteq> Y) \<longrightarrow>   
                        (\<exists>! Y. Y \<in> F(y) \<and> h(z) \<subseteq> Y)"
 apply (intro oallI impI)
 apply (drule ospec, assumption, clarify)
 apply (blast elim!: oallE ) 
 done
 
 lemma lemma5:
      "\<lbrakk>\<forall>y<x. F(y) \<subseteq> X \<and>   
                (\<forall>x<a. x < y | (\<exists>Y \<in> F(y). h(x) \<subseteq> Y) \<longrightarrow>   
                 (\<exists>! Y. Y \<in> F(y) \<and> h(x) \<subseteq> Y));  
          x < a; Limit(x); \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j)\<rbrakk>   
       \<Longrightarrow> (\<Union>x<x. F(x)) \<subseteq> X \<and>   
           (\<forall>xa<a. xa < x | (\<exists>x \<in> \<Union>x<x. F(x). h(xa) \<subseteq> x)   
                 \<longrightarrow> (\<exists>! Y. Y \<in> (\<Union>x<x. F(x)) \<and> h(xa) \<subseteq> Y))"
 apply (rule conjI)
 apply (rule subsetI)
 apply (erule OUN_E)
 apply (drule ospec, assumption, fast)
 apply (drule lemma4, assumption)
 apply (rule oallI)
 apply (rule impI)
 apply (erule disjE)
 apply (frule ospec, erule Limit_has_succ, assumption) 
 apply (drule_tac A = a and x = xa in ospec, assumption)
 apply (erule impE, rule le_refl [THEN disjI1], erule lt_Ord) 
 apply (blast intro: lemma3 Limit_has_succ) 
 apply (blast intro: lemma3) 
 done
 
 (* ********************************************************************** *)
 (* case of successor ordinal                                              *)
 (* ********************************************************************** *)
 
 (*
   First quite complicated proof of the fact used in the recursive construction
   of the family T_gamma (WO2 \<Longrightarrow> AC16(k #+ m, k)) - the fact that at any stage
   gamma the set (s - \<Union>(...) - k_gamma) is equipollent to s
   (Rubin \<and> Rubin page 15).
 *)
 
 (* ********************************************************************** *)
 (* dbl_Diff_eqpoll_Card                                                   *)
 (* ********************************************************************** *)
 
 
 lemma dbl_Diff_eqpoll_Card:
       "\<lbrakk>A\<approx>a; Card(a); \<not>Finite(a); B\<prec>a; C\<prec>a\<rbrakk> \<Longrightarrow> A - B - C\<approx>a"
 by (blast intro: Diff_lesspoll_eqpoll_Card) 
 
 (* ********************************************************************** *)
 (* Case of finite ordinals                                                *)
 (* ********************************************************************** *)
 
 
 lemma Finite_lesspoll_infinite_Ord: 
       "\<lbrakk>Finite(X); \<not>Finite(a); Ord(a)\<rbrakk> \<Longrightarrow> X\<prec>a"
   unfolding lesspoll_def
 apply (rule conjI)
 apply (drule nat_le_infinite_Ord [THEN le_imp_lepoll], assumption)
   unfolding Finite_def
 apply (blast intro: leI [THEN le_imp_subset, THEN subset_imp_lepoll]
                     ltI eqpoll_imp_lepoll lepoll_trans) 
 apply (blast intro: eqpoll_sym [THEN eqpoll_trans])
 done
 
 lemma Union_lesspoll:
      "\<lbrakk>\<forall>x \<in> X. x \<lesssim> n \<and> x \<subseteq> T; well_ord(T, R); X \<lesssim> b;   
          b<a; \<not>Finite(a); Card(a); n \<in> nat\<rbrakk>   
       \<Longrightarrow> \<Union>(X)\<prec>a"
 apply (case_tac "Finite (X)")
 apply (blast intro: Card_is_Ord Finite_lesspoll_infinite_Ord 
                     lepoll_nat_imp_Finite Finite_Union)
 apply (drule lepoll_imp_ex_le_eqpoll) 
 apply (erule lt_Ord) 
 apply (elim exE conjE)
 apply (frule eqpoll_imp_lepoll [THEN lepoll_infinite], assumption)
 apply (erule eqpoll_sym [THEN eqpoll_def [THEN def_imp_iff, THEN iffD1],
                          THEN exE])
 apply (frule bij_is_surj [THEN surj_image_eq])
 apply (drule image_fun [OF bij_is_fun subset_refl])
 apply (drule sym [THEN trans], assumption)
 apply (blast intro: lt_Ord UN_lepoll lt_Card_imp_lesspoll
                     lt_trans1 lesspoll_trans1)
 done
 
 (* ********************************************************************** *)
 (* recfunAC16_lepoll_index                                                *)
 (* ********************************************************************** *)
 
 lemma Un_sing_eq_cons: "A \<union> {a} = cons(a, A)"
 by fast
 
 lemma Un_lepoll_succ: "A \<lesssim> B \<Longrightarrow> A \<union> {a} \<lesssim> succ(B)"
 apply (simp add: Un_sing_eq_cons succ_def)
 apply (blast elim!: mem_irrefl intro: cons_lepoll_cong)
 done
 
 lemma Diff_UN_succ_empty: "Ord(a) \<Longrightarrow> F(a) - (\<Union>b<succ(a). F(b)) = 0"
 by (fast intro!: le_refl)
 
 lemma Diff_UN_succ_subset: "Ord(a) \<Longrightarrow> F(a) \<union> X - (\<Union>b<succ(a). F(b)) \<subseteq> X"
 by blast
 
 lemma recfunAC16_Diff_lepoll_1:
      "Ord(x) 
       \<Longrightarrow> recfunAC16(f, g, x, a) - (\<Union>i<x. recfunAC16(f, g, i, a)) \<lesssim> 1"
 apply (erule Ord_cases)
   apply (simp add: recfunAC16_0 empty_subsetI [THEN subset_imp_lepoll])
 (*Limit case*)
 prefer 2 apply (simp add: recfunAC16_Limit Diff_cancel 
                           empty_subsetI [THEN subset_imp_lepoll])
 (*succ case*)
 apply (simp add: recfunAC16_succ
                  Diff_UN_succ_empty [of _ "\<lambda>j. recfunAC16(f,g,j,a)"]
                  empty_subsetI [THEN subset_imp_lepoll])
 apply (best intro: Diff_UN_succ_subset [THEN subset_imp_lepoll]
                    singleton_eqpoll_1 [THEN eqpoll_imp_lepoll] lepoll_trans)
 done
 
 lemma in_Least_Diff:
      "\<lbrakk>z \<in> F(x); Ord(x)\<rbrakk>   
       \<Longrightarrow> z \<in> F(\<mu> i. z \<in> F(i)) - (\<Union>j<(\<mu> i. z \<in> F(i)). F(j))"
 by (fast elim: less_LeastE elim!: LeastI)
 
 lemma Least_eq_imp_ex:
      "\<lbrakk>(\<mu> i. w \<in> F(i)) = (\<mu> i. z \<in> F(i));   
          w \<in> (\<Union>i<a. F(i)); z \<in> (\<Union>i<a. F(i))\<rbrakk>   
       \<Longrightarrow> \<exists>b<a. w \<in> (F(b) - (\<Union>c<b. F(c))) \<and> z \<in> (F(b) - (\<Union>c<b. F(c)))"
 apply (elim OUN_E)
 apply (drule in_Least_Diff, erule lt_Ord) 
 apply (frule in_Least_Diff, erule lt_Ord) 
 apply (rule oexI, force) 
 apply (blast intro: lt_Ord Least_le [THEN lt_trans1]) 
 done
 
 
 lemma two_in_lepoll_1: "\<lbrakk>A \<lesssim> 1; a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a=b"
 by (fast dest!: lepoll_1_is_sing)
 
 
 lemma UN_lepoll_index:
      "\<lbrakk>\<forall>i<a. F(i)-(\<Union>j<i. F(j)) \<lesssim> 1; Limit(a)\<rbrakk>   
       \<Longrightarrow> (\<Union>x<a. F(x)) \<lesssim> a"
 apply (rule lepoll_def [THEN def_imp_iff [THEN iffD2]])
 apply (rule_tac x = "\<lambda>z \<in> (\<Union>x<a. F (x)). \<mu> i. z \<in> F (i) " in exI)
   unfolding inj_def
 apply (rule CollectI)
 apply (rule lam_type)
 apply (erule OUN_E)
 apply (erule Least_in_Ord)
 apply (erule ltD)
 apply (erule lt_Ord2)
 apply (intro ballI)
 apply (simp (no_asm_simp))
 apply (rule impI)
 apply (drule Least_eq_imp_ex, assumption+)
 apply (fast elim!: two_in_lepoll_1)
 done
 
 
 lemma recfunAC16_lepoll_index: "Ord(y) \<Longrightarrow> recfunAC16(f, h, y, a) \<lesssim> y"
 apply (erule trans_induct3)
 (*0 case*)
 apply (simp (no_asm_simp) add: recfunAC16_0 lepoll_refl)
 (*succ case*)
 apply (simp (no_asm_simp) add: recfunAC16_succ)
 apply (blast dest!: succI1 [THEN rev_bspec] 
              intro: subset_succI [THEN subset_imp_lepoll] Un_lepoll_succ  
                     lepoll_trans)
 apply (simp (no_asm_simp) add: recfunAC16_Limit)
 apply (blast intro: lt_Ord [THEN recfunAC16_Diff_lepoll_1] UN_lepoll_index)
 done
 
 
 lemma Union_recfunAC16_lesspoll:
      "\<lbrakk>recfunAC16(f,g,y,a) \<subseteq> {X \<in> Pow(A). X\<approx>n};   
          A\<approx>a;  y<a;  \<not>Finite(a);  Card(a);  n \<in> nat\<rbrakk>   
       \<Longrightarrow> \<Union>(recfunAC16(f,g,y,a))\<prec>a"
 apply (erule eqpoll_def [THEN def_imp_iff, THEN iffD1, THEN exE])
 apply (rule_tac T=A in Union_lesspoll, simp_all)
 apply (blast intro!: eqpoll_imp_lepoll)
 apply (blast intro: bij_is_inj Card_is_Ord [THEN well_ord_Memrel]
                     well_ord_rvimage)
 apply (erule lt_Ord [THEN recfunAC16_lepoll_index])
 done
 
 lemma dbl_Diff_eqpoll:
      "\<lbrakk>recfunAC16(f, h, y, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)};   
          Card(a); \<not> Finite(a); A\<approx>a;   
          k \<in> nat;  y<a;   
          h \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k)})\<rbrakk>   
       \<Longrightarrow> A - \<Union>(recfunAC16(f, h, y, a)) - h`y\<approx>a"
 apply (rule dbl_Diff_eqpoll_Card, simp_all)
 apply (simp add: Union_recfunAC16_lesspoll)
 apply (rule Finite_lesspoll_infinite_Ord) 
 apply (rule Finite_def [THEN def_imp_iff, THEN iffD2]) 
 apply (blast dest: ltD bij_is_fun [THEN apply_type], assumption)  
 apply (blast intro: Card_is_Ord) 
 done
 
 (* back to the proof *)
 
 lemmas disj_Un_eqpoll_nat_sum = 
     eqpoll_trans [THEN eqpoll_trans, 
                   OF disj_Un_eqpoll_sum sum_eqpoll_cong nat_sum_eqpoll_sum]
 
 
 lemma Un_in_Collect: "\<lbrakk>x \<in> Pow(A - B - h`i); x\<approx>m;   
         h \<in> bij(a, {x \<in> Pow(A) . x\<approx>k}); i<a; k \<in> nat; m \<in> nat\<rbrakk>   
         \<Longrightarrow> h ` i \<union> x \<in> {x \<in> Pow(A) . x\<approx>k #+ m}"
 by (blast intro: disj_Un_eqpoll_nat_sum
           dest:  ltD bij_is_fun [THEN apply_type])
 
 
 (* ********************************************************************** *)
 (* Lemmas simplifying assumptions                                         *)
 (* ********************************************************************** *)
 
 lemma lemma6:
      "\<lbrakk>\<forall>y<succ(j). F(y)<=X \<and> (\<forall>x<a. x<y | P(x,y) \<longrightarrow> Q(x,y)); succ(j)<a\<rbrakk>
       \<Longrightarrow> F(j)<=X \<and> (\<forall>x<a. x<j | P(x,j) \<longrightarrow> Q(x,j))"
 by (blast intro!: lt_Ord succI1 [THEN ltI, THEN lt_Ord, THEN le_refl]) 
 
 
 lemma lemma7:
      "\<lbrakk>\<forall>x<a. x<j | P(x,j) \<longrightarrow> Q(x,j);  succ(j)<a\<rbrakk>   
       \<Longrightarrow> P(j,j) \<longrightarrow> (\<forall>x<a. x\<le>j | P(x,j) \<longrightarrow> Q(x,j))"
 by (fast elim!: leE)
 
 (* ********************************************************************** *)
 (* Lemmas needed to prove ex_next_set, which means that for any successor *)
 (* ordinal there is a set satisfying certain properties                   *)
 (* ********************************************************************** *)
 
 lemma ex_subset_eqpoll:
      "\<lbrakk>A\<approx>a; \<not> Finite(a); Ord(a); m \<in> nat\<rbrakk> \<Longrightarrow> \<exists>X \<in> Pow(A). X\<approx>m"
 apply (rule lepoll_imp_eqpoll_subset [of m A, THEN exE]) 
  apply (rule lepoll_trans, rule leI [THEN le_imp_lepoll])
   apply (blast intro: lt_trans2 [OF ltI nat_le_infinite_Ord] Ord_nat)
 apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll]) 
 apply (fast elim!: eqpoll_sym)
 done
 
 lemma subset_Un_disjoint: "\<lbrakk>A \<subseteq> B \<union> C; A \<inter> C = 0\<rbrakk> \<Longrightarrow> A \<subseteq> B"
 by blast
 
 
 lemma Int_empty:
      "\<lbrakk>X \<in> Pow(A - \<Union>(B) -C); T \<in> B; F \<subseteq> T\<rbrakk> \<Longrightarrow> F \<inter> X = 0"
 by blast
 
 
 (* ********************************************************************** *)
 (* equipollent subset (and finite) is the whole set                       *)
 (* ********************************************************************** *)
 
 
 lemma subset_imp_eq_lemma:
      "m \<in> nat \<Longrightarrow> \<forall>A B. A \<subseteq> B \<and> m \<lesssim> A \<and> B \<lesssim> m \<longrightarrow> A=B"
 apply (induct_tac "m")
 apply (fast dest!: lepoll_0_is_0)
 apply (intro allI impI)
 apply (elim conjE)
 apply (rule succ_lepoll_imp_not_empty [THEN not_emptyE], assumption)
 apply (frule subsetD [THEN Diff_sing_lepoll], assumption+)
 apply (frule lepoll_Diff_sing)
 apply (erule allE impE)+
 apply (rule conjI)
 prefer 2 apply fast
 apply fast
 apply (blast elim: equalityE) 
 done
 
 
 lemma subset_imp_eq: "\<lbrakk>A \<subseteq> B; m \<lesssim> A; B \<lesssim> m; m \<in> nat\<rbrakk> \<Longrightarrow> A=B"
 by (blast dest!: subset_imp_eq_lemma)
 
 
 lemma bij_imp_arg_eq:
      "\<lbrakk>f \<in> bij(a, {Y \<in> X. Y\<approx>succ(k)}); k \<in> nat; f`b \<subseteq> f`y; b<a; y<a\<rbrakk> 
       \<Longrightarrow> b=y"
 apply (drule subset_imp_eq)
 apply (erule_tac [3] nat_succI)
-apply (unfold bij_def inj_def)
+  unfolding bij_def inj_def
 apply (blast intro: eqpoll_sym eqpoll_imp_lepoll
              dest:  ltD apply_type)+
 done
 
 
 lemma ex_next_set:
      "\<lbrakk>recfunAC16(f, h, y, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)};   
          Card(a); \<not> Finite(a); A\<approx>a;   
          k \<in> nat; m \<in> nat; y<a;   
          h \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k)});   
          \<not> (\<exists>Y \<in> recfunAC16(f, h, y, a). h`y \<subseteq> Y)\<rbrakk>   
       \<Longrightarrow> \<exists>X \<in> {Y \<in> Pow(A). Y\<approx>succ(k #+ m)}. h`y \<subseteq> X \<and>   
                 (\<forall>b<a. h`b \<subseteq> X \<longrightarrow>   
                 (\<forall>T \<in> recfunAC16(f, h, y, a). \<not> h`b \<subseteq> T))"
 apply (erule_tac m1=m in dbl_Diff_eqpoll [THEN ex_subset_eqpoll, THEN bexE], 
        assumption+)
 apply (erule Card_is_Ord, assumption)
 apply (frule Un_in_Collect, (erule asm_rl nat_succI)+) 
 apply (erule CollectE)
 apply (rule rev_bexI, simp)
 apply (rule conjI, blast) 
 apply (intro ballI impI oallI notI)
 apply (drule subset_Un_disjoint, rule Int_empty, assumption+)
 apply (blast dest: bij_imp_arg_eq) 
 done
 
 (* ********************************************************************** *)
 (* Lemma ex_next_Ord states that for any successor                        *)
 (* ordinal there is a number of the set satisfying certain properties     *)
 (* ********************************************************************** *)
 
 lemma ex_next_Ord:
      "\<lbrakk>recfunAC16(f, h, y, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)};   
          Card(a); \<not> Finite(a); A\<approx>a;   
          k \<in> nat; m \<in> nat; y<a;   
          h \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k)});   
          f \<in> bij(a, {Y \<in> Pow(A). Y\<approx>succ(k #+ m)});   
          \<not> (\<exists>Y \<in> recfunAC16(f, h, y, a). h`y \<subseteq> Y)\<rbrakk>   
       \<Longrightarrow> \<exists>c<a. h`y \<subseteq> f`c \<and>   
                 (\<forall>b<a. h`b \<subseteq> f`c \<longrightarrow>   
                 (\<forall>T \<in> recfunAC16(f, h, y, a). \<not> h`b \<subseteq> T))"
 apply (drule ex_next_set, assumption+)
 apply (erule bexE)
 apply (rule_tac x="converse(f)`X" in oexI)
 apply (simp add: right_inverse_bij)
 apply (blast intro: bij_converse_bij bij_is_fun [THEN apply_type] ltI
                     Card_is_Ord)
 done
 
 
 (* ********************************************************************** *)
 (* Lemma simplifying assumptions                                          *)
 (* ********************************************************************** *)
 
 lemma lemma8:
      "\<lbrakk>\<forall>x<a. x<j | (\<exists>xa \<in> F(j). P(x, xa))   
          \<longrightarrow> (\<exists>! Y. Y \<in> F(j) \<and> P(x, Y)); F(j) \<subseteq> X;   
          L \<in> X; P(j, L) \<and> (\<forall>x<a. P(x, L) \<longrightarrow> (\<forall>xa \<in> F(j). \<not>P(x, xa)))\<rbrakk>   
       \<Longrightarrow> F(j) \<union> {L} \<subseteq> X \<and>   
           (\<forall>x<a. x\<le>j | (\<exists>xa \<in> (F(j) \<union> {L}). P(x, xa)) \<longrightarrow>   
                  (\<exists>! Y. Y \<in> (F(j) \<union> {L}) \<and> P(x, Y)))"
 apply (rule conjI)
 apply (fast intro!: singleton_subsetI)
 apply (rule oallI)
 apply (blast elim!: leE oallE)
 done
 
 (* ********************************************************************** *)
 (* The main part of the proof: inductive proof of the property of T_gamma *)
 (* lemma main_induct                                                      *)
 (* ********************************************************************** *)
 
 lemma main_induct:
      "\<lbrakk>b < a; f \<in> bij(a, {Y \<in> Pow(A) . Y\<approx>succ(k #+ m)});   
          h \<in> bij(a, {Y \<in> Pow(A) . Y\<approx>succ(k)});   
          \<not>Finite(a); Card(a); A\<approx>a; k \<in> nat; m \<in> nat\<rbrakk>   
       \<Longrightarrow> recfunAC16(f, h, b, a) \<subseteq> {X \<in> Pow(A) . X\<approx>succ(k #+ m)} \<and>   
           (\<forall>x<a. x < b | (\<exists>Y \<in> recfunAC16(f, h, b, a). h ` x \<subseteq> Y) \<longrightarrow>   
           (\<exists>! Y. Y \<in> recfunAC16(f, h, b, a) \<and> h ` x \<subseteq> Y))"
 apply (erule lt_induct)
 apply (frule lt_Ord)
 apply (erule Ord_cases)
 (* case 0 *)
 apply (simp add: recfunAC16_0)
 (* case Limit *)
 prefer 2  apply (simp add: recfunAC16_Limit)
           apply (rule lemma5, assumption+)
           apply (blast dest!: recfunAC16_mono)
 (* case succ *)
 apply clarify 
 apply (erule lemma6 [THEN conjE], assumption)
 apply (simp (no_asm_simp) split del: split_if add: recfunAC16_succ)
 apply (rule conjI [THEN split_if [THEN iffD2]])
  apply (simp, erule lemma7, assumption)
 apply (rule impI)
 apply (rule ex_next_Ord [THEN oexE], 
        assumption+, rule le_refl [THEN lt_trans], assumption+) 
 apply (erule lemma8, assumption)
  apply (rule bij_is_fun [THEN apply_type], assumption)
  apply (erule Least_le [THEN lt_trans2, THEN ltD])
   apply (erule lt_Ord) 
  apply (erule succ_leI)
 apply (erule LeastI) 
 apply (erule lt_Ord) 
 done
 
 (* ********************************************************************** *)
 (* Lemma to simplify the inductive proof                                  *)
 (*   - the desired property is a consequence of the inductive assumption  *)
 (* ********************************************************************** *)
 
 lemma lemma_simp_induct:
      "\<lbrakk>\<forall>b. b<a \<longrightarrow> F(b) \<subseteq> S \<and> (\<forall>x<a. (x<b | (\<exists>Y \<in> F(b). f`x \<subseteq> Y))  
                                    \<longrightarrow> (\<exists>! Y. Y \<in> F(b) \<and> f`x \<subseteq> Y));
          f \<in> a->f``(a); Limit(a); 
          \<forall>i j. i\<le>j \<longrightarrow> F(i) \<subseteq> F(j)\<rbrakk>   
         \<Longrightarrow> (\<Union>j<a. F(j)) \<subseteq> S \<and>   
             (\<forall>x \<in> f``a. \<exists>! Y. Y \<in> (\<Union>j<a. F(j)) \<and> x \<subseteq> Y)"
 apply (rule conjI)
 apply (rule subsetI)
 apply (erule OUN_E, blast) 
 apply (rule ballI)
 apply (erule imageE)
 apply (drule ltI, erule Limit_is_Ord) 
 apply (drule Limit_has_succ, assumption) 
 apply (frule_tac x1="succ(xa)" in spec [THEN mp], assumption)
 apply (erule conjE)
 apply (drule ospec) 
 (** LEVEL 10 **)
 apply (erule leI [THEN succ_leE])
 apply (erule impE)
 apply (fast elim!: leI [THEN succ_leE, THEN lt_Ord, THEN le_refl])
 apply (drule apply_equality, assumption) 
 apply (elim conjE ex1E)
 (** LEVEL 15 **)
 apply (rule ex1I, blast) 
 apply (elim conjE OUN_E)
 apply (erule_tac i="succ(xa)" and j=aa 
        in Ord_linear_le [OF lt_Ord lt_Ord], assumption)
 prefer 2 
 apply (drule spec [THEN spec, THEN mp, THEN subsetD], assumption+, blast) 
 (** LEVEL 20 **)
 apply (drule_tac x1=aa in spec [THEN mp], assumption)
 apply (frule succ_leE)
 apply (drule spec [THEN spec, THEN mp, THEN subsetD], assumption+, blast) 
 done
 
 (* ********************************************************************** *)
 (* The target theorem                                                     *)
 (* ********************************************************************** *)
 
 theorem WO2_AC16: "\<lbrakk>WO2; 0<m; k \<in> nat; m \<in> nat\<rbrakk> \<Longrightarrow> AC16(k #+ m,k)"
   unfolding AC16_def
 apply (rule allI)
 apply (rule impI)
 apply (frule WO2_infinite_subsets_eqpoll_X, assumption+)
 apply (frule_tac n="k #+ m" in WO2_infinite_subsets_eqpoll_X, simp, simp) 
 apply (frule WO2_imp_ex_Card)
 apply (elim exE conjE)
 apply (drule eqpoll_trans [THEN eqpoll_sym, 
                            THEN eqpoll_def [THEN def_imp_iff, THEN iffD1]],
        assumption)
 apply (drule eqpoll_trans [THEN eqpoll_sym, 
                            THEN eqpoll_def [THEN def_imp_iff, THEN iffD1]], 
        assumption+)
 apply (elim exE)
 apply (rename_tac h)
 apply (rule_tac x = "\<Union>j<a. recfunAC16 (h,f,j,a) " in exI)
 apply (rule_tac P="\<lambda>z. Y \<and> (\<forall>x \<in> z. Z(x))"  for Y Z
        in bij_is_surj [THEN surj_image_eq, THEN subst], assumption)
 apply (rule lemma_simp_induct)
 apply (blast del: conjI notI
              intro!: main_induct eqpoll_imp_lepoll [THEN lepoll_infinite] ) 
 apply (blast intro: bij_is_fun [THEN surj_image, THEN surj_is_fun])
 apply (erule eqpoll_imp_lepoll [THEN lepoll_infinite, 
                                 THEN infinite_Card_is_InfCard, 
                                 THEN InfCard_is_Limit], 
        assumption+)
 apply (blast dest!: recfunAC16_mono)
 done
 
 end
diff --git a/src/ZF/AC/WO6_WO1.thy b/src/ZF/AC/WO6_WO1.thy
--- a/src/ZF/AC/WO6_WO1.thy
+++ b/src/ZF/AC/WO6_WO1.thy
@@ -1,539 +1,539 @@
 (*  Title:      ZF/AC/WO6_WO1.thy
     Author:     Krzysztof Grabczewski
 
 Proofs needed to state that formulations WO1,...,WO6 are all equivalent.
 The only hard one is WO6 \<Longrightarrow> WO1.
 
 Every proof (except WO6 \<Longrightarrow> WO1 and WO1 \<Longrightarrow> WO2) are described as "clear"
 by Rubin \<and> Rubin (page 2). 
 They refer reader to a book by Gödel to see the proof WO1 \<Longrightarrow> WO2.
 Fortunately order types made this proof also very easy.
 *)
 
 theory WO6_WO1
 imports Cardinal_aux
 begin
 
 (* Auxiliary definitions used in proof *)
 definition
   NN  :: "i \<Rightarrow> i"  where
     "NN(y) \<equiv> {m \<in> nat. \<exists>a. \<exists>f. Ord(a) \<and> domain(f)=a  \<and>  
                         (\<Union>b<a. f`b) = y \<and> (\<forall>b<a. f`b \<lesssim> m)}"
   
 definition
   uu  :: "[i, i, i, i] \<Rightarrow> i"  where
     "uu(f, beta, gamma, delta) \<equiv> (f`beta * f`gamma) \<inter> f`delta"
 
 
 (** Definitions for case 1 **)
 definition
   vv1 :: "[i, i, i] \<Rightarrow> i"  where
      "vv1(f,m,b) \<equiv>                                                
            let g = \<mu> g. (\<exists>d. Ord(d) \<and> (domain(uu(f,b,g,d)) \<noteq> 0 \<and> 
                                  domain(uu(f,b,g,d)) \<lesssim> m));      
                d = \<mu> d. domain(uu(f,b,g,d)) \<noteq> 0 \<and>                  
                             domain(uu(f,b,g,d)) \<lesssim> m         
            in  if f`b \<noteq> 0 then domain(uu(f,b,g,d)) else 0"
 
 definition
   ww1 :: "[i, i, i] \<Rightarrow> i"  where
      "ww1(f,m,b) \<equiv> f`b - vv1(f,m,b)"
 
 definition
   gg1 :: "[i, i, i] \<Rightarrow> i"  where
      "gg1(f,a,m) \<equiv> \<lambda>b \<in> a++a. if b<a then vv1(f,m,b) else ww1(f,m,b--a)"
 
 
 (** Definitions for case 2 **)
 definition
   vv2 :: "[i, i, i, i] \<Rightarrow> i"  where
      "vv2(f,b,g,s) \<equiv>   
            if f`g \<noteq> 0 then {uu(f, b, g, \<mu> d. uu(f,b,g,d) \<noteq> 0)`s} else 0"
 
 definition
   ww2 :: "[i, i, i, i] \<Rightarrow> i"  where
      "ww2(f,b,g,s) \<equiv> f`g - vv2(f,b,g,s)"
 
 definition
   gg2 :: "[i, i, i, i] \<Rightarrow> i"  where
      "gg2(f,a,b,s) \<equiv>
               \<lambda>g \<in> a++a. if g<a then vv2(f,b,g,s) else ww2(f,b,g--a,s)"
 
 
 lemma WO2_WO3: "WO2 \<Longrightarrow> WO3"
 by (unfold WO2_def WO3_def, fast)
 
 (* ********************************************************************** *)
 
 lemma WO3_WO1: "WO3 \<Longrightarrow> WO1"
-apply (unfold eqpoll_def WO1_def WO3_def)
+  unfolding eqpoll_def WO1_def WO3_def
 apply (intro allI)
 apply (drule_tac x=A in spec) 
 apply (blast intro: bij_is_inj well_ord_rvimage 
                     well_ord_Memrel [THEN well_ord_subset])
 done
 
 (* ********************************************************************** *)
 
 lemma WO1_WO2: "WO1 \<Longrightarrow> WO2"
-apply (unfold eqpoll_def WO1_def WO2_def)
+  unfolding eqpoll_def WO1_def WO2_def
 apply (blast intro!: Ord_ordertype ordermap_bij)
 done
 
 (* ********************************************************************** *)
 
 lemma lam_sets: "f \<in> A->B \<Longrightarrow> (\<lambda>x \<in> A. {f`x}): A -> {{b}. b \<in> B}"
 by (fast intro!: lam_type apply_type)
 
 lemma surj_imp_eq': "f \<in> surj(A,B) \<Longrightarrow> (\<Union>a \<in> A. {f`a}) = B"
   unfolding surj_def
 apply (fast elim!: apply_type)
 done
 
 lemma surj_imp_eq: "\<lbrakk>f \<in> surj(A,B); Ord(A)\<rbrakk> \<Longrightarrow> (\<Union>a<A. {f`a}) = B"
 by (fast dest!: surj_imp_eq' intro!: ltI elim!: ltE)
 
 lemma WO1_WO4: "WO1 \<Longrightarrow> WO4(1)"
-apply (unfold WO1_def WO4_def)
+  unfolding WO1_def WO4_def
 apply (rule allI)
 apply (erule_tac x = A in allE)
 apply (erule exE)
 apply (intro exI conjI)
 apply (erule Ord_ordertype)
 apply (erule ordermap_bij [THEN bij_converse_bij, THEN bij_is_fun, THEN lam_sets, THEN domain_of_fun])
 apply (simp_all add: singleton_eqpoll_1 eqpoll_imp_lepoll Ord_ordertype
        ordermap_bij [THEN bij_converse_bij, THEN bij_is_surj, THEN surj_imp_eq]
        ltD)
 done
 
 (* ********************************************************************** *)
 
 lemma WO4_mono: "\<lbrakk>m\<le>n; WO4(m)\<rbrakk> \<Longrightarrow> WO4(n)"
   unfolding WO4_def
 apply (blast dest!: spec intro: lepoll_trans [OF _ le_imp_lepoll])
 done
 
 (* ********************************************************************** *)
 
 lemma WO4_WO5: "\<lbrakk>m \<in> nat; 1\<le>m; WO4(m)\<rbrakk> \<Longrightarrow> WO5"
 by (unfold WO4_def WO5_def, blast)
 
 (* ********************************************************************** *)
 
 lemma WO5_WO6: "WO5 \<Longrightarrow> WO6"
 by (unfold WO4_def WO5_def WO6_def, blast)
 
 
 (* ********************************************************************** 
     The proof of "WO6 \<Longrightarrow> WO1".  Simplified by L C Paulson.
 
     From the book "Equivalents of the Axiom of Choice" by Rubin \<and> Rubin,
     pages 2-5
 ************************************************************************* *)
 
 lemma lt_oadd_odiff_disj:
       "\<lbrakk>k < i++j;  Ord(i);  Ord(j)\<rbrakk> 
        \<Longrightarrow> k < i  |  (\<not> k<i \<and> k = i ++ (k--i) \<and> (k--i)<j)"
 apply (rule_tac i = k and j = i in Ord_linear2)
 prefer 4 
    apply (drule odiff_lt_mono2, assumption)
    apply (simp add: oadd_odiff_inverse odiff_oadd_inverse)
 apply (auto elim!: lt_Ord)
 done
 
 
 (* ********************************************************************** *)
 (* The most complicated part of the proof - lemma ii - p. 2-4             *)
 (* ********************************************************************** *)
 
 (* ********************************************************************** *)
 (* some properties of relation uu(beta, gamma, delta) - p. 2              *)
 (* ********************************************************************** *)
 
 lemma domain_uu_subset: "domain(uu(f,b,g,d)) \<subseteq> f`b"
 by (unfold uu_def, blast)
 
 lemma quant_domain_uu_lepoll_m:
      "\<forall>b<a. f`b \<lesssim> m \<Longrightarrow> \<forall>b<a. \<forall>g<a. \<forall>d<a. domain(uu(f,b,g,d)) \<lesssim> m"
 by (blast intro: domain_uu_subset [THEN subset_imp_lepoll] lepoll_trans)
 
 lemma uu_subset1: "uu(f,b,g,d) \<subseteq> f`b * f`g"
 by (unfold uu_def, blast)
 
 lemma uu_subset2: "uu(f,b,g,d) \<subseteq> f`d"
 by (unfold uu_def, blast)
 
 lemma uu_lepoll_m: "\<lbrakk>\<forall>b<a. f`b \<lesssim> m;  d<a\<rbrakk> \<Longrightarrow> uu(f,b,g,d) \<lesssim> m"
 by (blast intro: uu_subset2 [THEN subset_imp_lepoll] lepoll_trans)
 
 (* ********************************************************************** *)
 (* Two cases for lemma ii                                                 *)
 (* ********************************************************************** *)
 lemma cases: 
      "\<forall>b<a. \<forall>g<a. \<forall>d<a. u(f,b,g,d) \<lesssim> m   
       \<Longrightarrow> (\<forall>b<a. f`b \<noteq> 0 \<longrightarrow>  
                   (\<exists>g<a. \<exists>d<a. u(f,b,g,d) \<noteq> 0 \<and> u(f,b,g,d) \<prec> m))  
         | (\<exists>b<a. f`b \<noteq> 0 \<and> (\<forall>g<a. \<forall>d<a. u(f,b,g,d) \<noteq> 0 \<longrightarrow>   
                                         u(f,b,g,d) \<approx> m))"
   unfolding lesspoll_def
 apply (blast del: equalityI)
 done
 
 (* ********************************************************************** *)
 (* Lemmas used in both cases                                              *)
 (* ********************************************************************** *)
 lemma UN_oadd: "Ord(a) \<Longrightarrow> (\<Union>b<a++a. C(b)) = (\<Union>b<a. C(b) \<union> C(a++b))"
 by (blast intro: ltI lt_oadd1 oadd_lt_mono2 dest!: lt_oadd_disj)
 
 
 (* ********************************************************************** *)
 (* Case 1: lemmas                                                        *)
 (* ********************************************************************** *)
 
 lemma vv1_subset: "vv1(f,m,b) \<subseteq> f`b"
 by (simp add: vv1_def Let_def domain_uu_subset)
 
 (* ********************************************************************** *)
 (* Case 1: Union of images is the whole "y"                              *)
 (* ********************************************************************** *)
 lemma UN_gg1_eq: 
   "\<lbrakk>Ord(a);  m \<in> nat\<rbrakk> \<Longrightarrow> (\<Union>b<a++a. gg1(f,a,m)`b) = (\<Union>b<a. f`b)"
 by (simp add: gg1_def UN_oadd lt_oadd1 oadd_le_self [THEN le_imp_not_lt] 
               lt_Ord odiff_oadd_inverse ltD vv1_subset [THEN Diff_partition]
               ww1_def)
 
 lemma domain_gg1: "domain(gg1(f,a,m)) = a++a"
 by (simp add: lam_funtype [THEN domain_of_fun] gg1_def)
 
 (* ********************************************************************** *)
 (* every value of defined function is less than or equipollent to m       *)
 (* ********************************************************************** *)
 lemma nested_LeastI:
      "\<lbrakk>P(a, b);  Ord(a);  Ord(b);   
          Least_a = (\<mu> a. \<exists>x. Ord(x) \<and> P(a, x))\<rbrakk>   
       \<Longrightarrow> P(Least_a, \<mu> b. P(Least_a, b))"
 apply (erule ssubst)
 apply (rule_tac Q = "\<lambda>z. P (z, \<mu> b. P (z, b))" in LeastI2)
 apply (fast elim!: LeastI)+
 done
 
 lemmas nested_Least_instance =
        nested_LeastI [of "\<lambda>g d. domain(uu(f,b,g,d)) \<noteq> 0 \<and> 
                                 domain(uu(f,b,g,d)) \<lesssim> m"] for f b m
 
 lemma gg1_lepoll_m: 
      "\<lbrakk>Ord(a);  m \<in> nat;   
          \<forall>b<a. f`b \<noteq>0 \<longrightarrow>                                        
              (\<exists>g<a. \<exists>d<a. domain(uu(f,b,g,d)) \<noteq> 0  \<and>                
                           domain(uu(f,b,g,d)) \<lesssim> m);             
          \<forall>b<a. f`b \<lesssim> succ(m);  b<a++a\<rbrakk> 
       \<Longrightarrow> gg1(f,a,m)`b \<lesssim> m"
 apply (simp add: gg1_def empty_lepollI)
 apply (safe dest!: lt_oadd_odiff_disj)
 (*Case b<a   \<in> show vv1(f,m,b) \<lesssim> m *)
  apply (simp add: vv1_def Let_def empty_lepollI)
  apply (fast intro: nested_Least_instance [THEN conjunct2]
              elim!: lt_Ord)
 (*Case a\<le>b \<in> show ww1(f,m,b--a) \<lesssim> m *)
 apply (simp add: ww1_def empty_lepollI)
 apply (case_tac "f` (b--a) = 0", simp add: empty_lepollI)
 apply (rule Diff_lepoll, blast)
 apply (rule vv1_subset)
 apply (drule ospec [THEN mp], assumption+)
 apply (elim oexE conjE)
 apply (simp add: vv1_def Let_def lt_Ord nested_Least_instance [THEN conjunct1])
 done
 
 (* ********************************************************************** *)
 (* Case 2: lemmas                                                        *)
 (* ********************************************************************** *)
 
 (* ********************************************************************** *)
 (* Case 2: vv2_subset                                                    *)
 (* ********************************************************************** *)
 
 lemma ex_d_uu_not_empty:
      "\<lbrakk>b<a;  g<a;  f`b\<noteq>0;  f`g\<noteq>0;         
          y*y \<subseteq> y;  (\<Union>b<a. f`b)=y\<rbrakk> 
       \<Longrightarrow> \<exists>d<a. uu(f,b,g,d) \<noteq> 0"
 by (unfold uu_def, blast) 
 
 lemma uu_not_empty:
      "\<lbrakk>b<a; g<a; f`b\<noteq>0; f`g\<noteq>0;  y*y \<subseteq> y; (\<Union>b<a. f`b)=y\<rbrakk>   
       \<Longrightarrow> uu(f,b,g,\<mu> d. (uu(f,b,g,d) \<noteq> 0)) \<noteq> 0"
 apply (drule ex_d_uu_not_empty, assumption+)
 apply (fast elim!: LeastI lt_Ord)
 done
 
 lemma not_empty_rel_imp_domain: "\<lbrakk>r \<subseteq> A*B; r\<noteq>0\<rbrakk> \<Longrightarrow> domain(r)\<noteq>0"
 by blast
 
 lemma Least_uu_not_empty_lt_a:
      "\<lbrakk>b<a; g<a; f`b\<noteq>0; f`g\<noteq>0; y*y \<subseteq> y; (\<Union>b<a. f`b)=y\<rbrakk>   
       \<Longrightarrow> (\<mu> d. uu(f,b,g,d) \<noteq> 0) < a"
 apply (erule ex_d_uu_not_empty [THEN oexE], assumption+)
 apply (blast intro: Least_le [THEN lt_trans1] lt_Ord)
 done
 
 lemma subset_Diff_sing: "\<lbrakk>B \<subseteq> A; a\<notin>B\<rbrakk> \<Longrightarrow> B \<subseteq> A-{a}"
 by blast
 
 (*Could this be proved more directly?*)
 lemma supset_lepoll_imp_eq:
      "\<lbrakk>A \<lesssim> m; m \<lesssim> B; B \<subseteq> A; m \<in> nat\<rbrakk> \<Longrightarrow> A=B"
 apply (erule natE)
 apply (fast dest!: lepoll_0_is_0 intro!: equalityI)
 apply (safe intro!: equalityI)
 apply (rule ccontr)
 apply (rule succ_lepoll_natE)
  apply (erule lepoll_trans)  
  apply (rule lepoll_trans)  
   apply (erule subset_Diff_sing [THEN subset_imp_lepoll], assumption)
  apply (rule Diff_sing_lepoll, assumption+) 
 done
 
 lemma uu_Least_is_fun:
      "\<lbrakk>\<forall>g<a. \<forall>d<a. domain(uu(f, b, g, d))\<noteq>0 \<longrightarrow>                
           domain(uu(f, b, g, d)) \<approx> succ(m);                         
           \<forall>b<a. f`b \<lesssim> succ(m);  y*y \<subseteq> y;                        
           (\<Union>b<a. f`b)=y;  b<a;  g<a;  d<a;                             
           f`b\<noteq>0;  f`g\<noteq>0;  m \<in> nat;  s \<in> f`b\<rbrakk> 
       \<Longrightarrow> uu(f, b, g, \<mu> d. uu(f,b,g,d)\<noteq>0) \<in> f`b -> f`g"
 apply (drule_tac x2=g in ospec [THEN ospec, THEN mp])
    apply (rule_tac [3] not_empty_rel_imp_domain [OF uu_subset1 uu_not_empty])
         apply (rule_tac [2] Least_uu_not_empty_lt_a, assumption+)
 apply (rule rel_is_fun)
     apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll]) 
    apply (erule uu_lepoll_m) 
    apply (rule Least_uu_not_empty_lt_a, assumption+) 
 apply (rule uu_subset1)
 apply (rule supset_lepoll_imp_eq [OF _ eqpoll_sym [THEN eqpoll_imp_lepoll]])
 apply (fast intro!: domain_uu_subset)+
 done
 
 lemma vv2_subset: 
      "\<lbrakk>\<forall>g<a. \<forall>d<a. domain(uu(f, b, g, d))\<noteq>0 \<longrightarrow>             
                        domain(uu(f, b, g, d)) \<approx> succ(m);
          \<forall>b<a. f`b \<lesssim> succ(m); y*y \<subseteq> y;
          (\<Union>b<a. f`b)=y;  b<a;  g<a;  m \<in> nat;  s \<in> f`b\<rbrakk> 
       \<Longrightarrow> vv2(f,b,g,s) \<subseteq> f`g"
 apply (simp add: vv2_def)
 apply (blast intro: uu_Least_is_fun [THEN apply_type])
 done
 
 (* ********************************************************************** *)
 (* Case 2: Union of images is the whole "y"                              *)
 (* ********************************************************************** *)
 lemma UN_gg2_eq: 
      "\<lbrakk>\<forall>g<a. \<forall>d<a. domain(uu(f,b,g,d)) \<noteq> 0 \<longrightarrow>              
                domain(uu(f,b,g,d)) \<approx> succ(m);                         
          \<forall>b<a. f`b \<lesssim> succ(m); y*y \<subseteq> y;                        
          (\<Union>b<a. f`b)=y;  Ord(a);  m \<in> nat;  s \<in> f`b;  b<a\<rbrakk> 
       \<Longrightarrow> (\<Union>g<a++a. gg2(f,a,b,s) ` g) = y"
   unfolding gg2_def
 apply (drule sym) 
 apply (simp add: ltD UN_oadd  oadd_le_self [THEN le_imp_not_lt] 
                  lt_Ord odiff_oadd_inverse ww2_def 
                  vv2_subset [THEN Diff_partition])
 done
 
 lemma domain_gg2: "domain(gg2(f,a,b,s)) = a++a"
 by (simp add: lam_funtype [THEN domain_of_fun] gg2_def)
 
 
 (* ********************************************************************** *)
 (* every value of defined function is less than or equipollent to m       *)
 (* ********************************************************************** *)
 
 lemma vv2_lepoll: "\<lbrakk>m \<in> nat; m\<noteq>0\<rbrakk> \<Longrightarrow> vv2(f,b,g,s) \<lesssim> m"
   unfolding vv2_def
 apply (simp add: empty_lepollI)
 apply (fast dest!: le_imp_subset [THEN subset_imp_lepoll, THEN lepoll_0_is_0] 
        intro!: singleton_eqpoll_1 [THEN eqpoll_imp_lepoll, THEN lepoll_trans]
                not_lt_imp_le [THEN le_imp_subset, THEN subset_imp_lepoll]
                nat_into_Ord nat_1I)
 done
 
 lemma ww2_lepoll: 
     "\<lbrakk>\<forall>b<a. f`b \<lesssim> succ(m);  g<a;  m \<in> nat;  vv2(f,b,g,d) \<subseteq> f`g\<rbrakk>  
      \<Longrightarrow> ww2(f,b,g,d) \<lesssim> m"
   unfolding ww2_def
 apply (case_tac "f`g = 0")
 apply (simp add: empty_lepollI)
 apply (drule ospec, assumption)
 apply (rule Diff_lepoll, assumption+)
 apply (simp add: vv2_def not_emptyI)
 done
 
 lemma gg2_lepoll_m: 
      "\<lbrakk>\<forall>g<a. \<forall>d<a. domain(uu(f,b,g,d)) \<noteq> 0 \<longrightarrow>              
                       domain(uu(f,b,g,d)) \<approx> succ(m);                         
          \<forall>b<a. f`b \<lesssim> succ(m);  y*y \<subseteq> y;                     
          (\<Union>b<a. f`b)=y;  b<a;  s \<in> f`b;  m \<in> nat;  m\<noteq> 0;  g<a++a\<rbrakk> 
       \<Longrightarrow> gg2(f,a,b,s) ` g \<lesssim> m"
 apply (simp add: gg2_def empty_lepollI)
 apply (safe elim!: lt_Ord2 dest!: lt_oadd_odiff_disj)
  apply (simp add: vv2_lepoll)
 apply (simp add: ww2_lepoll vv2_subset)
 done
 
 (* ********************************************************************** *)
 (* lemma ii                                                               *)
 (* ********************************************************************** *)
 lemma lemma_ii: "\<lbrakk>succ(m) \<in> NN(y); y*y \<subseteq> y; m \<in> nat; m\<noteq>0\<rbrakk> \<Longrightarrow> m \<in> NN(y)"
   unfolding NN_def
 apply (elim CollectE exE conjE) 
 apply (rule quant_domain_uu_lepoll_m [THEN cases, THEN disjE], assumption)
 (* case 1 *)
 apply (simp add: lesspoll_succ_iff)
 apply (rule_tac x = "a++a" in exI)
 apply (fast intro!: Ord_oadd domain_gg1 UN_gg1_eq gg1_lepoll_m)
 (* case 2 *)
 apply (elim oexE conjE)
 apply (rule_tac A = "f`B" for B in not_emptyE, assumption)
 apply (rule CollectI)
 apply (erule succ_natD)
 apply (rule_tac x = "a++a" in exI)
 apply (rule_tac x = "gg2 (f,a,b,x) " in exI)
 apply (simp add: Ord_oadd domain_gg2 UN_gg2_eq gg2_lepoll_m)
 done
 
 
 (* ********************************************************************** *)
 (* lemma iv - p. 4:                                                       *)
 (* For every set x there is a set y such that   x \<union> (y * y) \<subseteq> y         *)
 (* ********************************************************************** *)
 
 
 (* The leading \<forall>-quantifier looks odd but makes the proofs shorter 
    (used only in the following two lemmas)                          *)
 
 lemma z_n_subset_z_succ_n:
      "\<forall>n \<in> nat. rec(n, x, \<lambda>k r. r \<union> r*r) \<subseteq> rec(succ(n), x, \<lambda>k r. r \<union> r*r)"
 by (fast intro: rec_succ [THEN ssubst])
 
 lemma le_subsets:
      "\<lbrakk>\<forall>n \<in> nat. f(n)<=f(succ(n)); n\<le>m; n \<in> nat; m \<in> nat\<rbrakk>   
       \<Longrightarrow> f(n)<=f(m)"
 apply (erule_tac P = "n\<le>m" in rev_mp)
 apply (rule_tac P = "\<lambda>z. n\<le>z \<longrightarrow> f (n) \<subseteq> f (z) " in nat_induct) 
 apply (auto simp add: le_iff) 
 done
 
 lemma le_imp_rec_subset:
      "\<lbrakk>n\<le>m; m \<in> nat\<rbrakk> 
       \<Longrightarrow> rec(n, x, \<lambda>k r. r \<union> r*r) \<subseteq> rec(m, x, \<lambda>k r. r \<union> r*r)"
 apply (rule z_n_subset_z_succ_n [THEN le_subsets])
 apply (blast intro: lt_nat_in_nat)+
 done
 
 lemma lemma_iv: "\<exists>y. x \<union> y*y \<subseteq> y"
 apply (rule_tac x = "\<Union>n \<in> nat. rec (n, x, \<lambda>k r. r \<union> r*r) " in exI)
 apply safe
 apply (rule nat_0I [THEN UN_I], simp)
 apply (rule_tac a = "succ (n \<union> na) " in UN_I)
 apply (erule Un_nat_type [THEN nat_succI], assumption)
 apply (auto intro: le_imp_rec_subset [THEN subsetD] 
             intro!: Un_upper1_le Un_upper2_le Un_nat_type 
             elim!: nat_into_Ord)
 done
 
 (* ********************************************************************** *)
 (* Rubin \<and> Rubin wrote,                                                   *)
 (* "It follows from (ii) and mathematical induction that if y*y \<subseteq> y then *)
 (* y can be well-ordered"                                                 *)
 
 (* In fact we have to prove                                               *)
 (*      * WO6 \<Longrightarrow> NN(y) \<noteq> 0                                              *)
 (*      * reverse induction which lets us infer that 1 \<in> NN(y)            *)
 (*      * 1 \<in> NN(y) \<Longrightarrow> y can be well-ordered                             *)
 (* ********************************************************************** *)
 
 (* ********************************************************************** *)
 (*      WO6 \<Longrightarrow> NN(y) \<noteq> 0                                                *)
 (* ********************************************************************** *)
 
 lemma WO6_imp_NN_not_empty: "WO6 \<Longrightarrow> NN(y) \<noteq> 0"
 by (unfold WO6_def NN_def, clarify, blast)
 
 (* ********************************************************************** *)
 (*      1 \<in> NN(y) \<Longrightarrow> y can be well-ordered                               *)
 (* ********************************************************************** *)
 
 lemma lemma1:
      "\<lbrakk>(\<Union>b<a. f`b)=y; x \<in> y; \<forall>b<a. f`b \<lesssim> 1; Ord(a)\<rbrakk> \<Longrightarrow> \<exists>c<a. f`c = {x}"
 by (fast elim!: lepoll_1_is_sing)
 
 lemma lemma2:
      "\<lbrakk>(\<Union>b<a. f`b)=y; x \<in> y; \<forall>b<a. f`b \<lesssim> 1; Ord(a)\<rbrakk>   
       \<Longrightarrow> f` (\<mu> i. f`i = {x}) = {x}"
 apply (drule lemma1, assumption+)
 apply (fast elim!: lt_Ord intro: LeastI)
 done
 
 lemma NN_imp_ex_inj: "1 \<in> NN(y) \<Longrightarrow> \<exists>a f. Ord(a) \<and> f \<in> inj(y, a)"
   unfolding NN_def
 apply (elim CollectE exE conjE)
 apply (rule_tac x = a in exI)
 apply (rule_tac x = "\<lambda>x \<in> y. \<mu> i. f`i = {x}" in exI)
 apply (rule conjI, assumption)
 apply (rule_tac d = "\<lambda>i. THE x. x \<in> f`i" in lam_injective)
 apply (drule lemma1, assumption+)
 apply (fast elim!: Least_le [THEN lt_trans1, THEN ltD] lt_Ord)
 apply (rule lemma2 [THEN ssubst], assumption+, blast)
 done
 
 lemma y_well_ord: "\<lbrakk>y*y \<subseteq> y; 1 \<in> NN(y)\<rbrakk> \<Longrightarrow> \<exists>r. well_ord(y, r)"
 apply (drule NN_imp_ex_inj)
 apply (fast elim!: well_ord_rvimage [OF _ well_ord_Memrel])
 done
 
 (* ********************************************************************** *)
 (*      reverse induction which lets us infer that 1 \<in> NN(y)              *)
 (* ********************************************************************** *)
 
 lemma rev_induct_lemma [rule_format]: 
      "\<lbrakk>n \<in> nat; \<And>m. \<lbrakk>m \<in> nat; m\<noteq>0; P(succ(m))\<rbrakk> \<Longrightarrow> P(m)\<rbrakk>   
       \<Longrightarrow> n\<noteq>0 \<longrightarrow> P(n) \<longrightarrow> P(1)"
 by (erule nat_induct, blast+)
 
 lemma rev_induct:
      "\<lbrakk>n \<in> nat;  P(n);  n\<noteq>0;   
          \<And>m. \<lbrakk>m \<in> nat; m\<noteq>0; P(succ(m))\<rbrakk> \<Longrightarrow> P(m)\<rbrakk>   
       \<Longrightarrow> P(1)"
 by (rule rev_induct_lemma, blast+)
 
 lemma NN_into_nat: "n \<in> NN(y) \<Longrightarrow> n \<in> nat"
 by (simp add: NN_def)
 
 lemma lemma3: "\<lbrakk>n \<in> NN(y); y*y \<subseteq> y; n\<noteq>0\<rbrakk> \<Longrightarrow> 1 \<in> NN(y)"
 apply (rule rev_induct [OF NN_into_nat], assumption+)
 apply (rule lemma_ii, assumption+)
 done
 
 (* ********************************************************************** *)
 (* Main theorem "WO6 \<Longrightarrow> WO1"                                             *)
 (* ********************************************************************** *)
 
 (* another helpful lemma *)
 lemma NN_y_0: "0 \<in> NN(y) \<Longrightarrow> y=0"
   unfolding NN_def 
 apply (fast intro!: equalityI dest!: lepoll_0_is_0 elim: subst)
 done
 
 lemma WO6_imp_WO1: "WO6 \<Longrightarrow> WO1"
   unfolding WO1_def
 apply (rule allI)
 apply (case_tac "A=0")
 apply (fast intro!: well_ord_Memrel nat_0I [THEN nat_into_Ord])
 apply (rule_tac x = A in lemma_iv [elim_format])
 apply (erule exE)
 apply (drule WO6_imp_NN_not_empty)
 apply (erule Un_subset_iff [THEN iffD1, THEN conjE])
 apply (erule_tac A = "NN (y) " in not_emptyE)
 apply (frule y_well_ord)
  apply (fast intro!: lemma3 dest!: NN_y_0 elim!: not_emptyE)
 apply (fast elim: well_ord_subset)
 done
 
 end
diff --git a/src/ZF/Bin.thy b/src/ZF/Bin.thy
--- a/src/ZF/Bin.thy
+++ b/src/ZF/Bin.thy
@@ -1,763 +1,763 @@
 (*  Title:      ZF/Bin.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 
    The sign Pls stands for an infinite string of leading 0's.
    The sign Min stands for an infinite string of leading 1's.
 
 A number can have multiple representations, namely leading 0's with sign
 Pls and leading 1's with sign Min.  See twos-compl.ML/int_of_binary for
 the numerical interpretation.
 
 The representation expects that (m mod 2) is 0 or 1, even if m is negative;
 For instance, \<not>5 div 2 = \<not>3 and \<not>5 mod 2 = 1; thus \<not>5 = (\<not>3)*2 + 1
 *)
 
 section\<open>Arithmetic on Binary Integers\<close>
 
 theory Bin
 imports Int Datatype
 begin
 
 consts  bin :: i
 datatype
   "bin" = Pls
         | Min
         | Bit ("w \<in> bin", "b \<in> bool")     (infixl \<open>BIT\<close> 90)
 
 consts
   integ_of  :: "i\<Rightarrow>i"
   NCons     :: "[i,i]\<Rightarrow>i"
   bin_succ  :: "i\<Rightarrow>i"
   bin_pred  :: "i\<Rightarrow>i"
   bin_minus :: "i\<Rightarrow>i"
   bin_adder :: "i\<Rightarrow>i"
   bin_mult  :: "[i,i]\<Rightarrow>i"
 
 primrec
   integ_of_Pls:  "integ_of (Pls)     = $# 0"
   integ_of_Min:  "integ_of (Min)     = $-($#1)"
   integ_of_BIT:  "integ_of (w BIT b) = $#b $+ integ_of(w) $+ integ_of(w)"
 
     (** recall that cond(1,b,c)=b and cond(0,b,c)=0 **)
 
 primrec (*NCons adds a bit, suppressing leading 0s and 1s*)
   NCons_Pls: "NCons (Pls,b)     = cond(b,Pls BIT b,Pls)"
   NCons_Min: "NCons (Min,b)     = cond(b,Min,Min BIT b)"
   NCons_BIT: "NCons (w BIT c,b) = w BIT c BIT b"
 
 primrec (*successor.  If a BIT, can change a 0 to a 1 without recursion.*)
   bin_succ_Pls:  "bin_succ (Pls)     = Pls BIT 1"
   bin_succ_Min:  "bin_succ (Min)     = Pls"
   bin_succ_BIT:  "bin_succ (w BIT b) = cond(b, bin_succ(w) BIT 0, NCons(w,1))"
 
 primrec (*predecessor*)
   bin_pred_Pls:  "bin_pred (Pls)     = Min"
   bin_pred_Min:  "bin_pred (Min)     = Min BIT 0"
   bin_pred_BIT:  "bin_pred (w BIT b) = cond(b, NCons(w,0), bin_pred(w) BIT 1)"
 
 primrec (*unary negation*)
   bin_minus_Pls:
     "bin_minus (Pls)       = Pls"
   bin_minus_Min:
     "bin_minus (Min)       = Pls BIT 1"
   bin_minus_BIT:
     "bin_minus (w BIT b) = cond(b, bin_pred(NCons(bin_minus(w),0)),
                                 bin_minus(w) BIT 0)"
 
 primrec (*sum*)
   bin_adder_Pls:
     "bin_adder (Pls)     = (\<lambda>w\<in>bin. w)"
   bin_adder_Min:
     "bin_adder (Min)     = (\<lambda>w\<in>bin. bin_pred(w))"
   bin_adder_BIT:
     "bin_adder (v BIT x) =
        (\<lambda>w\<in>bin.
          bin_case (v BIT x, bin_pred(v BIT x),
                    \<lambda>w y. NCons(bin_adder (v) ` cond(x and y, bin_succ(w), w),
                                x xor y),
                    w))"
 
 (*The bin_case above replaces the following mutually recursive function:
 primrec
   "adding (v,x,Pls)     = v BIT x"
   "adding (v,x,Min)     = bin_pred(v BIT x)"
   "adding (v,x,w BIT y) = NCons(bin_adder (v, cond(x and y, bin_succ(w), w)),
                                 x xor y)"
 *)
 
 definition
   bin_add   :: "[i,i]\<Rightarrow>i"  where
     "bin_add(v,w) \<equiv> bin_adder(v)`w"
 
 
 primrec
   bin_mult_Pls:
     "bin_mult (Pls,w)     = Pls"
   bin_mult_Min:
     "bin_mult (Min,w)     = bin_minus(w)"
   bin_mult_BIT:
     "bin_mult (v BIT b,w) = cond(b, bin_add(NCons(bin_mult(v,w),0),w),
                                  NCons(bin_mult(v,w),0))"
 
 syntax
   "_Int0" :: i  (\<open>#' 0\<close>)
   "_Int1" :: i  (\<open>#' 1\<close>)
   "_Int2" :: i  (\<open>#' 2\<close>)
   "_Neg_Int1" :: i  (\<open>#-' 1\<close>)
   "_Neg_Int2" :: i  (\<open>#-' 2\<close>)
 translations
   "#0" \<rightleftharpoons> "CONST integ_of(CONST Pls)"
   "#1" \<rightleftharpoons> "CONST integ_of(CONST Pls BIT 1)"
   "#2" \<rightleftharpoons> "CONST integ_of(CONST Pls BIT 1 BIT 0)"
   "#-1" \<rightleftharpoons> "CONST integ_of(CONST Min)"
   "#-2" \<rightleftharpoons> "CONST integ_of(CONST Min BIT 0)"
 
 syntax
   "_Int" :: "num_token \<Rightarrow> i"  (\<open>#_\<close> 1000)
   "_Neg_Int" :: "num_token \<Rightarrow> i"  (\<open>#-_\<close> 1000)
 
 ML_file \<open>Tools/numeral_syntax.ML\<close>
 
 
 declare bin.intros [simp,TC]
 
 lemma NCons_Pls_0: "NCons(Pls,0) = Pls"
 by simp
 
 lemma NCons_Pls_1: "NCons(Pls,1) = Pls BIT 1"
 by simp
 
 lemma NCons_Min_0: "NCons(Min,0) = Min BIT 0"
 by simp
 
 lemma NCons_Min_1: "NCons(Min,1) = Min"
 by simp
 
 lemma NCons_BIT: "NCons(w BIT x,b) = w BIT x BIT b"
 by (simp add: bin.case_eqns)
 
 lemmas NCons_simps [simp] =
     NCons_Pls_0 NCons_Pls_1 NCons_Min_0 NCons_Min_1 NCons_BIT
 
 
 
 (** Type checking **)
 
 lemma integ_of_type [TC]: "w \<in> bin \<Longrightarrow> integ_of(w) \<in> int"
 apply (induct_tac "w")
 apply (simp_all add: bool_into_nat)
 done
 
 lemma NCons_type [TC]: "\<lbrakk>w \<in> bin; b \<in> bool\<rbrakk> \<Longrightarrow> NCons(w,b) \<in> bin"
 by (induct_tac "w", auto)
 
 lemma bin_succ_type [TC]: "w \<in> bin \<Longrightarrow> bin_succ(w) \<in> bin"
 by (induct_tac "w", auto)
 
 lemma bin_pred_type [TC]: "w \<in> bin \<Longrightarrow> bin_pred(w) \<in> bin"
 by (induct_tac "w", auto)
 
 lemma bin_minus_type [TC]: "w \<in> bin \<Longrightarrow> bin_minus(w) \<in> bin"
 by (induct_tac "w", auto)
 
 (*This proof is complicated by the mutual recursion*)
 lemma bin_add_type [rule_format]:
      "v \<in> bin \<Longrightarrow> \<forall>w\<in>bin. bin_add(v,w) \<in> bin"
   unfolding bin_add_def
 apply (induct_tac "v")
 apply (rule_tac [3] ballI)
 apply (rename_tac [3] "w'")
 apply (induct_tac [3] "w'")
 apply (simp_all add: NCons_type)
 done
 
 declare bin_add_type [TC]
 
 lemma bin_mult_type [TC]: "\<lbrakk>v \<in> bin; w \<in> bin\<rbrakk> \<Longrightarrow> bin_mult(v,w) \<in> bin"
 by (induct_tac "v", auto)
 
 
 subsubsection\<open>The Carry and Borrow Functions,
             \<^term>\<open>bin_succ\<close> and \<^term>\<open>bin_pred\<close>\<close>
 
 (*NCons preserves the integer value of its argument*)
 lemma integ_of_NCons [simp]:
      "\<lbrakk>w \<in> bin; b \<in> bool\<rbrakk> \<Longrightarrow> integ_of(NCons(w,b)) = integ_of(w BIT b)"
 apply (erule bin.cases)
 apply (auto elim!: boolE)
 done
 
 lemma integ_of_succ [simp]:
      "w \<in> bin \<Longrightarrow> integ_of(bin_succ(w)) = $#1 $+ integ_of(w)"
 apply (erule bin.induct)
 apply (auto simp add: zadd_ac elim!: boolE)
 done
 
 lemma integ_of_pred [simp]:
      "w \<in> bin \<Longrightarrow> integ_of(bin_pred(w)) = $- ($#1) $+ integ_of(w)"
 apply (erule bin.induct)
 apply (auto simp add: zadd_ac elim!: boolE)
 done
 
 
 subsubsection\<open>\<^term>\<open>bin_minus\<close>: Unary Negation of Binary Integers\<close>
 
 lemma integ_of_minus: "w \<in> bin \<Longrightarrow> integ_of(bin_minus(w)) = $- integ_of(w)"
 apply (erule bin.induct)
 apply (auto simp add: zadd_ac zminus_zadd_distrib  elim!: boolE)
 done
 
 
 subsubsection\<open>\<^term>\<open>bin_add\<close>: Binary Addition\<close>
 
 lemma bin_add_Pls [simp]: "w \<in> bin \<Longrightarrow> bin_add(Pls,w) = w"
 by (unfold bin_add_def, simp)
 
 lemma bin_add_Pls_right: "w \<in> bin \<Longrightarrow> bin_add(w,Pls) = w"
   unfolding bin_add_def
 apply (erule bin.induct, auto)
 done
 
 lemma bin_add_Min [simp]: "w \<in> bin \<Longrightarrow> bin_add(Min,w) = bin_pred(w)"
 by (unfold bin_add_def, simp)
 
 lemma bin_add_Min_right: "w \<in> bin \<Longrightarrow> bin_add(w,Min) = bin_pred(w)"
   unfolding bin_add_def
 apply (erule bin.induct, auto)
 done
 
 lemma bin_add_BIT_Pls [simp]: "bin_add(v BIT x,Pls) = v BIT x"
 by (unfold bin_add_def, simp)
 
 lemma bin_add_BIT_Min [simp]: "bin_add(v BIT x,Min) = bin_pred(v BIT x)"
 by (unfold bin_add_def, simp)
 
 lemma bin_add_BIT_BIT [simp]:
      "\<lbrakk>w \<in> bin;  y \<in> bool\<rbrakk>
       \<Longrightarrow> bin_add(v BIT x, w BIT y) =
           NCons(bin_add(v, cond(x and y, bin_succ(w), w)), x xor y)"
 by (unfold bin_add_def, simp)
 
 lemma integ_of_add [rule_format]:
      "v \<in> bin \<Longrightarrow>
           \<forall>w\<in>bin. integ_of(bin_add(v,w)) = integ_of(v) $+ integ_of(w)"
 apply (erule bin.induct, simp, simp)
 apply (rule ballI)
 apply (induct_tac "wa")
 apply (auto simp add: zadd_ac elim!: boolE)
 done
 
 (*Subtraction*)
 lemma diff_integ_of_eq:
      "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
       \<Longrightarrow> integ_of(v) $- integ_of(w) = integ_of(bin_add (v, bin_minus(w)))"
   unfolding zdiff_def
 apply (simp add: integ_of_add integ_of_minus)
 done
 
 
 subsubsection\<open>\<^term>\<open>bin_mult\<close>: Binary Multiplication\<close>
 
 lemma integ_of_mult:
      "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
       \<Longrightarrow> integ_of(bin_mult(v,w)) = integ_of(v) $* integ_of(w)"
 apply (induct_tac "v", simp)
 apply (simp add: integ_of_minus)
 apply (auto simp add: zadd_ac integ_of_add zadd_zmult_distrib  elim!: boolE)
 done
 
 
 subsection\<open>Computations\<close>
 
 (** extra rules for bin_succ, bin_pred **)
 
 lemma bin_succ_1: "bin_succ(w BIT 1) = bin_succ(w) BIT 0"
 by simp
 
 lemma bin_succ_0: "bin_succ(w BIT 0) = NCons(w,1)"
 by simp
 
 lemma bin_pred_1: "bin_pred(w BIT 1) = NCons(w,0)"
 by simp
 
 lemma bin_pred_0: "bin_pred(w BIT 0) = bin_pred(w) BIT 1"
 by simp
 
 (** extra rules for bin_minus **)
 
 lemma bin_minus_1: "bin_minus(w BIT 1) = bin_pred(NCons(bin_minus(w), 0))"
 by simp
 
 lemma bin_minus_0: "bin_minus(w BIT 0) = bin_minus(w) BIT 0"
 by simp
 
 (** extra rules for bin_add **)
 
 lemma bin_add_BIT_11: "w \<in> bin \<Longrightarrow> bin_add(v BIT 1, w BIT 1) =
                      NCons(bin_add(v, bin_succ(w)), 0)"
 by simp
 
 lemma bin_add_BIT_10: "w \<in> bin \<Longrightarrow> bin_add(v BIT 1, w BIT 0) =
                      NCons(bin_add(v,w), 1)"
 by simp
 
 lemma bin_add_BIT_0: "\<lbrakk>w \<in> bin;  y \<in> bool\<rbrakk>
       \<Longrightarrow> bin_add(v BIT 0, w BIT y) = NCons(bin_add(v,w), y)"
 by simp
 
 (** extra rules for bin_mult **)
 
 lemma bin_mult_1: "bin_mult(v BIT 1, w) = bin_add(NCons(bin_mult(v,w),0), w)"
 by simp
 
 lemma bin_mult_0: "bin_mult(v BIT 0, w) = NCons(bin_mult(v,w),0)"
 by simp
 
 
 (** Simplification rules with integer constants **)
 
 lemma int_of_0: "$#0 = #0"
 by simp
 
 lemma int_of_succ: "$# succ(n) = #1 $+ $#n"
 by (simp add: int_of_add [symmetric] natify_succ)
 
 lemma zminus_0 [simp]: "$- #0 = #0"
 by simp
 
 lemma zadd_0_intify [simp]: "#0 $+ z = intify(z)"
 by simp
 
 lemma zadd_0_right_intify [simp]: "z $+ #0 = intify(z)"
 by simp
 
 lemma zmult_1_intify [simp]: "#1 $* z = intify(z)"
 by simp
 
 lemma zmult_1_right_intify [simp]: "z $* #1 = intify(z)"
 by (subst zmult_commute, simp)
 
 lemma zmult_0 [simp]: "#0 $* z = #0"
 by simp
 
 lemma zmult_0_right [simp]: "z $* #0 = #0"
 by (subst zmult_commute, simp)
 
 lemma zmult_minus1 [simp]: "#-1 $* z = $-z"
 by (simp add: zcompare_rls)
 
 lemma zmult_minus1_right [simp]: "z $* #-1 = $-z"
 apply (subst zmult_commute)
 apply (rule zmult_minus1)
 done
 
 
 subsection\<open>Simplification Rules for Comparison of Binary Numbers\<close>
 text\<open>Thanks to Norbert Voelker\<close>
 
 (** Equals (=) **)
 
 lemma eq_integ_of_eq:
      "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
       \<Longrightarrow> ((integ_of(v)) = integ_of(w)) \<longleftrightarrow>
           iszero (integ_of (bin_add (v, bin_minus(w))))"
   unfolding iszero_def
 apply (simp add: zcompare_rls integ_of_add integ_of_minus)
 done
 
 lemma iszero_integ_of_Pls: "iszero (integ_of(Pls))"
 by (unfold iszero_def, simp)
 
 
 lemma nonzero_integ_of_Min: "\<not> iszero (integ_of(Min))"
   unfolding iszero_def
 apply (simp add: zminus_equation)
 done
 
 lemma iszero_integ_of_BIT:
      "\<lbrakk>w \<in> bin; x \<in> bool\<rbrakk>
       \<Longrightarrow> iszero (integ_of (w BIT x)) \<longleftrightarrow> (x=0 \<and> iszero (integ_of(w)))"
 apply (unfold iszero_def, simp)
 apply (subgoal_tac "integ_of (w) \<in> int")
 apply typecheck
 apply (drule int_cases)
 apply (safe elim!: boolE)
 apply (simp_all (asm_lr) add: zcompare_rls zminus_zadd_distrib [symmetric]
                      int_of_add [symmetric])
 done
 
 lemma iszero_integ_of_0:
      "w \<in> bin \<Longrightarrow> iszero (integ_of (w BIT 0)) \<longleftrightarrow> iszero (integ_of(w))"
 by (simp only: iszero_integ_of_BIT, blast)
 
 lemma iszero_integ_of_1: "w \<in> bin \<Longrightarrow> \<not> iszero (integ_of (w BIT 1))"
 by (simp only: iszero_integ_of_BIT, blast)
 
 
 
 (** Less-than (<) **)
 
 lemma less_integ_of_eq_neg:
      "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
       \<Longrightarrow> integ_of(v) $< integ_of(w)
           \<longleftrightarrow> znegative (integ_of (bin_add (v, bin_minus(w))))"
-apply (unfold zless_def zdiff_def)
+  unfolding zless_def zdiff_def
 apply (simp add: integ_of_minus integ_of_add)
 done
 
 lemma not_neg_integ_of_Pls: "\<not> znegative (integ_of(Pls))"
 by simp
 
 lemma neg_integ_of_Min: "znegative (integ_of(Min))"
 by simp
 
 lemma neg_integ_of_BIT:
      "\<lbrakk>w \<in> bin; x \<in> bool\<rbrakk>
       \<Longrightarrow> znegative (integ_of (w BIT x)) \<longleftrightarrow> znegative (integ_of(w))"
 apply simp
 apply (subgoal_tac "integ_of (w) \<in> int")
 apply typecheck
 apply (drule int_cases)
 apply (auto elim!: boolE simp add: int_of_add [symmetric]  zcompare_rls)
 apply (simp_all add: zminus_zadd_distrib [symmetric] zdiff_def
                      int_of_add [symmetric])
 apply (subgoal_tac "$#1 $- $# succ (succ (n #+ n)) = $- $# succ (n #+ n) ")
  apply (simp add: zdiff_def)
 apply (simp add: equation_zminus int_of_diff [symmetric])
 done
 
 (** Less-than-or-equals (<=) **)
 
 lemma le_integ_of_eq_not_less:
      "(integ_of(x) $\<le> (integ_of(w))) \<longleftrightarrow> \<not> (integ_of(w) $< (integ_of(x)))"
 by (simp add: not_zless_iff_zle [THEN iff_sym])
 
 
 (*Delete the original rewrites, with their clumsy conditional expressions*)
 declare bin_succ_BIT [simp del]
         bin_pred_BIT [simp del]
         bin_minus_BIT [simp del]
         NCons_Pls [simp del]
         NCons_Min [simp del]
         bin_adder_BIT [simp del]
         bin_mult_BIT [simp del]
 
 (*Hide the binary representation of integer constants*)
 declare integ_of_Pls [simp del] integ_of_Min [simp del] integ_of_BIT [simp del]
 
 
 lemmas bin_arith_extra_simps =
      integ_of_add [symmetric]
      integ_of_minus [symmetric]
      integ_of_mult [symmetric]
      bin_succ_1 bin_succ_0
      bin_pred_1 bin_pred_0
      bin_minus_1 bin_minus_0
      bin_add_Pls_right bin_add_Min_right
      bin_add_BIT_0 bin_add_BIT_10 bin_add_BIT_11
      diff_integ_of_eq
      bin_mult_1 bin_mult_0 NCons_simps
 
 
 (*For making a minimal simpset, one must include these default simprules
   of thy.  Also include simp_thms, or at least (\<not>False)=True*)
 lemmas bin_arith_simps =
      bin_pred_Pls bin_pred_Min
      bin_succ_Pls bin_succ_Min
      bin_add_Pls bin_add_Min
      bin_minus_Pls bin_minus_Min
      bin_mult_Pls bin_mult_Min
      bin_arith_extra_simps
 
 (*Simplification of relational operations*)
 lemmas bin_rel_simps =
      eq_integ_of_eq iszero_integ_of_Pls nonzero_integ_of_Min
      iszero_integ_of_0 iszero_integ_of_1
      less_integ_of_eq_neg
      not_neg_integ_of_Pls neg_integ_of_Min neg_integ_of_BIT
      le_integ_of_eq_not_less
 
 declare bin_arith_simps [simp]
 declare bin_rel_simps [simp]
 
 
 (** Simplification of arithmetic when nested to the right **)
 
 lemma add_integ_of_left [simp]:
      "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
       \<Longrightarrow> integ_of(v) $+ (integ_of(w) $+ z) = (integ_of(bin_add(v,w)) $+ z)"
 by (simp add: zadd_assoc [symmetric])
 
 lemma mult_integ_of_left [simp]:
      "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
       \<Longrightarrow> integ_of(v) $* (integ_of(w) $* z) = (integ_of(bin_mult(v,w)) $* z)"
 by (simp add: zmult_assoc [symmetric])
 
 lemma add_integ_of_diff1 [simp]:
     "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
       \<Longrightarrow> integ_of(v) $+ (integ_of(w) $- c) = integ_of(bin_add(v,w)) $- (c)"
   unfolding zdiff_def
 apply (rule add_integ_of_left, auto)
 done
 
 lemma add_integ_of_diff2 [simp]:
      "\<lbrakk>v \<in> bin;  w \<in> bin\<rbrakk>
       \<Longrightarrow> integ_of(v) $+ (c $- integ_of(w)) =
           integ_of (bin_add (v, bin_minus(w))) $+ (c)"
 apply (subst diff_integ_of_eq [symmetric])
 apply (simp_all add: zdiff_def zadd_ac)
 done
 
 
 (** More for integer constants **)
 
 declare int_of_0 [simp] int_of_succ [simp]
 
 lemma zdiff0 [simp]: "#0 $- x = $-x"
 by (simp add: zdiff_def)
 
 lemma zdiff0_right [simp]: "x $- #0 = intify(x)"
 by (simp add: zdiff_def)
 
 lemma zdiff_self [simp]: "x $- x = #0"
 by (simp add: zdiff_def)
 
 lemma znegative_iff_zless_0: "k \<in> int \<Longrightarrow> znegative(k) \<longleftrightarrow> k $< #0"
 by (simp add: zless_def)
 
 lemma zero_zless_imp_znegative_zminus: "\<lbrakk>#0 $< k; k \<in> int\<rbrakk> \<Longrightarrow> znegative($-k)"
 by (simp add: zless_def)
 
 lemma zero_zle_int_of [simp]: "#0 $\<le> $# n"
 by (simp add: not_zless_iff_zle [THEN iff_sym] znegative_iff_zless_0 [THEN iff_sym])
 
 lemma nat_of_0 [simp]: "nat_of(#0) = 0"
 by (simp only: natify_0 int_of_0 [symmetric] nat_of_int_of)
 
 lemma nat_le_int0_lemma: "\<lbrakk>z $\<le> $#0; z \<in> int\<rbrakk> \<Longrightarrow> nat_of(z) = 0"
 by (auto simp add: znegative_iff_zless_0 [THEN iff_sym] zle_def zneg_nat_of)
 
 lemma nat_le_int0: "z $\<le> $#0 \<Longrightarrow> nat_of(z) = 0"
 apply (subgoal_tac "nat_of (intify (z)) = 0")
 apply (rule_tac [2] nat_le_int0_lemma, auto)
 done
 
 lemma int_of_eq_0_imp_natify_eq_0: "$# n = #0 \<Longrightarrow> natify(n) = 0"
 by (rule not_znegative_imp_zero, auto)
 
 lemma nat_of_zminus_int_of: "nat_of($- $# n) = 0"
 by (simp add: nat_of_def int_of_def raw_nat_of zminus image_intrel_int)
 
 lemma int_of_nat_of: "#0 $\<le> z \<Longrightarrow> $# nat_of(z) = intify(z)"
 apply (rule not_zneg_nat_of_intify)
 apply (simp add: znegative_iff_zless_0 not_zless_iff_zle)
 done
 
 declare int_of_nat_of [simp] nat_of_zminus_int_of [simp]
 
 lemma int_of_nat_of_if: "$# nat_of(z) = (if #0 $\<le> z then intify(z) else #0)"
 by (simp add: int_of_nat_of znegative_iff_zless_0 not_zle_iff_zless)
 
 lemma zless_nat_iff_int_zless: "\<lbrakk>m \<in> nat; z \<in> int\<rbrakk> \<Longrightarrow> (m < nat_of(z)) \<longleftrightarrow> ($#m $< z)"
 apply (case_tac "znegative (z) ")
 apply (erule_tac [2] not_zneg_nat_of [THEN subst])
 apply (auto dest: zless_trans dest!: zero_zle_int_of [THEN zle_zless_trans]
             simp add: znegative_iff_zless_0)
 done
 
 
 (** nat_of and zless **)
 
 (*An alternative condition is  @{term"$#0 \<subseteq> w"}  *)
 lemma zless_nat_conj_lemma: "$#0 $< z \<Longrightarrow> (nat_of(w) < nat_of(z)) \<longleftrightarrow> (w $< z)"
 apply (rule iff_trans)
 apply (rule zless_int_of [THEN iff_sym])
 apply (auto simp add: int_of_nat_of_if simp del: zless_int_of)
 apply (auto elim: zless_asym simp add: not_zle_iff_zless)
 apply (blast intro: zless_zle_trans)
 done
 
 lemma zless_nat_conj: "(nat_of(w) < nat_of(z)) \<longleftrightarrow> ($#0 $< z \<and> w $< z)"
 apply (case_tac "$#0 $< z")
 apply (auto simp add: zless_nat_conj_lemma nat_le_int0 not_zless_iff_zle)
 done
 
 (*This simprule cannot be added unless we can find a way to make eq_integ_of_eq
   unconditional!
   [The condition "True" is a hack to prevent looping.
     Conditional rewrite rules are tried after unconditional ones, so a rule
     like eq_nat_number_of will be tried first to eliminate #mm=#nn.]
   lemma integ_of_reorient [simp]:
        "True \<Longrightarrow> (integ_of(w) = x) \<longleftrightarrow> (x = integ_of(w))"
   by auto
 *)
 
 lemma integ_of_minus_reorient [simp]:
      "(integ_of(w) = $- x) \<longleftrightarrow> ($- x = integ_of(w))"
 by auto
 
 lemma integ_of_add_reorient [simp]:
      "(integ_of(w) = x $+ y) \<longleftrightarrow> (x $+ y = integ_of(w))"
 by auto
 
 lemma integ_of_diff_reorient [simp]:
      "(integ_of(w) = x $- y) \<longleftrightarrow> (x $- y = integ_of(w))"
 by auto
 
 lemma integ_of_mult_reorient [simp]:
      "(integ_of(w) = x $* y) \<longleftrightarrow> (x $* y = integ_of(w))"
 by auto
 
 (** To simplify inequalities involving integer negation and literals,
     such as -x = #3
 **)
 
 lemmas [simp] =
   zminus_equation [where y = "integ_of(w)"]
   equation_zminus [where x = "integ_of(w)"]
   for w
 
 lemmas [iff] =
   zminus_zless [where y = "integ_of(w)"]
   zless_zminus [where x = "integ_of(w)"]
   for w
 
 lemmas [iff] =
   zminus_zle [where y = "integ_of(w)"]
   zle_zminus [where x = "integ_of(w)"]
   for w
 
 lemmas [simp] =
   Let_def [where s = "integ_of(w)"] for w
 
 
 (*** Simprocs for numeric literals ***)
 
 (** Combining of literal coefficients in sums of products **)
 
 lemma zless_iff_zdiff_zless_0: "(x $< y) \<longleftrightarrow> (x$-y $< #0)"
   by (simp add: zcompare_rls)
 
 lemma eq_iff_zdiff_eq_0: "\<lbrakk>x \<in> int; y \<in> int\<rbrakk> \<Longrightarrow> (x = y) \<longleftrightarrow> (x$-y = #0)"
   by (simp add: zcompare_rls)
 
 lemma zle_iff_zdiff_zle_0: "(x $\<le> y) \<longleftrightarrow> (x$-y $\<le> #0)"
   by (simp add: zcompare_rls)
 
 
 (** For combine_numerals **)
 
 lemma left_zadd_zmult_distrib: "i$*u $+ (j$*u $+ k) = (i$+j)$*u $+ k"
   by (simp add: zadd_zmult_distrib zadd_ac)
 
 
 (** For cancel_numerals **)
 
 lemma eq_add_iff1: "(i$*u $+ m = j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m = intify(n))"
   apply (simp add: zdiff_def zadd_zmult_distrib)
   apply (simp add: zcompare_rls)
   apply (simp add: zadd_ac)
   done
 
 lemma eq_add_iff2: "(i$*u $+ m = j$*u $+ n) \<longleftrightarrow> (intify(m) = (j$-i)$*u $+ n)"
   apply (simp add: zdiff_def zadd_zmult_distrib)
   apply (simp add: zcompare_rls)
   apply (simp add: zadd_ac)
   done
 
 context fixes n :: i
 begin
 
 lemmas rel_iff_rel_0_rls =
   zless_iff_zdiff_zless_0 [where y = "u $+ v"]
   eq_iff_zdiff_eq_0 [where y = "u $+ v"]
   zle_iff_zdiff_zle_0 [where y = "u $+ v"]
   zless_iff_zdiff_zless_0 [where y = n]
   eq_iff_zdiff_eq_0 [where y = n]
   zle_iff_zdiff_zle_0 [where y = n]
   for u v
 
 lemma less_add_iff1: "(i$*u $+ m $< j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m $< n)"
   apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls)
   done
 
 lemma less_add_iff2: "(i$*u $+ m $< j$*u $+ n) \<longleftrightarrow> (m $< (j$-i)$*u $+ n)"
   apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls)
   done
 
 end
 
 lemma le_add_iff1: "(i$*u $+ m $\<le> j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m $\<le> n)"
   apply (simp add: zdiff_def zadd_zmult_distrib)
   apply (simp add: zcompare_rls)
   apply (simp add: zadd_ac)
   done
 
 lemma le_add_iff2: "(i$*u $+ m $\<le> j$*u $+ n) \<longleftrightarrow> (m $\<le> (j$-i)$*u $+ n)"
   apply (simp add: zdiff_def zadd_zmult_distrib)
   apply (simp add: zcompare_rls)
   apply (simp add: zadd_ac)
   done
 
 ML_file \<open>int_arith.ML\<close>
 
 subsection \<open>examples:\<close>
 
 text \<open>\<open>combine_numerals_prod\<close> (products of separate literals)\<close>
 lemma "#5 $* x $* #3 = y" apply simp oops
 
 schematic_goal "y2 $+ ?x42 = y $+ y2" apply simp oops
 
 lemma "oo : int \<Longrightarrow> l $+ (l $+ #2) $+ oo = oo" apply simp oops
 
 lemma "#9$*x $+ y = x$*#23 $+ z" apply simp oops
 lemma "y $+ x = x $+ z" apply simp oops
 
 lemma "x : int \<Longrightarrow> x $+ y $+ z = x $+ z" apply simp oops
 lemma "x : int \<Longrightarrow> y $+ (z $+ x) = z $+ x" apply simp oops
 lemma "z : int \<Longrightarrow> x $+ y $+ z = (z $+ y) $+ (x $+ w)" apply simp oops
 lemma "z : int \<Longrightarrow> x$*y $+ z = (z $+ y) $+ (y$*x $+ w)" apply simp oops
 
 lemma "#-3 $* x $+ y $\<le> x $* #2 $+ z" apply simp oops
 lemma "y $+ x $\<le> x $+ z" apply simp oops
 lemma "x $+ y $+ z $\<le> x $+ z" apply simp oops
 
 lemma "y $+ (z $+ x) $< z $+ x" apply simp oops
 lemma "x $+ y $+ z $< (z $+ y) $+ (x $+ w)" apply simp oops
 lemma "x$*y $+ z $< (z $+ y) $+ (y$*x $+ w)" apply simp oops
 
 lemma "l $+ #2 $+ #2 $+ #2 $+ (l $+ #2) $+ (oo $+ #2) = uu" apply simp oops
 lemma "u : int \<Longrightarrow> #2 $* u = u" apply simp oops
 lemma "(i $+ j $+ #12 $+ k) $- #15 = y" apply simp oops
 lemma "(i $+ j $+ #12 $+ k) $- #5 = y" apply simp oops
 
 lemma "y $- b $< b" apply simp oops
 lemma "y $- (#3 $* b $+ c) $< b $- #2 $* c" apply simp oops
 
 lemma "(#2 $* x $- (u $* v) $+ y) $- v $* #3 $* u = w" apply simp oops
 lemma "(#2 $* x $* u $* v $+ (u $* v) $* #4 $+ y) $- v $* u $* #4 = w" apply simp oops
 lemma "(#2 $* x $* u $* v $+ (u $* v) $* #4 $+ y) $- v $* u = w" apply simp oops
 lemma "u $* v $- (x $* u $* v $+ (u $* v) $* #4 $+ y) = w" apply simp oops
 
 lemma "(i $+ j $+ #12 $+ k) = u $+ #15 $+ y" apply simp oops
 lemma "(i $+ j $* #2 $+ #12 $+ k) = j $+ #5 $+ y" apply simp oops
 
 lemma "#2 $* y $+ #3 $* z $+ #6 $* w $+ #2 $* y $+ #3 $* z $+ #2 $* u = #2 $* y' $+ #3 $* z' $+ #6 $* w' $+ #2 $* y' $+ #3 $* z' $+ u $+ vv" apply simp oops
 
 lemma "a $+ $-(b$+c) $+ b = d" apply simp oops
 lemma "a $+ $-(b$+c) $- b = d" apply simp oops
 
 text \<open>negative numerals\<close>
 lemma "(i $+ j $+ #-2 $+ k) $- (u $+ #5 $+ y) = zz" apply simp oops
 lemma "(i $+ j $+ #-3 $+ k) $< u $+ #5 $+ y" apply simp oops
 lemma "(i $+ j $+ #3 $+ k) $< u $+ #-6 $+ y" apply simp oops
 lemma "(i $+ j $+ #-12 $+ k) $- #15 = y" apply simp oops
 lemma "(i $+ j $+ #12 $+ k) $- #-15 = y" apply simp oops
 lemma "(i $+ j $+ #-12 $+ k) $- #-15 = y" apply simp oops
 
 text \<open>Multiplying separated numerals\<close>
 lemma "#6 $* ($# x $* #2) =  uu" apply simp oops
 lemma "#4 $* ($# x $* $# x) $* (#2 $* $# x) =  uu" apply simp oops
 
 end
diff --git a/src/ZF/Cardinal.thy b/src/ZF/Cardinal.thy
--- a/src/ZF/Cardinal.thy
+++ b/src/ZF/Cardinal.thy
@@ -1,1180 +1,1180 @@
 (*  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\<Rightarrow>o) \<Rightarrow> i"    (binder \<open>\<mu> \<close> 10)  where
      "Least(P) \<equiv> THE i. Ord(i) \<and> P(i) \<and> (\<forall>j. j<i \<longrightarrow> \<not>P(j))"
 
 definition
   eqpoll   :: "[i,i] \<Rightarrow> o"     (infixl \<open>\<approx>\<close> 50)  where
     "A \<approx> B \<equiv> \<exists>f. f \<in> bij(A,B)"
 
 definition
   lepoll   :: "[i,i] \<Rightarrow> o"     (infixl \<open>\<lesssim>\<close> 50)  where
     "A \<lesssim> B \<equiv> \<exists>f. f \<in> inj(A,B)"
 
 definition
   lesspoll :: "[i,i] \<Rightarrow> o"     (infixl \<open>\<prec>\<close> 50)  where
     "A \<prec> B \<equiv> A \<lesssim> B \<and> \<not>(A \<approx> B)"
 
 definition
   cardinal :: "i\<Rightarrow>i"           (\<open>|_|\<close>)  where
     "|A| \<equiv> (\<mu> i. i \<approx> A)"
 
 definition
   Finite   :: "i\<Rightarrow>o"  where
     "Finite(A) \<equiv> \<exists>n\<in>nat. A \<approx> n"
 
 definition
   Card     :: "i\<Rightarrow>o"  where
     "Card(i) \<equiv> (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, \<lambda>W. X - g``(Y - f``W))"
 by (rule bnd_monoI, blast+)
 
 lemma Banach_last_equation:
     "g \<in> Y->X
      \<Longrightarrow> g``(Y - f`` lfp(X, \<lambda>W. X - g``(Y - f``W))) =
          X - lfp(X, \<lambda>W. X - g``(Y - f``W))"
 apply (rule_tac P = "\<lambda>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:
      "\<lbrakk>f \<in> X->Y;  g \<in> Y->X\<rbrakk> \<Longrightarrow>
       \<exists>XA XB YA YB. (XA \<inter> XB = 0) \<and> (XA \<union> XB = X) \<and>
                       (YA \<inter> YB = 0) \<and> (YA \<union> YB = Y) \<and>
                       f``XA=YA \<and> 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:
     "\<lbrakk>f \<in> inj(X,Y);  g \<in> inj(Y,X)\<rbrakk> \<Longrightarrow> \<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\<And>*)
 done
 
 
 (** Equipollence is an equivalence relation **)
 
 lemma bij_imp_eqpoll: "f \<in> bij(A,B) \<Longrightarrow> A \<approx> B"
   unfolding 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 \<Longrightarrow> Y \<approx> X"
   unfolding eqpoll_def
 apply (blast intro: bij_converse_bij)
 done
 
 lemma eqpoll_trans [trans]:
     "\<lbrakk>X \<approx> Y;  Y \<approx> Z\<rbrakk> \<Longrightarrow> X \<approx> Z"
   unfolding eqpoll_def
 apply (blast intro: comp_bij)
 done
 
 (** Le-pollence is a partial ordering **)
 
 lemma subset_imp_lepoll: "X<=Y \<Longrightarrow> X \<lesssim> Y"
   unfolding 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 \<Longrightarrow> X \<lesssim> Y"
 by (unfold eqpoll_def bij_def lepoll_def, blast)
 
 lemma lepoll_trans [trans]: "\<lbrakk>X \<lesssim> Y;  Y \<lesssim> Z\<rbrakk> \<Longrightarrow> X \<lesssim> Z"
   unfolding lepoll_def
 apply (blast intro: comp_inj)
 done
 
 lemma eq_lepoll_trans [trans]: "\<lbrakk>X \<approx> Y;  Y \<lesssim> Z\<rbrakk> \<Longrightarrow> X \<lesssim> Z"
  by (blast intro: eqpoll_imp_lepoll lepoll_trans)
 
 lemma lepoll_eq_trans [trans]: "\<lbrakk>X \<lesssim> Y;  Y \<approx> Z\<rbrakk> \<Longrightarrow> X \<lesssim> Z"
  by (blast intro: eqpoll_imp_lepoll lepoll_trans)
 
 (*Asymmetry law*)
 lemma eqpollI: "\<lbrakk>X \<lesssim> Y;  Y \<lesssim> X\<rbrakk> \<Longrightarrow> X \<approx> Y"
-apply (unfold lepoll_def eqpoll_def)
+  unfolding lepoll_def eqpoll_def
 apply (elim exE)
 apply (rule schroeder_bernstein, assumption+)
 done
 
 lemma eqpollE:
     "\<lbrakk>X \<approx> Y; \<lbrakk>X \<lesssim> Y; Y \<lesssim> X\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
 by (blast intro: eqpoll_imp_lepoll eqpoll_sym)
 
 lemma eqpoll_iff: "X \<approx> Y \<longleftrightarrow> X \<lesssim> Y \<and> Y \<lesssim> X"
 by (blast intro: eqpollI elim!: eqpollE)
 
 lemma lepoll_0_is_0: "A \<lesssim> 0 \<Longrightarrow> A = 0"
-apply (unfold lepoll_def inj_def)
+  unfolding 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:
     "\<lbrakk>A \<lesssim> B; C \<lesssim> D; B \<inter> D = 0\<rbrakk> \<Longrightarrow> A \<union> C \<lesssim> B \<union> D"
   unfolding lepoll_def
 apply (blast intro: inj_disjoint_Un)
 done
 
 (*A \<approx> 0 \<Longrightarrow> 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:
     "\<lbrakk>A \<approx> B;  C \<approx> D;  A \<inter> C = 0;  B \<inter> D = 0\<rbrakk>
      \<Longrightarrow> A \<union> C \<approx> B \<union> D"
   unfolding eqpoll_def
 apply (blast intro: bij_disjoint_Un)
 done
 
 
 subsection\<open>lesspoll: contributions by Krzysztof Grabczewski\<close>
 
 lemma lesspoll_not_refl: "\<not> (i \<prec> i)"
 by (simp add: lesspoll_def)
 
 lemma lesspoll_irrefl [elim!]: "i \<prec> i \<Longrightarrow> P"
 by (simp add: lesspoll_def)
 
 lemma lesspoll_imp_lepoll: "A \<prec> B \<Longrightarrow> A \<lesssim> B"
 by (unfold lesspoll_def, blast)
 
 lemma lepoll_well_ord: "\<lbrakk>A \<lesssim> B; well_ord(B,r)\<rbrakk> \<Longrightarrow> \<exists>s. well_ord(A,s)"
   unfolding lepoll_def
 apply (blast intro: well_ord_rvimage)
 done
 
 lemma lepoll_iff_leqpoll: "A \<lesssim> B \<longleftrightarrow> A \<prec> B | A \<approx> B"
   unfolding 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]:
       "\<lbrakk>X \<prec> Y; Y \<prec> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
   unfolding lesspoll_def
 apply (blast elim!: eqpollE intro: eqpollI lepoll_trans)
 done
 
 lemma lesspoll_trans1 [trans]:
       "\<lbrakk>X \<lesssim> Y; Y \<prec> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
   unfolding lesspoll_def
 apply (blast elim!: eqpollE intro: eqpollI lepoll_trans)
 done
 
 lemma lesspoll_trans2 [trans]:
       "\<lbrakk>X \<prec> Y; Y \<lesssim> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
   unfolding lesspoll_def
 apply (blast elim!: eqpollE intro: eqpollI lepoll_trans)
 done
 
 lemma eq_lesspoll_trans [trans]:
       "\<lbrakk>X \<approx> Y; Y \<prec> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
   by (blast intro: eqpoll_imp_lepoll lesspoll_trans1)
 
 lemma lesspoll_eq_trans [trans]:
       "\<lbrakk>X \<prec> Y; Y \<approx> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
   by (blast intro: eqpoll_imp_lepoll lesspoll_trans2)
 
 
 (** \<mu> -- the least number operator [from HOL/Univ.ML] **)
 
 lemma Least_equality:
     "\<lbrakk>P(i);  Ord(i);  \<And>x. x<i \<Longrightarrow> \<not>P(x)\<rbrakk> \<Longrightarrow> (\<mu> x. P(x)) = i"
   unfolding 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> \<not>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> \<not> (\<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: "\<lbrakk>P(i);  i < (\<mu> x. P(x))\<rbrakk> \<Longrightarrow> 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:
     "\<lbrakk>P(i);  Ord(i);  \<And>j. P(j) \<Longrightarrow> Q(j)\<rbrakk> \<Longrightarrow> Q(\<mu> j. P(j))"
 by (blast intro: LeastI )
 
 (*If there is no such P then \<mu> is vacuously 0*)
 lemma Least_0:
     "\<lbrakk>\<not> (\<exists>i. Ord(i) \<and> P(i))\<rbrakk> \<Longrightarrow> (\<mu> x. P(x)) = 0"
   unfolding 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) \<and> 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: "(\<And>y. P(y) \<longleftrightarrow> Q(y)) \<Longrightarrow> (\<mu> x. P(x)) = (\<mu> x. Q(x))"
 by simp
 
 (*Need AC to get @{term"X \<lesssim> Y \<Longrightarrow> |X| \<le> |Y|"};  see well_ord_lepoll_imp_cardinal_le
   Converse also requires AC, but see well_ord_cardinal_eqE*)
 lemma cardinal_cong: "X \<approx> Y \<Longrightarrow> |X| = |Y|"
-apply (unfold eqpoll_def cardinal_def)
+  unfolding 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) \<Longrightarrow> |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:
      "\<lbrakk>well_ord(X,r);  well_ord(Y,s)\<rbrakk> \<Longrightarrow> |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) \<Longrightarrow> |i| \<le> i"
   unfolding cardinal_def
 apply (erule eqpoll_refl [THEN Least_le])
 done
 
 lemma Card_cardinal_eq: "Card(K) \<Longrightarrow> |K| = K"
   unfolding Card_def
 apply (erule sym)
 done
 
 (* Could replace the  @{term"\<not>(j \<approx> i)"}  by  @{term"\<not>(i \<preceq> j)"}. *)
 lemma CardI: "\<lbrakk>Ord(i);  \<And>j. j<i \<Longrightarrow> \<not>(j \<approx> i)\<rbrakk> \<Longrightarrow> Card(i)"
-apply (unfold Card_def cardinal_def)
+  unfolding Card_def cardinal_def
 apply (subst Least_equality)
 apply (blast intro: eqpoll_refl)+
 done
 
 lemma Card_is_Ord: "Card(i) \<Longrightarrow> Ord(i)"
-apply (unfold Card_def cardinal_def)
+  unfolding Card_def cardinal_def
 apply (erule ssubst)
 apply (rule Ord_Least)
 done
 
 lemma Card_cardinal_le: "Card(K) \<Longrightarrow> K \<le> |K|"
 apply (simp (no_asm_simp) add: Card_is_Ord Card_cardinal_eq)
 done
 
 lemma Ord_cardinal [simp,intro!]: "Ord(|A|)"
   unfolding 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) \<and> (\<forall>j. j<K \<longrightarrow> \<not> 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: "\<lbrakk>Card(a); i<a\<rbrakk> \<Longrightarrow> i \<prec> a"
   unfolding 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: "\<lbrakk>Card(K);  Card(L)\<rbrakk> \<Longrightarrow> 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) \<and> 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: "\<lbrakk>|i| < |j|;  Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> 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: "\<lbrakk>|i| < K;  Ord(i);  Card(K)\<rbrakk> \<Longrightarrow> i < K"
   by (simp (no_asm_simp) add: cardinal_lt_imp_lt Card_is_Ord Card_cardinal_eq)
 
 lemma Card_lt_iff: "\<lbrakk>Ord(i);  Card(K)\<rbrakk> \<Longrightarrow> (|i| < K) \<longleftrightarrow> (i < K)"
 by (blast intro: Card_lt_imp_lt Ord_cardinal_le [THEN lt_trans1])
 
 lemma Card_le_iff: "\<lbrakk>Ord(i);  Card(K)\<rbrakk> \<Longrightarrow> (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_cardinal_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: "\<lbrakk>A \<lesssim> i; Ord(i)\<rbrakk> \<Longrightarrow> |A| \<le> i"
 apply (rule le_trans)
 apply (erule well_ord_Memrel [THEN well_ord_lepoll_imp_cardinal_le], assumption)
 apply (erule Ord_cardinal_le)
 done
 
 lemma lepoll_Ord_imp_eqpoll: "\<lbrakk>A \<lesssim> i; Ord(i)\<rbrakk> \<Longrightarrow> |A| \<approx> A"
 by (blast intro: lepoll_cardinal_le well_ord_Memrel well_ord_cardinal_eqpoll dest!: lepoll_well_ord)
 
 lemma lesspoll_imp_eqpoll: "\<lbrakk>A \<prec> i; Ord(i)\<rbrakk> \<Longrightarrow> |A| \<approx> A"
   unfolding lesspoll_def
 apply (blast intro: lepoll_Ord_imp_eqpoll)
 done
 
 lemma cardinal_subset_Ord: "\<lbrakk>A<=i; Ord(i)\<rbrakk> \<Longrightarrow> |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:
  "\<lbrakk>cons(u,A) \<lesssim> cons(v,B);  u\<notin>A;  v\<notin>B\<rbrakk> \<Longrightarrow> 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: "\<lbrakk>cons(u,A) \<approx> cons(v,B);  u\<notin>A;  v\<notin>B\<rbrakk> \<Longrightarrow> 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) \<Longrightarrow> m \<lesssim> n"
   unfolding succ_def
 apply (erule cons_lepoll_consD)
 apply (rule mem_not_refl)+
 done
 
 
 lemma nat_lepoll_imp_le:
      "m \<in> nat \<Longrightarrow> 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: "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow> 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: "\<lbrakk>succ(n) \<lesssim> n;  n \<in> nat\<rbrakk> \<Longrightarrow> P"
 by (rule nat_lepoll_imp_le [THEN lt_irrefl], auto)
 
 lemma nat_lepoll_imp_ex_eqpoll_n:
      "\<lbrakk>n \<in> nat;  nat \<lesssim> X\<rbrakk> \<Longrightarrow> \<exists>Y. Y \<subseteq> X \<and> n \<approx> Y"
-apply (unfold lepoll_def eqpoll_def)
+  unfolding 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:
      "\<lbrakk>A \<prec> succ(m); m \<in> nat\<rbrakk> \<Longrightarrow> A \<lesssim> m"
-apply (unfold lesspoll_def lepoll_def eqpoll_def bij_def)
+  unfolding lesspoll_def lepoll_def eqpoll_def bij_def
 apply (auto dest: inj_not_surj_succ)
 done
 
 lemma lesspoll_succ_iff: "m \<in> nat \<Longrightarrow> A \<prec> succ(m) \<longleftrightarrow> A \<lesssim> m"
 by (blast intro!: lepoll_imp_lesspoll_succ lesspoll_succ_imp_lepoll)
 
 lemma lepoll_succ_disj: "\<lbrakk>A \<lesssim> succ(m);  m \<in> nat\<rbrakk> \<Longrightarrow> 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: "\<lbrakk>A \<prec> i; Ord(i)\<rbrakk> \<Longrightarrow> |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 "\<not> 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  "\<not> i \<lesssim> n" using n  by (rule lt_not_lepoll)
   hence  "\<not> 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 "\<not> 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 \<Longrightarrow> 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 \<Longrightarrow> 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:
     "\<lbrakk>A \<lesssim> B;  b \<notin> B\<rbrakk> \<Longrightarrow> 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 = "\<lambda>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:
      "\<lbrakk>A \<approx> B;  a \<notin> A;  b \<notin> B\<rbrakk> \<Longrightarrow> cons(a,A) \<approx> cons(b,B)"
 by (simp add: eqpoll_iff cons_lepoll_cong)
 
 lemma cons_lepoll_cons_iff:
      "\<lbrakk>a \<notin> A;  b \<notin> B\<rbrakk> \<Longrightarrow> 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:
      "\<lbrakk>a \<notin> A;  b \<notin> B\<rbrakk> \<Longrightarrow> 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"
   unfolding 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 \<Longrightarrow> 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= "\<lambda>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 \<Longrightarrow> succ(A) \<approx> succ(B)"
   unfolding succ_def
 apply (simp add: cons_eqpoll_cong mem_not_refl)
 done
 
 (*Congruence law for + under equipollence*)
 lemma sum_eqpoll_cong: "\<lbrakk>A \<approx> C;  B \<approx> D\<rbrakk> \<Longrightarrow> A+B \<approx> C+D"
   unfolding eqpoll_def
 apply (blast intro!: sum_bij)
 done
 
 (*Congruence law for * under equipollence*)
 lemma prod_eqpoll_cong:
     "\<lbrakk>A \<approx> C;  B \<approx> D\<rbrakk> \<Longrightarrow> A*B \<approx> C*D"
   unfolding eqpoll_def
 apply (blast intro!: prod_bij)
 done
 
 lemma inj_disjoint_eqpoll:
     "\<lbrakk>f \<in> inj(A,B);  A \<inter> B = 0\<rbrakk> \<Longrightarrow> A \<union> (B - range(f)) \<approx> B"
   unfolding eqpoll_def
 apply (rule exI)
 apply (rule_tac c = "\<lambda>x. if x \<in> A then f`x else x"
             and d = "\<lambda>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:
       "\<lbrakk>a \<in> A;  A \<lesssim> succ(n)\<rbrakk> \<Longrightarrow> A - {a} \<lesssim> n"
   unfolding 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: "\<lbrakk>a \<in> A; A \<approx> succ(n)\<rbrakk> \<Longrightarrow> A - {a} \<approx> n"
 by (blast intro!: eqpollI
           elim!: eqpollE
           intro: Diff_sing_lepoll lepoll_Diff_sing)
 
 lemma lepoll_1_is_sing: "\<lbrakk>A \<lesssim> 1; a \<in> A\<rbrakk> \<Longrightarrow> 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"
   unfolding 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 = "\<lambda>z. snd (z)" in lam_injective)
 apply force
 apply (simp add: Inl_def Inr_def)
 done
 
 lemma well_ord_Un:
      "\<lbrakk>well_ord(X,R); well_ord(Y,S)\<rbrakk> \<Longrightarrow> \<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 \<Longrightarrow> A \<union> B \<approx> A + B"
   unfolding 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 = "\<lambda>z. case (\<lambda>x. x, \<lambda>x. x, z)" in lam_bijective)
 apply auto
 done
 
 
 subsection \<open>Finite and infinite sets\<close>
 
 lemma eqpoll_imp_Finite_iff: "A \<approx> B \<Longrightarrow> Finite(A) \<longleftrightarrow> Finite(B)"
   unfolding Finite_def
 apply (blast intro: eqpoll_trans eqpoll_sym)
 done
 
 lemma Finite_0 [simp]: "Finite(0)"
   unfolding Finite_def
 apply (blast intro!: eqpoll_refl nat_0I)
 done
 
 lemma Finite_cons: "Finite(x) \<Longrightarrow> Finite(cons(y,x))"
   unfolding 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) \<Longrightarrow> Finite(succ(x))"
   unfolding 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 \<Longrightarrow> Finite(A)"
   unfolding 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) \<Longrightarrow> Finite(A \<inter> B)"
 by (blast intro: subset_Finite)
 
 lemmas Finite_Diff = Diff_subset [THEN subset_Finite]
 
 lemma nat_le_infinite_Ord:
       "\<lbrakk>Ord(i);  \<not> Finite(i)\<rbrakk> \<Longrightarrow> nat \<le> i"
   unfolding 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) \<Longrightarrow> \<exists>r. well_ord(A,r)"
-apply (unfold Finite_def eqpoll_def)
+  unfolding 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 \<Longrightarrow> y \<noteq> 0"
 by (fast dest!: lepoll_0_is_0)
 
 lemma eqpoll_succ_imp_not_empty: "x \<approx> succ(n) \<Longrightarrow> 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 \<Longrightarrow> \<forall>A. (A\<approx>n \<and> 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: "\<lbrakk>Finite(A); A \<subseteq> X\<rbrakk> \<Longrightarrow> A \<in> Fin(X)"
 by (unfold Finite_def, blast intro: Finite_Fin_lemma)
 
 lemma Fin_lemma [rule_format]: "n \<in> nat \<Longrightarrow> \<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*)
   unfolding eqpoll_def
 apply (blast intro: bij_converse_bij [THEN bij_is_fun, THEN apply_type])
 done
 
 lemma Finite_into_Fin: "Finite(A) \<Longrightarrow> A \<in> Fin(A)"
   unfolding Finite_def
 apply (blast intro: Fin_lemma)
 done
 
 lemma Fin_into_Finite: "A \<in> Fin(U) \<Longrightarrow> 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: "\<lbrakk>Finite(A); Finite(B)\<rbrakk> \<Longrightarrow> 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) \<and> Finite(B))"
 by (blast intro: subset_Finite Finite_Un)
 
 text\<open>The converse must hold too.\<close>
 lemma Finite_Union: "\<lbrakk>\<forall>y\<in>X. Finite(y);  Finite(X)\<rbrakk> \<Longrightarrow> 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]:
 "\<lbrakk>Finite(A); P(0);
     \<And>x B.   \<lbrakk>Finite(B); x \<notin> B; P(B)\<rbrakk> \<Longrightarrow> P(cons(x, B))\<rbrakk>
  \<Longrightarrow> P(A)"
 apply (erule Finite_into_Fin [THEN Fin_induct])
 apply (blast intro: Fin_into_Finite)+
 done
 
 (*Sidi Ehmety.  The contrapositive says \<not>Finite(A) \<Longrightarrow> \<not>Finite(A-{a}) *)
 lemma Diff_sing_Finite: "Finite(A - {a}) \<Longrightarrow> Finite(A)"
   unfolding 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 \<and> 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
    \<lbrakk>\<not>Finite(A); Finite(B)\<rbrakk> \<Longrightarrow> \<not>Finite(A-B) *)
 lemma Diff_Finite [rule_format]: "Finite(B) \<Longrightarrow> 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) \<Longrightarrow> Finite(RepFun(A,f))"
 by (erule Finite_induct, simp_all)
 
 lemma Finite_RepFun_iff_lemma [rule_format]:
      "\<lbrakk>Finite(x); \<And>x y. f(x)=f(y) \<Longrightarrow> x=y\<rbrakk>
       \<Longrightarrow> \<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) \<Longrightarrow> Finite(RepFun(A,f)) \<longleftrightarrow> Finite(A)"
 by (blast intro: Finite_RepFun Finite_RepFun_iff_lemma [of _ f])
 
 lemma Finite_Pow: "Finite(A) \<Longrightarrow> 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)) \<Longrightarrow> 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 \<Longrightarrow> 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 \<Longrightarrow> 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:
      "\<lbrakk>well_ord(A,r);
         well_ord(ordertype(A,r), converse(Memrel(ordertype(A, r))))\<rbrakk>
       \<Longrightarrow> 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:
     "\<lbrakk>Finite(A);  well_ord(A,r)\<rbrakk> \<Longrightarrow> well_ord(A,converse(r))"
   unfolding 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 \<Longrightarrow> Finite(n)"
   by (auto simp add: Finite_def intro: eqpoll_refl) 
 
 lemma nat_not_Finite: "\<not> 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
diff --git a/src/ZF/CardinalArith.thy b/src/ZF/CardinalArith.thy
--- a/src/ZF/CardinalArith.thy
+++ b/src/ZF/CardinalArith.thy
@@ -1,940 +1,940 @@
 (*  Title:      ZF/CardinalArith.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section\<open>Cardinal Arithmetic Without the Axiom of Choice\<close>
 
 theory CardinalArith imports Cardinal OrderArith ArithSimp Finite begin
 
 definition
   InfCard       :: "i\<Rightarrow>o"  where
     "InfCard(i) \<equiv> Card(i) \<and> nat \<le> i"
 
 definition
   cmult         :: "[i,i]\<Rightarrow>i"       (infixl \<open>\<otimes>\<close> 70)  where
     "i \<otimes> j \<equiv> |i*j|"
 
 definition
   cadd          :: "[i,i]\<Rightarrow>i"       (infixl \<open>\<oplus>\<close> 65)  where
     "i \<oplus> j \<equiv> |i+j|"
 
 definition
   csquare_rel   :: "i\<Rightarrow>i"  where
     "csquare_rel(K) \<equiv>
           rvimage(K*K,
                   lam \<langle>x,y\<rangle>:K*K. <x \<union> y, x, y>,
                   rmult(K,Memrel(K), K*K, rmult(K,Memrel(K), K,Memrel(K))))"
 
 definition
   jump_cardinal :: "i\<Rightarrow>i"  where
     \<comment> \<open>This definition is more complex than Kunen's but it more easily proved to
         be a cardinal\<close>
     "jump_cardinal(K) \<equiv>
          \<Union>X\<in>Pow(K). {z. r \<in> Pow(K*K), well_ord(X,r) \<and> z = ordertype(X,r)}"
 
 definition
   csucc         :: "i\<Rightarrow>i"  where
     \<comment> \<open>needed because \<^term>\<open>jump_cardinal(K)\<close> might not be the successor
         of \<^term>\<open>K\<close>\<close>
     "csucc(K) \<equiv> \<mu> L. Card(L) \<and> K<L"
 
 
 lemma Card_Union [simp,intro,TC]:
   assumes A: "\<And>x. x\<in>A \<Longrightarrow> Card(x)" shows "Card(\<Union>(A))"
 proof (rule CardI)
   show "Ord(\<Union>A)" using A
     by (simp add: Card_is_Ord)
 next
   fix j
   assume j: "j < \<Union>A"
   hence "\<exists>c\<in>A. j < c \<and> Card(c)" using A
     by (auto simp add: lt_def intro: Card_is_Ord)
   then obtain c where c: "c\<in>A" "j < c" "Card(c)"
     by blast
   hence jls: "j \<prec> c"
     by (simp add: lt_Card_imp_lesspoll)
   { assume eqp: "j \<approx> \<Union>A"
     have  "c \<lesssim> \<Union>A" using c
       by (blast intro: subset_imp_lepoll)
     also have "... \<approx> j"  by (rule eqpoll_sym [OF eqp])
     also have "... \<prec> c"  by (rule jls)
     finally have "c \<prec> c" .
     hence False
       by auto
   } thus "\<not> j \<approx> \<Union>A" by blast
 qed
 
 lemma Card_UN: "(\<And>x. x \<in> A \<Longrightarrow> Card(K(x))) \<Longrightarrow> Card(\<Union>x\<in>A. K(x))"
   by blast
 
 lemma Card_OUN [simp,intro,TC]:
      "(\<And>x. x \<in> A \<Longrightarrow> Card(K(x))) \<Longrightarrow> Card(\<Union>x<A. K(x))"
   by (auto simp add: OUnion_def Card_0)
 
 lemma in_Card_imp_lesspoll: "\<lbrakk>Card(K); b \<in> K\<rbrakk> \<Longrightarrow> b \<prec> K"
   unfolding lesspoll_def
 apply (simp add: Card_iff_initial)
 apply (fast intro!: le_imp_lepoll ltI leI)
 done
 
 
 subsection\<open>Cardinal addition\<close>
 
 text\<open>Note: Could omit proving the algebraic laws for cardinal addition and
 multiplication.  On finite cardinals these operations coincide with
 addition and multiplication of natural numbers; on infinite cardinals they
 coincide with union (maximum).  Either way we get most laws for free.\<close>
 
 subsubsection\<open>Cardinal addition is commutative\<close>
 
 lemma sum_commute_eqpoll: "A+B \<approx> B+A"
 proof (unfold eqpoll_def, rule exI)
   show "(\<lambda>z\<in>A+B. case(Inr,Inl,z)) \<in> bij(A+B, B+A)"
     by (auto intro: lam_bijective [where d = "case(Inr,Inl)"])
 qed
 
 lemma cadd_commute: "i \<oplus> j = j \<oplus> i"
   unfolding cadd_def
 apply (rule sum_commute_eqpoll [THEN cardinal_cong])
 done
 
 subsubsection\<open>Cardinal addition is associative\<close>
 
 lemma sum_assoc_eqpoll: "(A+B)+C \<approx> A+(B+C)"
   unfolding eqpoll_def
 apply (rule exI)
 apply (rule sum_assoc_bij)
 done
 
 text\<open>Unconditional version requires AC\<close>
 lemma well_ord_cadd_assoc:
   assumes i: "well_ord(i,ri)" and j: "well_ord(j,rj)" and k: "well_ord(k,rk)"
   shows "(i \<oplus> j) \<oplus> k = i \<oplus> (j \<oplus> k)"
 proof (unfold cadd_def, rule cardinal_cong)
   have "|i + j| + k \<approx> (i + j) + k"
     by (blast intro: sum_eqpoll_cong well_ord_cardinal_eqpoll eqpoll_refl well_ord_radd i j)
   also have "...  \<approx> i + (j + k)"
     by (rule sum_assoc_eqpoll)
   also have "...  \<approx> i + |j + k|"
     by (blast intro: sum_eqpoll_cong well_ord_cardinal_eqpoll eqpoll_refl well_ord_radd j k eqpoll_sym)
   finally show "|i + j| + k \<approx> i + |j + k|" .
 qed
 
 
 subsubsection\<open>0 is the identity for addition\<close>
 
 lemma sum_0_eqpoll: "0+A \<approx> A"
   unfolding eqpoll_def
 apply (rule exI)
 apply (rule bij_0_sum)
 done
 
 lemma cadd_0 [simp]: "Card(K) \<Longrightarrow> 0 \<oplus> K = K"
   unfolding cadd_def
 apply (simp add: sum_0_eqpoll [THEN cardinal_cong] Card_cardinal_eq)
 done
 
 subsubsection\<open>Addition by another cardinal\<close>
 
 lemma sum_lepoll_self: "A \<lesssim> A+B"
 proof (unfold lepoll_def, rule exI)
   show "(\<lambda>x\<in>A. Inl (x)) \<in> inj(A, A + B)"
     by (simp add: inj_def)
 qed
 
 (*Could probably weaken the premises to well_ord(K,r), or removing using AC*)
 
 lemma cadd_le_self:
   assumes K: "Card(K)" and L: "Ord(L)" shows "K \<le> (K \<oplus> L)"
 proof (unfold cadd_def)
   have "K \<le> |K|"
     by (rule Card_cardinal_le [OF K])
   moreover have "|K| \<le> |K + L|" using K L
     by (blast intro: well_ord_lepoll_imp_cardinal_le sum_lepoll_self
                      well_ord_radd well_ord_Memrel Card_is_Ord)
   ultimately show "K \<le> |K + L|"
     by (blast intro: le_trans)
 qed
 
 subsubsection\<open>Monotonicity of addition\<close>
 
 lemma sum_lepoll_mono:
      "\<lbrakk>A \<lesssim> C;  B \<lesssim> D\<rbrakk> \<Longrightarrow> A + B \<lesssim> C + D"
   unfolding lepoll_def
 apply (elim exE)
 apply (rule_tac x = "\<lambda>z\<in>A+B. case (\<lambda>w. Inl(f`w), \<lambda>y. Inr(fa`y), z)" in exI)
 apply (rule_tac d = "case (\<lambda>w. Inl(converse(f) `w), \<lambda>y. Inr(converse(fa) ` y))"
        in lam_injective)
 apply (typecheck add: inj_is_fun, auto)
 done
 
 lemma cadd_le_mono:
     "\<lbrakk>K' \<le> K;  L' \<le> L\<rbrakk> \<Longrightarrow> (K' \<oplus> L') \<le> (K \<oplus> L)"
   unfolding cadd_def
 apply (safe dest!: le_subset_iff [THEN iffD1])
 apply (rule well_ord_lepoll_imp_cardinal_le)
 apply (blast intro: well_ord_radd well_ord_Memrel)
 apply (blast intro: sum_lepoll_mono subset_imp_lepoll)
 done
 
 subsubsection\<open>Addition of finite cardinals is "ordinary" addition\<close>
 
 lemma sum_succ_eqpoll: "succ(A)+B \<approx> succ(A+B)"
   unfolding eqpoll_def
 apply (rule exI)
 apply (rule_tac c = "\<lambda>z. if z=Inl (A) then A+B else z"
             and d = "\<lambda>z. if z=A+B then Inl (A) else z" in lam_bijective)
    apply simp_all
 apply (blast dest: sym [THEN eq_imp_not_mem] elim: mem_irrefl)+
 done
 
 (*Pulling the  succ(...)  outside the |...| requires m, n \<in> nat  *)
 (*Unconditional version requires AC*)
 lemma cadd_succ_lemma:
   assumes "Ord(m)" "Ord(n)" shows "succ(m) \<oplus> n = |succ(m \<oplus> n)|"
 proof (unfold cadd_def)
   have [intro]: "m + n \<approx> |m + n|" using assms
     by (blast intro: eqpoll_sym well_ord_cardinal_eqpoll well_ord_radd well_ord_Memrel)
 
   have "|succ(m) + n| = |succ(m + n)|"
     by (rule sum_succ_eqpoll [THEN cardinal_cong])
   also have "... = |succ(|m + n|)|"
     by (blast intro: succ_eqpoll_cong cardinal_cong)
   finally show "|succ(m) + n| = |succ(|m + n|)|" .
 qed
 
 lemma nat_cadd_eq_add:
   assumes m: "m \<in> nat" and [simp]: "n \<in> nat" shows"m \<oplus> n = m #+ n"
 using m
 proof (induct m)
   case 0 thus ?case by (simp add: nat_into_Card cadd_0)
 next
   case (succ m) thus ?case by (simp add: cadd_succ_lemma nat_into_Card Card_cardinal_eq)
 qed
 
 
 subsection\<open>Cardinal multiplication\<close>
 
 subsubsection\<open>Cardinal multiplication is commutative\<close>
 
 lemma prod_commute_eqpoll: "A*B \<approx> B*A"
   unfolding eqpoll_def
 apply (rule exI)
 apply (rule_tac c = "\<lambda>\<langle>x,y\<rangle>.\<langle>y,x\<rangle>" and d = "\<lambda>\<langle>x,y\<rangle>.\<langle>y,x\<rangle>" in lam_bijective,
        auto)
 done
 
 lemma cmult_commute: "i \<otimes> j = j \<otimes> i"
   unfolding cmult_def
 apply (rule prod_commute_eqpoll [THEN cardinal_cong])
 done
 
 subsubsection\<open>Cardinal multiplication is associative\<close>
 
 lemma prod_assoc_eqpoll: "(A*B)*C \<approx> A*(B*C)"
   unfolding eqpoll_def
 apply (rule exI)
 apply (rule prod_assoc_bij)
 done
 
 text\<open>Unconditional version requires AC\<close>
 lemma well_ord_cmult_assoc:
   assumes i: "well_ord(i,ri)" and j: "well_ord(j,rj)" and k: "well_ord(k,rk)"
   shows "(i \<otimes> j) \<otimes> k = i \<otimes> (j \<otimes> k)"
 proof (unfold cmult_def, rule cardinal_cong)
   have "|i * j| * k \<approx> (i * j) * k"
     by (blast intro: prod_eqpoll_cong well_ord_cardinal_eqpoll eqpoll_refl well_ord_rmult i j)
   also have "...  \<approx> i * (j * k)"
     by (rule prod_assoc_eqpoll)
   also have "...  \<approx> i * |j * k|"
     by (blast intro: prod_eqpoll_cong well_ord_cardinal_eqpoll eqpoll_refl well_ord_rmult j k eqpoll_sym)
   finally show "|i * j| * k \<approx> i * |j * k|" .
 qed
 
 subsubsection\<open>Cardinal multiplication distributes over addition\<close>
 
 lemma sum_prod_distrib_eqpoll: "(A+B)*C \<approx> (A*C)+(B*C)"
   unfolding eqpoll_def
 apply (rule exI)
 apply (rule sum_prod_distrib_bij)
 done
 
 lemma well_ord_cadd_cmult_distrib:
   assumes i: "well_ord(i,ri)" and j: "well_ord(j,rj)" and k: "well_ord(k,rk)"
   shows "(i \<oplus> j) \<otimes> k = (i \<otimes> k) \<oplus> (j \<otimes> k)"
 proof (unfold cadd_def cmult_def, rule cardinal_cong)
   have "|i + j| * k \<approx> (i + j) * k"
     by (blast intro: prod_eqpoll_cong well_ord_cardinal_eqpoll eqpoll_refl well_ord_radd i j)
   also have "...  \<approx> i * k + j * k"
     by (rule sum_prod_distrib_eqpoll)
   also have "...  \<approx> |i * k| + |j * k|"
     by (blast intro: sum_eqpoll_cong well_ord_cardinal_eqpoll well_ord_rmult i j k eqpoll_sym)
   finally show "|i + j| * k \<approx> |i * k| + |j * k|" .
 qed
 
 subsubsection\<open>Multiplication by 0 yields 0\<close>
 
 lemma prod_0_eqpoll: "0*A \<approx> 0"
   unfolding eqpoll_def
 apply (rule exI)
 apply (rule lam_bijective, safe)
 done
 
 lemma cmult_0 [simp]: "0 \<otimes> i = 0"
 by (simp add: cmult_def prod_0_eqpoll [THEN cardinal_cong])
 
 subsubsection\<open>1 is the identity for multiplication\<close>
 
 lemma prod_singleton_eqpoll: "{x}*A \<approx> A"
   unfolding eqpoll_def
 apply (rule exI)
 apply (rule singleton_prod_bij [THEN bij_converse_bij])
 done
 
 lemma cmult_1 [simp]: "Card(K) \<Longrightarrow> 1 \<otimes> K = K"
-apply (unfold cmult_def succ_def)
+  unfolding cmult_def succ_def
 apply (simp add: prod_singleton_eqpoll [THEN cardinal_cong] Card_cardinal_eq)
 done
 
 subsection\<open>Some inequalities for multiplication\<close>
 
 lemma prod_square_lepoll: "A \<lesssim> A*A"
-apply (unfold lepoll_def inj_def)
+  unfolding lepoll_def inj_def
 apply (rule_tac x = "\<lambda>x\<in>A. \<langle>x,x\<rangle>" in exI, simp)
 done
 
 (*Could probably weaken the premise to well_ord(K,r), or remove using AC*)
 lemma cmult_square_le: "Card(K) \<Longrightarrow> K \<le> K \<otimes> K"
   unfolding cmult_def
 apply (rule le_trans)
 apply (rule_tac [2] well_ord_lepoll_imp_cardinal_le)
 apply (rule_tac [3] prod_square_lepoll)
 apply (simp add: le_refl Card_is_Ord Card_cardinal_eq)
 apply (blast intro: well_ord_rmult well_ord_Memrel Card_is_Ord)
 done
 
 subsubsection\<open>Multiplication by a non-zero cardinal\<close>
 
 lemma prod_lepoll_self: "b \<in> B \<Longrightarrow> A \<lesssim> A*B"
-apply (unfold lepoll_def inj_def)
+  unfolding lepoll_def inj_def
 apply (rule_tac x = "\<lambda>x\<in>A. \<langle>x,b\<rangle>" in exI, simp)
 done
 
 (*Could probably weaken the premises to well_ord(K,r), or removing using AC*)
 lemma cmult_le_self:
     "\<lbrakk>Card(K);  Ord(L);  0<L\<rbrakk> \<Longrightarrow> K \<le> (K \<otimes> L)"
   unfolding cmult_def
 apply (rule le_trans [OF Card_cardinal_le well_ord_lepoll_imp_cardinal_le])
   apply assumption
  apply (blast intro: well_ord_rmult well_ord_Memrel Card_is_Ord)
 apply (blast intro: prod_lepoll_self ltD)
 done
 
 subsubsection\<open>Monotonicity of multiplication\<close>
 
 lemma prod_lepoll_mono:
      "\<lbrakk>A \<lesssim> C;  B \<lesssim> D\<rbrakk> \<Longrightarrow> A * B  \<lesssim>  C * D"
   unfolding lepoll_def
 apply (elim exE)
 apply (rule_tac x = "lam \<langle>w,y\<rangle>:A*B. <f`w, fa`y>" in exI)
 apply (rule_tac d = "\<lambda>\<langle>w,y\<rangle>. <converse (f) `w, converse (fa) `y>"
        in lam_injective)
 apply (typecheck add: inj_is_fun, auto)
 done
 
 lemma cmult_le_mono:
     "\<lbrakk>K' \<le> K;  L' \<le> L\<rbrakk> \<Longrightarrow> (K' \<otimes> L') \<le> (K \<otimes> L)"
   unfolding cmult_def
 apply (safe dest!: le_subset_iff [THEN iffD1])
 apply (rule well_ord_lepoll_imp_cardinal_le)
  apply (blast intro: well_ord_rmult well_ord_Memrel)
 apply (blast intro: prod_lepoll_mono subset_imp_lepoll)
 done
 
 subsection\<open>Multiplication of finite cardinals is "ordinary" multiplication\<close>
 
 lemma prod_succ_eqpoll: "succ(A)*B \<approx> B + A*B"
   unfolding eqpoll_def
 apply (rule exI)
 apply (rule_tac c = "\<lambda>\<langle>x,y\<rangle>. if x=A then Inl (y) else Inr (\<langle>x,y\<rangle>)"
             and d = "case (\<lambda>y. \<langle>A,y\<rangle>, \<lambda>z. z)" in lam_bijective)
 apply safe
 apply (simp_all add: succI2 if_type mem_imp_not_eq)
 done
 
 (*Unconditional version requires AC*)
 lemma cmult_succ_lemma:
     "\<lbrakk>Ord(m);  Ord(n)\<rbrakk> \<Longrightarrow> succ(m) \<otimes> n = n \<oplus> (m \<otimes> n)"
-apply (unfold cmult_def cadd_def)
+  unfolding cmult_def cadd_def
 apply (rule prod_succ_eqpoll [THEN cardinal_cong, THEN trans])
 apply (rule cardinal_cong [symmetric])
 apply (rule sum_eqpoll_cong [OF eqpoll_refl well_ord_cardinal_eqpoll])
 apply (blast intro: well_ord_rmult well_ord_Memrel)
 done
 
 lemma nat_cmult_eq_mult: "\<lbrakk>m \<in> nat;  n \<in> nat\<rbrakk> \<Longrightarrow> m \<otimes> n = m#*n"
 apply (induct_tac m)
 apply (simp_all add: cmult_succ_lemma nat_cadd_eq_add)
 done
 
 lemma cmult_2: "Card(n) \<Longrightarrow> 2 \<otimes> n = n \<oplus> n"
 by (simp add: cmult_succ_lemma Card_is_Ord cadd_commute [of _ 0])
 
 lemma sum_lepoll_prod:
   assumes C: "2 \<lesssim> C" shows "B+B \<lesssim> C*B"
 proof -
   have "B+B \<lesssim> 2*B"
     by (simp add: sum_eq_2_times)
   also have "... \<lesssim> C*B"
     by (blast intro: prod_lepoll_mono lepoll_refl C)
   finally show "B+B \<lesssim> C*B" .
 qed
 
 lemma lepoll_imp_sum_lepoll_prod: "\<lbrakk>A \<lesssim> B; 2 \<lesssim> A\<rbrakk> \<Longrightarrow> A+B \<lesssim> A*B"
 by (blast intro: sum_lepoll_mono sum_lepoll_prod lepoll_trans lepoll_refl)
 
 
 subsection\<open>Infinite Cardinals are Limit Ordinals\<close>
 
 (*This proof is modelled upon one assuming nat<=A, with injection
   \<lambda>z\<in>cons(u,A). if z=u then 0 else if z \<in> nat then succ(z) else z
   and inverse \<lambda>y. if y \<in> nat then nat_case(u, \<lambda>z. z, y) else y.  \
   If f \<in> inj(nat,A) then range(f) behaves like the natural numbers.*)
 lemma nat_cons_lepoll: "nat \<lesssim> A \<Longrightarrow> cons(u,A) \<lesssim> A"
   unfolding lepoll_def
 apply (erule exE)
 apply (rule_tac x =
           "\<lambda>z\<in>cons (u,A).
              if z=u then f`0
              else if z \<in> range (f) then f`succ (converse (f) `z) else z"
        in exI)
 apply (rule_tac d =
           "\<lambda>y. if y \<in> range(f) then nat_case (u, \<lambda>z. f`z, converse(f) `y)
                               else y"
        in lam_injective)
 apply (fast intro!: if_type apply_type intro: inj_is_fun inj_converse_fun)
 apply (simp add: inj_is_fun [THEN apply_rangeI]
                  inj_converse_fun [THEN apply_rangeI]
                  inj_converse_fun [THEN apply_funtype])
 done
 
 lemma nat_cons_eqpoll: "nat \<lesssim> A \<Longrightarrow> cons(u,A) \<approx> A"
 apply (erule nat_cons_lepoll [THEN eqpollI])
 apply (rule subset_consI [THEN subset_imp_lepoll])
 done
 
 (*Specialized version required below*)
 lemma nat_succ_eqpoll: "nat \<subseteq> A \<Longrightarrow> succ(A) \<approx> A"
   unfolding succ_def
 apply (erule subset_imp_lepoll [THEN nat_cons_eqpoll])
 done
 
 lemma InfCard_nat: "InfCard(nat)"
   unfolding InfCard_def
 apply (blast intro: Card_nat le_refl Card_is_Ord)
 done
 
 lemma InfCard_is_Card: "InfCard(K) \<Longrightarrow> Card(K)"
   unfolding InfCard_def
 apply (erule conjunct1)
 done
 
 lemma InfCard_Un:
     "\<lbrakk>InfCard(K);  Card(L)\<rbrakk> \<Longrightarrow> InfCard(K \<union> L)"
   unfolding InfCard_def
 apply (simp add: Card_Un Un_upper1_le [THEN [2] le_trans]  Card_is_Ord)
 done
 
 (*Kunen's Lemma 10.11*)
 lemma InfCard_is_Limit: "InfCard(K) \<Longrightarrow> Limit(K)"
   unfolding InfCard_def
 apply (erule conjE)
 apply (frule Card_is_Ord)
 apply (rule ltI [THEN non_succ_LimitI])
 apply (erule le_imp_subset [THEN subsetD])
 apply (safe dest!: Limit_nat [THEN Limit_le_succD])
   unfolding Card_def
 apply (drule trans)
 apply (erule le_imp_subset [THEN nat_succ_eqpoll, THEN cardinal_cong])
 apply (erule Ord_cardinal_le [THEN lt_trans2, THEN lt_irrefl])
 apply (rule le_eqI, assumption)
 apply (rule Ord_cardinal)
 done
 
 
 (*** An infinite cardinal equals its square (Kunen, Thm 10.12, page 29) ***)
 
 (*A general fact about ordermap*)
 lemma ordermap_eqpoll_pred:
     "\<lbrakk>well_ord(A,r);  x \<in> A\<rbrakk> \<Longrightarrow> ordermap(A,r)`x \<approx> Order.pred(A,x,r)"
   unfolding eqpoll_def
 apply (rule exI)
 apply (simp add: ordermap_eq_image well_ord_is_wf)
 apply (erule ordermap_bij [THEN bij_is_inj, THEN restrict_bij,
                            THEN bij_converse_bij])
 apply (rule pred_subset)
 done
 
 subsubsection\<open>Establishing the well-ordering\<close>
 
 lemma well_ord_csquare:
   assumes K: "Ord(K)" shows "well_ord(K*K, csquare_rel(K))"
 proof (unfold csquare_rel_def, rule well_ord_rvimage)
   show "(\<lambda>\<langle>x,y\<rangle>\<in>K \<times> K. \<langle>x \<union> y, x, y\<rangle>) \<in> inj(K \<times> K, K \<times> K \<times> K)" using K
     by (force simp add: inj_def intro: lam_type Un_least_lt [THEN ltD] ltI)
 next
   show "well_ord(K \<times> K \<times> K, rmult(K, Memrel(K), K \<times> K, rmult(K, Memrel(K), K, Memrel(K))))"
     using K by (blast intro: well_ord_rmult well_ord_Memrel)
 qed
 
 subsubsection\<open>Characterising initial segments of the well-ordering\<close>
 
 lemma csquareD:
  "\<lbrakk><\<langle>x,y\<rangle>, \<langle>z,z\<rangle>> \<in> csquare_rel(K);  x<K;  y<K;  z<K\<rbrakk> \<Longrightarrow> x \<le> z \<and> y \<le> z"
   unfolding csquare_rel_def
 apply (erule rev_mp)
 apply (elim ltE)
 apply (simp add: rvimage_iff Un_absorb Un_least_mem_iff ltD)
 apply (safe elim!: mem_irrefl intro!: Un_upper1_le Un_upper2_le)
 apply (simp_all add: lt_def succI2)
 done
 
 lemma pred_csquare_subset:
     "z<K \<Longrightarrow> Order.pred(K*K, \<langle>z,z\<rangle>, csquare_rel(K)) \<subseteq> succ(z)*succ(z)"
-apply (unfold Order.pred_def)
+  unfolding Order.pred_def
 apply (safe del: SigmaI dest!: csquareD)
 apply (unfold lt_def, auto)
 done
 
 lemma csquare_ltI:
  "\<lbrakk>x<z;  y<z;  z<K\<rbrakk> \<Longrightarrow>  <\<langle>x,y\<rangle>, \<langle>z,z\<rangle>> \<in> csquare_rel(K)"
   unfolding csquare_rel_def
 apply (subgoal_tac "x<K \<and> y<K")
  prefer 2 apply (blast intro: lt_trans)
 apply (elim ltE)
 apply (simp add: rvimage_iff Un_absorb Un_least_mem_iff ltD)
 done
 
 (*Part of the traditional proof.  UNUSED since it's harder to prove \<and> apply *)
 lemma csquare_or_eqI:
  "\<lbrakk>x \<le> z;  y \<le> z;  z<K\<rbrakk> \<Longrightarrow> <\<langle>x,y\<rangle>, \<langle>z,z\<rangle>> \<in> csquare_rel(K) | x=z \<and> y=z"
   unfolding csquare_rel_def
 apply (subgoal_tac "x<K \<and> y<K")
  prefer 2 apply (blast intro: lt_trans1)
 apply (elim ltE)
 apply (simp add: rvimage_iff Un_absorb Un_least_mem_iff ltD)
 apply (elim succE)
 apply (simp_all add: subset_Un_iff [THEN iff_sym]
                      subset_Un_iff2 [THEN iff_sym] OrdmemD)
 done
 
 subsubsection\<open>The cardinality of initial segments\<close>
 
 lemma ordermap_z_lt:
       "\<lbrakk>Limit(K);  x<K;  y<K;  z=succ(x \<union> y)\<rbrakk> \<Longrightarrow>
           ordermap(K*K, csquare_rel(K)) ` \<langle>x,y\<rangle> <
           ordermap(K*K, csquare_rel(K)) ` \<langle>z,z\<rangle>"
 apply (subgoal_tac "z<K \<and> well_ord (K*K, csquare_rel (K))")
 prefer 2 apply (blast intro!: Un_least_lt Limit_has_succ
                               Limit_is_Ord [THEN well_ord_csquare], clarify)
 apply (rule csquare_ltI [THEN ordermap_mono, THEN ltI])
 apply (erule_tac [4] well_ord_is_wf)
 apply (blast intro!: Un_upper1_le Un_upper2_le Ord_ordermap elim!: ltE)+
 done
 
 text\<open>Kunen: "each \<^term>\<open>\<langle>x,y\<rangle> \<in> K \<times> K\<close> has no more than \<^term>\<open>z \<times> z\<close> predecessors..." (page 29)\<close>
 lemma ordermap_csquare_le:
   assumes K: "Limit(K)" and x: "x<K" and y: " y<K"
   defines "z \<equiv> succ(x \<union> y)"
   shows "|ordermap(K \<times> K, csquare_rel(K)) ` \<langle>x,y\<rangle>| \<le> |succ(z)| \<otimes> |succ(z)|"
 proof (unfold cmult_def, rule well_ord_lepoll_imp_cardinal_le)
   show "well_ord(|succ(z)| \<times> |succ(z)|,
                  rmult(|succ(z)|, Memrel(|succ(z)|), |succ(z)|, Memrel(|succ(z)|)))"
     by (blast intro: Ord_cardinal well_ord_Memrel well_ord_rmult)
 next
   have zK: "z<K" using x y K z_def
     by (blast intro: Un_least_lt Limit_has_succ)
   hence oz: "Ord(z)" by (elim ltE)
   have "ordermap(K \<times> K, csquare_rel(K)) ` \<langle>x,y\<rangle> \<lesssim> ordermap(K \<times> K, csquare_rel(K)) ` \<langle>z,z\<rangle>"
     using z_def
     by (blast intro: ordermap_z_lt leI le_imp_lepoll K x y)
   also have "... \<approx>  Order.pred(K \<times> K, \<langle>z,z\<rangle>, csquare_rel(K))"
     proof (rule ordermap_eqpoll_pred)
       show "well_ord(K \<times> K, csquare_rel(K))" using K
         by (rule Limit_is_Ord [THEN well_ord_csquare])
     next
       show "\<langle>z, z\<rangle> \<in> K \<times> K" using zK
         by (blast intro: ltD)
     qed
   also have "...  \<lesssim> succ(z) \<times> succ(z)" using zK
     by (rule pred_csquare_subset [THEN subset_imp_lepoll])
   also have "... \<approx> |succ(z)| \<times> |succ(z)|" using oz
     by (blast intro: prod_eqpoll_cong Ord_succ Ord_cardinal_eqpoll eqpoll_sym)
   finally show "ordermap(K \<times> K, csquare_rel(K)) ` \<langle>x,y\<rangle> \<lesssim> |succ(z)| \<times> |succ(z)|" .
 qed
 
 text\<open>Kunen: "... so the order type is \<open>\<le>\<close> K"\<close>
 lemma ordertype_csquare_le:
   assumes IK: "InfCard(K)" and eq: "\<And>y. y\<in>K \<Longrightarrow> InfCard(y) \<Longrightarrow> y \<otimes> y = y"
   shows "ordertype(K*K, csquare_rel(K)) \<le> K"
 proof -
   have  CK: "Card(K)" using IK by (rule InfCard_is_Card)
   hence OK: "Ord(K)"  by (rule Card_is_Ord)
   moreover have "Ord(ordertype(K \<times> K, csquare_rel(K)))" using OK
     by (rule well_ord_csquare [THEN Ord_ordertype])
   ultimately show ?thesis
   proof (rule all_lt_imp_le)
     fix i
     assume i: "i < ordertype(K \<times> K, csquare_rel(K))"
     hence Oi: "Ord(i)" by (elim ltE)
     obtain x y where x: "x \<in> K" and y: "y \<in> K"
                  and ieq: "i = ordermap(K \<times> K, csquare_rel(K)) ` \<langle>x,y\<rangle>"
       using i by (auto simp add: ordertype_unfold elim: ltE)
     hence xy: "Ord(x)" "Ord(y)" "x < K" "y < K" using OK
       by (blast intro: Ord_in_Ord ltI)+
     hence ou: "Ord(x \<union> y)"
       by (simp add: Ord_Un)
     show "i < K"
       proof (rule Card_lt_imp_lt [OF _ Oi CK])
         have "|i| \<le> |succ(succ(x \<union> y))| \<otimes> |succ(succ(x \<union> y))|" using IK xy
           by (auto simp add: ieq intro: InfCard_is_Limit [THEN ordermap_csquare_le])
         moreover have "|succ(succ(x \<union> y))| \<otimes> |succ(succ(x \<union> y))| < K"
           proof (cases rule: Ord_linear2 [OF ou Ord_nat])
             assume "x \<union> y < nat"
             hence "|succ(succ(x \<union> y))| \<otimes> |succ(succ(x \<union> y))| \<in> nat"
               by (simp add: lt_def nat_cmult_eq_mult nat_succI mult_type
                          nat_into_Card [THEN Card_cardinal_eq]  Ord_nat)
             also have "... \<subseteq> K" using IK
               by (simp add: InfCard_def le_imp_subset)
             finally show "|succ(succ(x \<union> y))| \<otimes> |succ(succ(x \<union> y))| < K"
               by (simp add: ltI OK)
           next
             assume natxy: "nat \<le> x \<union> y"
             hence seq: "|succ(succ(x \<union> y))| = |x \<union> y|" using xy
               by (simp add: le_imp_subset nat_succ_eqpoll [THEN cardinal_cong] le_succ_iff)
             also have "... < K" using xy
               by (simp add: Un_least_lt Ord_cardinal_le [THEN lt_trans1])
             finally have "|succ(succ(x \<union> y))| < K" .
             moreover have "InfCard(|succ(succ(x \<union> y))|)" using xy natxy
               by (simp add: seq InfCard_def Card_cardinal nat_le_cardinal)
             ultimately show ?thesis  by (simp add: eq ltD)
           qed
         ultimately show "|i| < K" by (blast intro: lt_trans1)
     qed
   qed
 qed
 
 (*Main result: Kunen's Theorem 10.12*)
 lemma InfCard_csquare_eq:
   assumes IK: "InfCard(K)" shows "K \<otimes> K = K"
 proof -
   have  OK: "Ord(K)" using IK by (simp add: Card_is_Ord InfCard_is_Card)
   show "K \<otimes> K = K" using OK IK
   proof (induct rule: trans_induct)
     case (step i)
     show "i \<otimes> i = i"
     proof (rule le_anti_sym)
       have "|i \<times> i| = |ordertype(i \<times> i, csquare_rel(i))|"
         by (rule cardinal_cong,
           simp add: step.hyps well_ord_csquare [THEN ordermap_bij, THEN bij_imp_eqpoll])
       hence "i \<otimes> i \<le> ordertype(i \<times> i, csquare_rel(i))"
         by (simp add: step.hyps cmult_def Ord_cardinal_le well_ord_csquare [THEN Ord_ordertype])
       moreover
       have "ordertype(i \<times> i, csquare_rel(i)) \<le> i" using step
         by (simp add: ordertype_csquare_le)
       ultimately show "i \<otimes> i \<le> i" by (rule le_trans)
     next
       show "i \<le> i \<otimes> i" using step
         by (blast intro: cmult_square_le InfCard_is_Card)
     qed
   qed
 qed
 
 (*Corollary for arbitrary well-ordered sets (all sets, assuming AC)*)
 lemma well_ord_InfCard_square_eq:
   assumes r: "well_ord(A,r)" and I: "InfCard(|A|)" shows "A \<times> A \<approx> A"
 proof -
   have "A \<times> A \<approx> |A| \<times> |A|"
     by (blast intro: prod_eqpoll_cong well_ord_cardinal_eqpoll eqpoll_sym r)
   also have "... \<approx> A"
     proof (rule well_ord_cardinal_eqE [OF _ r])
       show "well_ord(|A| \<times> |A|, rmult(|A|, Memrel(|A|), |A|, Memrel(|A|)))"
         by (blast intro: Ord_cardinal well_ord_rmult well_ord_Memrel r)
     next
       show "||A| \<times> |A|| = |A|" using InfCard_csquare_eq I
         by (simp add: cmult_def)
     qed
   finally show ?thesis .
 qed
 
 lemma InfCard_square_eqpoll: "InfCard(K) \<Longrightarrow> K \<times> K \<approx> K"
 apply (rule well_ord_InfCard_square_eq)
  apply (erule InfCard_is_Card [THEN Card_is_Ord, THEN well_ord_Memrel])
 apply (simp add: InfCard_is_Card [THEN Card_cardinal_eq])
 done
 
 lemma Inf_Card_is_InfCard: "\<lbrakk>Card(i); \<not> Finite(i)\<rbrakk> \<Longrightarrow> InfCard(i)"
 by (simp add: InfCard_def Card_is_Ord [THEN nat_le_infinite_Ord])
 
 subsubsection\<open>Toward's Kunen's Corollary 10.13 (1)\<close>
 
 lemma InfCard_le_cmult_eq: "\<lbrakk>InfCard(K);  L \<le> K;  0<L\<rbrakk> \<Longrightarrow> K \<otimes> L = K"
 apply (rule le_anti_sym)
  prefer 2
  apply (erule ltE, blast intro: cmult_le_self InfCard_is_Card)
 apply (frule InfCard_is_Card [THEN Card_is_Ord, THEN le_refl])
 apply (rule cmult_le_mono [THEN le_trans], assumption+)
 apply (simp add: InfCard_csquare_eq)
 done
 
 (*Corollary 10.13 (1), for cardinal multiplication*)
 lemma InfCard_cmult_eq: "\<lbrakk>InfCard(K);  InfCard(L)\<rbrakk> \<Longrightarrow> K \<otimes> L = K \<union> L"
 apply (rule_tac i = K and j = L in Ord_linear_le)
 apply (typecheck add: InfCard_is_Card Card_is_Ord)
 apply (rule cmult_commute [THEN ssubst])
 apply (rule Un_commute [THEN ssubst])
 apply (simp_all add: InfCard_is_Limit [THEN Limit_has_0] InfCard_le_cmult_eq
                      subset_Un_iff2 [THEN iffD1] le_imp_subset)
 done
 
 lemma InfCard_cdouble_eq: "InfCard(K) \<Longrightarrow> K \<oplus> K = K"
 apply (simp add: cmult_2 [symmetric] InfCard_is_Card cmult_commute)
 apply (simp add: InfCard_le_cmult_eq InfCard_is_Limit Limit_has_0 Limit_has_succ)
 done
 
 (*Corollary 10.13 (1), for cardinal addition*)
 lemma InfCard_le_cadd_eq: "\<lbrakk>InfCard(K);  L \<le> K\<rbrakk> \<Longrightarrow> K \<oplus> L = K"
 apply (rule le_anti_sym)
  prefer 2
  apply (erule ltE, blast intro: cadd_le_self InfCard_is_Card)
 apply (frule InfCard_is_Card [THEN Card_is_Ord, THEN le_refl])
 apply (rule cadd_le_mono [THEN le_trans], assumption+)
 apply (simp add: InfCard_cdouble_eq)
 done
 
 lemma InfCard_cadd_eq: "\<lbrakk>InfCard(K);  InfCard(L)\<rbrakk> \<Longrightarrow> K \<oplus> L = K \<union> L"
 apply (rule_tac i = K and j = L in Ord_linear_le)
 apply (typecheck add: InfCard_is_Card Card_is_Ord)
 apply (rule cadd_commute [THEN ssubst])
 apply (rule Un_commute [THEN ssubst])
 apply (simp_all add: InfCard_le_cadd_eq subset_Un_iff2 [THEN iffD1] le_imp_subset)
 done
 
 (*The other part, Corollary 10.13 (2), refers to the cardinality of the set
   of all n-tuples of elements of K.  A better version for the Isabelle theory
   might be  InfCard(K) \<Longrightarrow> |list(K)| = K.
 *)
 
 subsection\<open>For Every Cardinal Number There Exists A Greater One\<close>
 
 text\<open>This result is Kunen's Theorem 10.16, which would be trivial using AC\<close>
 
 lemma Ord_jump_cardinal: "Ord(jump_cardinal(K))"
   unfolding jump_cardinal_def
 apply (rule Ord_is_Transset [THEN [2] OrdI])
  prefer 2 apply (blast intro!: Ord_ordertype)
   unfolding Transset_def
 apply (safe del: subsetI)
 apply (simp add: ordertype_pred_unfold, safe)
 apply (rule UN_I)
 apply (rule_tac [2] ReplaceI)
    prefer 4 apply (blast intro: well_ord_subset elim!: predE)+
 done
 
 (*Allows selective unfolding.  Less work than deriving intro/elim rules*)
 lemma jump_cardinal_iff:
      "i \<in> jump_cardinal(K) \<longleftrightarrow>
       (\<exists>r X. r \<subseteq> K*K \<and> X \<subseteq> K \<and> well_ord(X,r) \<and> i = ordertype(X,r))"
   unfolding jump_cardinal_def
 apply (blast del: subsetI)
 done
 
 (*The easy part of Theorem 10.16: jump_cardinal(K) exceeds K*)
 lemma K_lt_jump_cardinal: "Ord(K) \<Longrightarrow> K < jump_cardinal(K)"
 apply (rule Ord_jump_cardinal [THEN [2] ltI])
 apply (rule jump_cardinal_iff [THEN iffD2])
 apply (rule_tac x="Memrel(K)" in exI)
 apply (rule_tac x=K in exI)
 apply (simp add: ordertype_Memrel well_ord_Memrel)
 apply (simp add: Memrel_def subset_iff)
 done
 
 (*The proof by contradiction: the bijection f yields a wellordering of X
   whose ordertype is jump_cardinal(K).  *)
 lemma Card_jump_cardinal_lemma:
      "\<lbrakk>well_ord(X,r);  r \<subseteq> K * K;  X \<subseteq> K;
          f \<in> bij(ordertype(X,r), jump_cardinal(K))\<rbrakk>
       \<Longrightarrow> jump_cardinal(K) \<in> jump_cardinal(K)"
 apply (subgoal_tac "f O ordermap (X,r) \<in> bij (X, jump_cardinal (K))")
  prefer 2 apply (blast intro: comp_bij ordermap_bij)
 apply (rule jump_cardinal_iff [THEN iffD2])
 apply (intro exI conjI)
 apply (rule subset_trans [OF rvimage_type Sigma_mono], assumption+)
 apply (erule bij_is_inj [THEN well_ord_rvimage])
 apply (rule Ord_jump_cardinal [THEN well_ord_Memrel])
 apply (simp add: well_ord_Memrel [THEN [2] bij_ordertype_vimage]
                  ordertype_Memrel Ord_jump_cardinal)
 done
 
 (*The hard part of Theorem 10.16: jump_cardinal(K) is itself a cardinal*)
 lemma Card_jump_cardinal: "Card(jump_cardinal(K))"
 apply (rule Ord_jump_cardinal [THEN CardI])
   unfolding eqpoll_def
 apply (safe dest!: ltD jump_cardinal_iff [THEN iffD1])
 apply (blast intro: Card_jump_cardinal_lemma [THEN mem_irrefl])
 done
 
 subsection\<open>Basic Properties of Successor Cardinals\<close>
 
 lemma csucc_basic: "Ord(K) \<Longrightarrow> Card(csucc(K)) \<and> K < csucc(K)"
   unfolding csucc_def
 apply (rule LeastI)
 apply (blast intro: Card_jump_cardinal K_lt_jump_cardinal Ord_jump_cardinal)+
 done
 
 lemmas Card_csucc = csucc_basic [THEN conjunct1]
 
 lemmas lt_csucc = csucc_basic [THEN conjunct2]
 
 lemma Ord_0_lt_csucc: "Ord(K) \<Longrightarrow> 0 < csucc(K)"
 by (blast intro: Ord_0_le lt_csucc lt_trans1)
 
 lemma csucc_le: "\<lbrakk>Card(L);  K<L\<rbrakk> \<Longrightarrow> csucc(K) \<le> L"
   unfolding csucc_def
 apply (rule Least_le)
 apply (blast intro: Card_is_Ord)+
 done
 
 lemma lt_csucc_iff: "\<lbrakk>Ord(i); Card(K)\<rbrakk> \<Longrightarrow> i < csucc(K) \<longleftrightarrow> |i| \<le> K"
 apply (rule iffI)
 apply (rule_tac [2] Card_lt_imp_lt)
 apply (erule_tac [2] lt_trans1)
 apply (simp_all add: lt_csucc Card_csucc Card_is_Ord)
 apply (rule notI [THEN not_lt_imp_le])
 apply (rule Card_cardinal [THEN csucc_le, THEN lt_trans1, THEN lt_irrefl], assumption)
 apply (rule Ord_cardinal_le [THEN lt_trans1])
 apply (simp_all add: Ord_cardinal Card_is_Ord)
 done
 
 lemma Card_lt_csucc_iff:
      "\<lbrakk>Card(K'); Card(K)\<rbrakk> \<Longrightarrow> K' < csucc(K) \<longleftrightarrow> K' \<le> K"
 by (simp add: lt_csucc_iff Card_cardinal_eq Card_is_Ord)
 
 lemma InfCard_csucc: "InfCard(K) \<Longrightarrow> InfCard(csucc(K))"
 by (simp add: InfCard_def Card_csucc Card_is_Ord
               lt_csucc [THEN leI, THEN [2] le_trans])
 
 
 subsubsection\<open>Removing elements from a finite set decreases its cardinality\<close>
 
 lemma Finite_imp_cardinal_cons [simp]:
   assumes FA: "Finite(A)" and a: "a\<notin>A" shows "|cons(a,A)| = succ(|A|)"
 proof -
   { fix X
     have "Finite(X) \<Longrightarrow> a \<notin> X \<Longrightarrow> cons(a,X) \<lesssim> X \<Longrightarrow> False"
       proof (induct X rule: Finite_induct)
         case 0 thus False  by (simp add: lepoll_0_iff)
       next
         case (cons x Y)
         hence "cons(x, cons(a, Y)) \<lesssim> cons(x, Y)" by (simp add: cons_commute)
         hence "cons(a, Y) \<lesssim> Y" using cons        by (blast dest: cons_lepoll_consD)
         thus False using cons by auto
       qed
   }
   hence [simp]: "\<not> cons(a,A) \<lesssim> A" using a FA by auto
   have [simp]: "|A| \<approx> A" using Finite_imp_well_ord [OF FA]
     by (blast intro: well_ord_cardinal_eqpoll)
   have "(\<mu> i. i \<approx> cons(a, A)) = succ(|A|)"
     proof (rule Least_equality [OF _ _ notI])
       show "succ(|A|) \<approx> cons(a, A)"
         by (simp add: succ_def cons_eqpoll_cong mem_not_refl a)
     next
       show "Ord(succ(|A|))" by simp
     next
       fix i
       assume i: "i \<le> |A|" "i \<approx> cons(a, A)"
       have "cons(a, A) \<approx> i" by (rule eqpoll_sym) (rule i)
       also have "... \<lesssim> |A|" by (rule le_imp_lepoll) (rule i)
       also have "... \<approx> A"   by simp
       finally have "cons(a, A) \<lesssim> A" .
       thus False by simp
     qed
   thus ?thesis by (simp add: cardinal_def)
 qed
 
 lemma Finite_imp_succ_cardinal_Diff:
      "\<lbrakk>Finite(A);  a \<in> A\<rbrakk> \<Longrightarrow> succ(|A-{a}|) = |A|"
 apply (rule_tac b = A in cons_Diff [THEN subst], assumption)
 apply (simp add: Finite_imp_cardinal_cons Diff_subset [THEN subset_Finite])
 apply (simp add: cons_Diff)
 done
 
 lemma Finite_imp_cardinal_Diff: "\<lbrakk>Finite(A);  a \<in> A\<rbrakk> \<Longrightarrow> |A-{a}| < |A|"
 apply (rule succ_leE)
 apply (simp add: Finite_imp_succ_cardinal_Diff)
 done
 
 lemma Finite_cardinal_in_nat [simp]: "Finite(A) \<Longrightarrow> |A| \<in> nat"
 proof (induct rule: Finite_induct)
   case 0 thus ?case by (simp add: cardinal_0)
 next
   case (cons x A) thus ?case by (simp add: Finite_imp_cardinal_cons)
 qed
 
 lemma card_Un_Int:
      "\<lbrakk>Finite(A); Finite(B)\<rbrakk> \<Longrightarrow> |A| #+ |B| = |A \<union> B| #+ |A \<inter> B|"
 apply (erule Finite_induct, simp)
 apply (simp add: Finite_Int cons_absorb Un_cons Int_cons_left)
 done
 
 lemma card_Un_disjoint:
      "\<lbrakk>Finite(A); Finite(B); A \<inter> B = 0\<rbrakk> \<Longrightarrow> |A \<union> B| = |A| #+ |B|"
 by (simp add: Finite_Un card_Un_Int)
 
 lemma card_partition:
   assumes FC: "Finite(C)"
   shows
      "Finite (\<Union> C) \<Longrightarrow>
         (\<forall>c\<in>C. |c| = k) \<Longrightarrow>
         (\<forall>c1 \<in> C. \<forall>c2 \<in> C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = 0) \<Longrightarrow>
         k #* |C| = |\<Union> C|"
 using FC
 proof (induct rule: Finite_induct)
   case 0 thus ?case by simp
 next
   case (cons x B)
   hence "x \<inter> \<Union>B = 0" by auto
   thus ?case using cons
     by (auto simp add: card_Un_disjoint)
 qed
 
 
 subsubsection\<open>Theorems by Krzysztof Grabczewski, proofs by lcp\<close>
 
 lemmas nat_implies_well_ord = nat_into_Ord [THEN well_ord_Memrel]
 
 lemma nat_sum_eqpoll_sum:
   assumes m: "m \<in> nat" and n: "n \<in> nat" shows "m + n \<approx> m #+ n"
 proof -
   have "m + n \<approx> |m+n|" using m n
     by (blast intro: nat_implies_well_ord well_ord_radd well_ord_cardinal_eqpoll eqpoll_sym)
   also have "... = m #+ n" using m n
     by (simp add: nat_cadd_eq_add [symmetric] cadd_def)
   finally show ?thesis .
 qed
 
 lemma Ord_subset_natD [rule_format]: "Ord(i) \<Longrightarrow> i \<subseteq> nat \<Longrightarrow> i \<in> nat | i=nat"
 proof (induct i rule: trans_induct3)
   case 0 thus ?case by auto
 next
   case (succ i) thus ?case by auto
 next
   case (limit l) thus ?case
     by (blast dest: nat_le_Limit le_imp_subset)
 qed
 
 lemma Ord_nat_subset_into_Card: "\<lbrakk>Ord(i); i \<subseteq> nat\<rbrakk> \<Longrightarrow> Card(i)"
   by (blast dest: Ord_subset_natD intro: Card_nat nat_into_Card)
 
 end
diff --git a/src/ZF/Coind/ECR.thy b/src/ZF/Coind/ECR.thy
--- a/src/ZF/Coind/ECR.thy
+++ b/src/ZF/Coind/ECR.thy
@@ -1,167 +1,167 @@
 (*  Title:      ZF/Coind/ECR.thy
     Author:     Jacob Frost, Cambridge University Computer Laboratory
     Copyright   1995  University of Cambridge
 *)
 
 theory ECR imports Static Dynamic begin
 
 (* The extended correspondence relation *)
 
 consts
   HasTyRel :: i
 coinductive
   domains "HasTyRel" \<subseteq> "Val * Ty"
   intros
     htr_constI [intro!]:
       "\<lbrakk>c \<in> Const; t \<in> Ty; isof(c,t)\<rbrakk> \<Longrightarrow> <v_const(c),t> \<in> HasTyRel"
     htr_closI [intro]:
       "\<lbrakk>x \<in> ExVar; e \<in> Exp; t \<in> Ty; ve \<in> ValEnv; te \<in> TyEnv; 
           <te,e_fn(x,e),t> \<in> ElabRel;  
           ve_dom(ve) = te_dom(te);   
           {<ve_app(ve,y),te_app(te,y)>.y \<in> ve_dom(ve)} \<in> Pow(HasTyRel)\<rbrakk> 
        \<Longrightarrow> <v_clos(x,e,ve),t> \<in> HasTyRel" 
   monos  Pow_mono
   type_intros Val_ValEnv.intros
   
 (* Pointwise extension to environments *)
  
 definition
   hastyenv :: "[i,i] \<Rightarrow> o"  where
     "hastyenv(ve,te) \<equiv>                        
          ve_dom(ve) = te_dom(te) \<and>          
          (\<forall>x \<in> ve_dom(ve). <ve_app(ve,x),te_app(te,x)> \<in> HasTyRel)"
 
 (* Specialised co-induction rule *)
 
 lemma htr_closCI [intro]:
      "\<lbrakk>x \<in> ExVar; e \<in> Exp; t \<in> Ty; ve \<in> ValEnv; te \<in> TyEnv;   
          <te, e_fn(x, e), t> \<in> ElabRel; ve_dom(ve) = te_dom(te);  
          {<ve_app(ve,y),te_app(te,y)>.y \<in> ve_dom(ve)} \<in>
            Pow({<v_clos(x,e,ve),t>} \<union> HasTyRel)\<rbrakk>     
       \<Longrightarrow> <v_clos(x, e, ve),t> \<in> HasTyRel"
 apply (rule singletonI [THEN HasTyRel.coinduct], auto)
 done
 
 (* Specialised elimination rules *)
 
 inductive_cases
     htr_constE [elim!]: "<v_const(c),t> \<in> HasTyRel"
   and htr_closE [elim]: "<v_clos(x,e,ve),t> \<in> HasTyRel"
 
 
 (* Properties of the pointwise extension to environments *)
 
 lemmas HasTyRel_non_zero =
        HasTyRel.dom_subset [THEN subsetD, THEN SigmaD1, THEN ValNEE]
 
 lemma hastyenv_owr: 
   "\<lbrakk>ve \<in> ValEnv; te \<in> TyEnv; hastyenv(ve,te); \<langle>v,t\<rangle> \<in> HasTyRel\<rbrakk> 
    \<Longrightarrow> hastyenv(ve_owr(ve,x,v),te_owr(te,x,t))"
 by (auto simp add: hastyenv_def ve_app_owr HasTyRel_non_zero)
 
 lemma basic_consistency_lem: 
   "\<lbrakk>ve \<in> ValEnv; te \<in> TyEnv; isofenv(ve,te)\<rbrakk> \<Longrightarrow> hastyenv(ve,te)"
-apply (unfold isofenv_def hastyenv_def)
+  unfolding isofenv_def hastyenv_def
 apply (force intro: te_appI ve_domI) 
 done
 
 
 (* ############################################################ *)
 (* The Consistency theorem                                      *)
 (* ############################################################ *)
 
 lemma consistency_const:
      "\<lbrakk>c \<in> Const; hastyenv(ve,te);<te,e_const(c),t> \<in> ElabRel\<rbrakk> 
       \<Longrightarrow> <v_const(c), t> \<in> HasTyRel"
 by blast
 
 
 lemma consistency_var: 
   "\<lbrakk>x \<in> ve_dom(ve); hastyenv(ve,te); <te,e_var(x),t> \<in> ElabRel\<rbrakk> \<Longrightarrow>      
    <ve_app(ve,x),t> \<in> HasTyRel"
 by (unfold hastyenv_def, blast)
 
 lemma consistency_fn: 
   "\<lbrakk>ve \<in> ValEnv; x \<in> ExVar; e \<in> Exp; hastyenv(ve,te);        
            <te,e_fn(x,e),t> \<in> ElabRel   
 \<rbrakk> \<Longrightarrow> <v_clos(x, e, ve), t> \<in> HasTyRel"
 by (unfold hastyenv_def, blast)
 
 declare ElabRel.dom_subset [THEN subsetD, dest]
 
 declare Ty.intros [simp, intro!]
 declare TyEnv.intros [simp, intro!]
 declare Val_ValEnv.intros [simp, intro!]
 
 lemma consistency_fix: 
   "\<lbrakk>ve \<in> ValEnv; x \<in> ExVar; e \<in> Exp; f \<in> ExVar; cl \<in> Val;                
       v_clos(x,e,ve_owr(ve,f,cl)) = cl;                           
       hastyenv(ve,te); <te,e_fix(f,x,e),t> \<in> ElabRel\<rbrakk> \<Longrightarrow>        
    \<langle>cl,t\<rangle> \<in> HasTyRel"
   unfolding hastyenv_def
 apply (erule elab_fixE, safe)
 apply hypsubst_thin
 apply (rule subst, assumption) 
 apply (rule_tac te="te_owr(te, f, t_fun(t1, t2))" in htr_closCI)
 apply simp_all
 apply (blast intro: ve_owrI) 
 apply (rule ElabRel.fnI)
 apply (simp_all add: ValNEE, force)
 done
 
 
 lemma consistency_app1:
  "\<lbrakk>ve \<in> ValEnv; e1 \<in> Exp; e2 \<in> Exp; c1 \<in> Const; c2 \<in> Const;    
      <ve,e1,v_const(c1)> \<in> EvalRel;                       
      \<forall>t te.                                          
        hastyenv(ve,te) \<longrightarrow> <te,e1,t> \<in> ElabRel \<longrightarrow> <v_const(c1),t> \<in> HasTyRel;
      <ve, e2, v_const(c2)> \<in> EvalRel;                   
      \<forall>t te.                                          
        hastyenv(ve,te) \<longrightarrow> <te,e2,t> \<in> ElabRel \<longrightarrow> <v_const(c2),t> \<in> HasTyRel;
      hastyenv(ve, te);                                  
      <te,e_app(e1,e2),t> \<in> ElabRel\<rbrakk> 
   \<Longrightarrow> <v_const(c_app(c1, c2)),t> \<in> HasTyRel"
 by (blast intro!: c_appI intro: isof_app)
 
 lemma consistency_app2:
  "\<lbrakk>ve \<in> ValEnv; vem \<in> ValEnv; e1 \<in> Exp; e2 \<in> Exp; em \<in> Exp; xm \<in> ExVar; 
      v \<in> Val;   
      <ve,e1,v_clos(xm,em,vem)> \<in> EvalRel;        
      \<forall>t te. hastyenv(ve,te) \<longrightarrow>                     
             <te,e1,t> \<in> ElabRel \<longrightarrow> <v_clos(xm,em,vem),t> \<in> HasTyRel;         
      <ve,e2,v2> \<in> EvalRel;                       
      \<forall>t te. hastyenv(ve,te) \<longrightarrow> <te,e2,t> \<in> ElabRel \<longrightarrow> \<langle>v2,t\<rangle> \<in> HasTyRel;
      <ve_owr(vem,xm,v2),em,v> \<in> EvalRel;         
      \<forall>t te. hastyenv(ve_owr(vem,xm,v2),te) \<longrightarrow>      
             <te,em,t> \<in> ElabRel \<longrightarrow> \<langle>v,t\<rangle> \<in> HasTyRel;
      hastyenv(ve,te); <te,e_app(e1,e2),t> \<in> ElabRel\<rbrakk> 
    \<Longrightarrow> \<langle>v,t\<rangle> \<in> HasTyRel"
 apply (erule elab_appE)
 apply (drule spec [THEN spec, THEN mp, THEN mp], assumption+)
 apply (drule spec [THEN spec, THEN mp, THEN mp], assumption+)
 apply (erule htr_closE)
 apply (erule elab_fnE, simp)
 apply clarify
 apply (drule spec [THEN spec, THEN mp, THEN mp])
 prefer 2 apply assumption+
 apply (rule hastyenv_owr, assumption)
 apply assumption 
 apply (simp add: hastyenv_def, blast+)
 done
 
 lemma consistency [rule_format]:
    "<ve,e,v> \<in> EvalRel 
     \<Longrightarrow> (\<forall>t te. hastyenv(ve,te) \<longrightarrow> <te,e,t> \<in> ElabRel \<longrightarrow> \<langle>v,t\<rangle> \<in> HasTyRel)"
 apply (erule EvalRel.induct)
 apply (simp_all add: consistency_const consistency_var consistency_fn 
                      consistency_fix consistency_app1)
 apply (blast intro: consistency_app2)
 done
 
 lemma basic_consistency:
      "\<lbrakk>ve \<in> ValEnv; te \<in> TyEnv; isofenv(ve,te);                    
          <ve,e,v_const(c)> \<in> EvalRel; <te,e,t> \<in> ElabRel\<rbrakk> 
       \<Longrightarrow> isof(c,t)"
 by (blast dest: consistency intro!: basic_consistency_lem)
 
 end
diff --git a/src/ZF/Coind/Map.thy b/src/ZF/Coind/Map.thy
--- a/src/ZF/Coind/Map.thy
+++ b/src/ZF/Coind/Map.thy
@@ -1,184 +1,184 @@
 (*  Title:      ZF/Coind/Map.thy
     Author:     Jacob Frost, Cambridge University Computer Laboratory
     Copyright   1995  University of Cambridge
 
 Some sample proofs of inclusions for the final coalgebra "U" (by lcp).
 *)
 
 theory Map imports ZF begin
 
 definition
   TMap :: "[i,i] \<Rightarrow> i"  where
    "TMap(A,B) \<equiv> {m \<in> Pow(A*\<Union>(B)).\<forall>a \<in> A. m``{a} \<in> B}"
 
 definition
   PMap :: "[i,i] \<Rightarrow> i"  where
    "PMap(A,B) \<equiv> TMap(A,cons(0,B))"
 
 (* Note: 0 \<in> B \<Longrightarrow> TMap(A,B) = PMap(A,B) *)
   
 definition
   map_emp :: i  where
    "map_emp \<equiv> 0"
 
 definition
   map_owr :: "[i,i,i]\<Rightarrow>i"  where
    "map_owr(m,a,b) \<equiv> \<Sum>x \<in> {a} \<union> domain(m). if x=a then b else m``{x}"
 
 definition
   map_app :: "[i,i]\<Rightarrow>i"  where
    "map_app(m,a) \<equiv> m``{a}"
   
 lemma "{0,1} \<subseteq> {1} \<union> TMap(I, {0,1})"
 by (unfold TMap_def, blast)
 
 lemma "{0} \<union> TMap(I,1) \<subseteq> {1} \<union> TMap(I, {0} \<union> TMap(I,1))"
 by (unfold TMap_def, blast)
 
 lemma "{0,1} \<union> TMap(I,2) \<subseteq> {1} \<union> TMap(I, {0,1} \<union> TMap(I,2))"
 by (unfold TMap_def, blast)
 
 (*A bit too slow.
 lemma "{0,1} \<union> TMap(I,TMap(I,2)) \<union> TMap(I,2) \<subseteq>  
        {1} \<union> TMap(I, {0,1} \<union> TMap(I,TMap(I,2)) \<union> TMap(I,2))"
 by (unfold TMap_def, blast)
 *)
 
 (* ############################################################ *)
 (* Lemmas                                                       *)
 (* ############################################################ *)
 
 lemma qbeta_if: "Sigma(A,B)``{a} = (if a \<in> A then B(a) else 0)"
 by auto
 
 lemma qbeta: "a \<in> A \<Longrightarrow> Sigma(A,B)``{a} = B(a)"
 by fast
 
 lemma qbeta_emp: "a\<notin>A \<Longrightarrow> Sigma(A,B)``{a} = 0"
 by fast
 
 lemma image_Sigma1: "a \<notin> A \<Longrightarrow> Sigma(A,B)``{a}=0"
 by fast
 
 
 (* ############################################################ *)
 (* Inclusion in Quine Universes                                 *)
 (* ############################################################ *)
 
 (* Lemmas *)
 
 lemma MapQU_lemma: 
     "A \<subseteq> univ(X) \<Longrightarrow> Pow(A * \<Union>(quniv(X))) \<subseteq> quniv(X)"
   unfolding quniv_def
 apply (rule Pow_mono)
 apply (rule subset_trans [OF Sigma_mono product_univ])
 apply (erule subset_trans)
 apply (rule arg_subset_eclose [THEN univ_mono])
 apply (simp add: Union_Pow_eq)
 done
 
 (* Theorems *)
 
 lemma mapQU:
   "\<lbrakk>m \<in> PMap(A,quniv(B)); \<And>x. x \<in> A \<Longrightarrow> x \<in> univ(B)\<rbrakk> \<Longrightarrow> m \<in> quniv(B)"
-apply (unfold PMap_def TMap_def)
+  unfolding PMap_def TMap_def
 apply (blast intro!: MapQU_lemma [THEN subsetD]) 
 done
 
 (* ############################################################ *)
 (* Monotonicity                                                 *)
 (* ############################################################ *)
 
 lemma PMap_mono: "B \<subseteq> C \<Longrightarrow> PMap(A,B)<=PMap(A,C)"
 by (unfold PMap_def TMap_def, blast)
 
 
 (* ############################################################ *)
 (* Introduction Rules                                           *)
 (* ############################################################ *)
 
 (** map_emp **)
 
 lemma pmap_empI: "map_emp \<in> PMap(A,B)"
 by (unfold map_emp_def PMap_def TMap_def, auto)
 
 (** map_owr **)
 
 lemma pmap_owrI: 
   "\<lbrakk>m \<in> PMap(A,B); a \<in> A; b \<in> B\<rbrakk>  \<Longrightarrow> map_owr(m,a,b):PMap(A,B)"
 apply (unfold map_owr_def PMap_def TMap_def, safe)
 apply (simp_all add: if_iff, auto)
 (*Remaining subgoal*)
 apply (rule excluded_middle [THEN disjE])
 apply (erule image_Sigma1)
 apply (drule_tac psi = "uu \<notin> B" for uu in asm_rl)
 apply (auto simp add: qbeta)
 done
 
 (** map_app **)
 
 lemma tmap_app_notempty: 
   "\<lbrakk>m \<in> TMap(A,B); a \<in> domain(m)\<rbrakk> \<Longrightarrow> map_app(m,a) \<noteq>0"
 by (unfold TMap_def map_app_def, blast)
 
 lemma tmap_appI: 
   "\<lbrakk>m \<in> TMap(A,B); a \<in> domain(m)\<rbrakk> \<Longrightarrow> map_app(m,a):B"
 by (unfold TMap_def map_app_def domain_def, blast)
 
 lemma pmap_appI: 
   "\<lbrakk>m \<in> PMap(A,B); a \<in> domain(m)\<rbrakk> \<Longrightarrow> map_app(m,a):B"
   unfolding PMap_def
 apply (frule tmap_app_notempty, assumption)
 apply (drule tmap_appI, auto)
 done
 
 (** domain **)
 
 lemma tmap_domainD: 
   "\<lbrakk>m \<in> TMap(A,B); a \<in> domain(m)\<rbrakk> \<Longrightarrow> a \<in> A"
 by (unfold TMap_def, blast)
 
 lemma pmap_domainD: 
   "\<lbrakk>m \<in> PMap(A,B); a \<in> domain(m)\<rbrakk> \<Longrightarrow> a \<in> A"
 by (unfold PMap_def TMap_def, blast)
 
 
 (* ############################################################ *)
 (* Equalities                                                   *)
 (* ############################################################ *)
 
 (** Domain **)
 
 (* Lemmas *)
 
 lemma domain_UN: "domain(\<Union>x \<in> A. B(x)) = (\<Union>x \<in> A. domain(B(x)))"
 by fast
 
 
 lemma domain_Sigma: "domain(Sigma(A,B)) = {x \<in> A. \<exists>y. y \<in> B(x)}"
 by blast
 
 (* Theorems *)
 
 lemma map_domain_emp: "domain(map_emp) = 0"
 by (unfold map_emp_def, blast)
 
 lemma map_domain_owr: 
   "b \<noteq> 0 \<Longrightarrow> domain(map_owr(f,a,b)) = {a} \<union> domain(f)"
   unfolding map_owr_def
 apply (auto simp add: domain_Sigma)
 done
 
 (** Application **)
 
 lemma map_app_owr: 
   "map_app(map_owr(f,a,b),c) = (if c=a then b else map_app(f,c))"
 by (simp add: qbeta_if  map_app_def map_owr_def, blast)
 
 lemma map_app_owr1: "map_app(map_owr(f,a,b),a) = b"
 by (simp add: map_app_owr)
 
 lemma map_app_owr2: "c \<noteq> a \<Longrightarrow> map_app(map_owr(f,a,b),c)= map_app(f,c)"
 by (simp add: map_app_owr)
 
 end
diff --git a/src/ZF/Coind/Values.thy b/src/ZF/Coind/Values.thy
--- a/src/ZF/Coind/Values.thy
+++ b/src/ZF/Coind/Values.thy
@@ -1,115 +1,115 @@
 (*  Title:      ZF/Coind/Values.thy
     Author:     Jacob Frost, Cambridge University Computer Laboratory
     Copyright   1995  University of Cambridge
 *)
 
 theory Values imports Language Map begin
 
 (* Values, values environments and associated operators *)
 
 consts
   Val  :: i
   ValEnv  :: i
   Val_ValEnv  :: i
 
 codatatype
     "Val" = v_const ("c \<in> Const")
           | v_clos ("x \<in> ExVar","e \<in> Exp","ve \<in> ValEnv")
   and
     "ValEnv" = ve_mk ("m \<in> PMap(ExVar,Val)")
   monos       PMap_mono
   type_intros  A_into_univ mapQU
 
 consts
   ve_owr :: "[i,i,i] \<Rightarrow> i"
   ve_dom :: "i\<Rightarrow>i"
   ve_app :: "[i,i] \<Rightarrow> i"
 
 
 primrec "ve_owr(ve_mk(m), x, v) = ve_mk(map_owr(m,x,v))"
 
 primrec "ve_dom(ve_mk(m)) = domain(m)"
 
 primrec "ve_app(ve_mk(m), a) = map_app(m,a)"
 
 definition
   ve_emp :: i  where
    "ve_emp \<equiv> ve_mk(map_emp)"
 
 
 (* Elimination rules *)
 
 lemma ValEnvE:
   "\<lbrakk>ve \<in> ValEnv; \<And>m.\<lbrakk>ve=ve_mk(m); m \<in> PMap(ExVar,Val)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
 apply (unfold Part_def Val_def ValEnv_def, clarify) 
 apply (erule Val_ValEnv.cases) 
 apply (auto simp add: Val_def Part_def Val_ValEnv.con_defs)
 done
 
 lemma ValE:
   "\<lbrakk>v \<in> Val;  
       \<And>c. \<lbrakk>v = v_const(c); c \<in> Const\<rbrakk> \<Longrightarrow> Q; 
       \<And>e ve x.  
         \<lbrakk>v = v_clos(x,e,ve); x \<in> ExVar; e \<in> Exp; ve \<in> ValEnv\<rbrakk> \<Longrightarrow> Q  
 \<rbrakk> \<Longrightarrow>  
    Q"
 apply (unfold Part_def Val_def ValEnv_def, clarify) 
 apply (erule Val_ValEnv.cases) 
 apply (auto simp add: ValEnv_def Part_def Val_ValEnv.con_defs)
 done
 
 (* Nonempty sets *)
 
 lemma v_closNE [simp]: "v_clos(x,e,ve) \<noteq> 0"
 by (unfold QPair_def QInl_def QInr_def Val_ValEnv.con_defs, blast)
 
 declare v_closNE [THEN notE, elim!]
 
 
 lemma v_constNE [simp]: "c \<in> Const \<Longrightarrow> v_const(c) \<noteq> 0"
-apply (unfold QPair_def QInl_def QInr_def Val_ValEnv.con_defs)
+  unfolding QPair_def QInl_def QInr_def Val_ValEnv.con_defs
 apply (drule constNEE, auto)
 done
 
 
 (* Proving that the empty set is not a value *)
 
 lemma ValNEE: "v \<in> Val \<Longrightarrow> v \<noteq> 0"
 by (erule ValE, auto)
 
 (* Equalities for value environments *)
 
 lemma ve_dom_owr [simp]:
      "\<lbrakk>ve \<in> ValEnv; v \<noteq>0\<rbrakk> \<Longrightarrow> ve_dom(ve_owr(ve,x,v)) = ve_dom(ve) \<union> {x}"
 apply (erule ValEnvE)
 apply (auto simp add: map_domain_owr)
 done
 
 lemma ve_app_owr [simp]:
      "ve \<in> ValEnv  
       \<Longrightarrow> ve_app(ve_owr(ve,y,v),x) = (if x=y then v else ve_app(ve,x))"
 by (erule ValEnvE, simp add: map_app_owr)
 
 (* Introduction rules for operators on value environments *)
 
 lemma ve_appI: "\<lbrakk>ve \<in> ValEnv; x \<in> ve_dom(ve)\<rbrakk> \<Longrightarrow> ve_app(ve,x):Val"
 by (erule ValEnvE, simp add: pmap_appI) 
 
 lemma ve_domI: "\<lbrakk>ve \<in> ValEnv; x \<in> ve_dom(ve)\<rbrakk> \<Longrightarrow> x \<in> ExVar"
 apply (erule ValEnvE, simp) 
 apply (blast dest: pmap_domainD)
 done
 
 lemma ve_empI: "ve_emp \<in> ValEnv"
   unfolding ve_emp_def
 apply (rule Val_ValEnv.intros)
 apply (rule pmap_empI)
 done
 
 lemma ve_owrI:
      "\<lbrakk>ve \<in> ValEnv; x \<in> ExVar; v \<in> Val\<rbrakk> \<Longrightarrow> ve_owr(ve,x,v):ValEnv"
 apply (erule ValEnvE, simp)
 apply (blast intro: pmap_owrI Val_ValEnv.intros)
 done
 
 end
diff --git a/src/ZF/Constructible/L_axioms.thy b/src/ZF/Constructible/L_axioms.thy
--- a/src/ZF/Constructible/L_axioms.thy
+++ b/src/ZF/Constructible/L_axioms.thy
@@ -1,1403 +1,1403 @@
 (*  Title:      ZF/Constructible/L_axioms.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
 *)
 
 section \<open>The ZF Axioms (Except Separation) in L\<close>
 
 theory L_axioms imports Formula Relative Reflection MetaExists begin
 
 text \<open>The class L satisfies the premises of locale \<open>M_trivial\<close>\<close>
 
 lemma transL: "\<lbrakk>y\<in>x; L(x)\<rbrakk> \<Longrightarrow> L(y)"
 apply (insert Transset_Lset)
 apply (simp add: Transset_def L_def, blast)
 done
 
 lemma nonempty: "L(0)"
 apply (simp add: L_def)
 apply (blast intro: zero_in_Lset)
 done
 
 theorem upair_ax: "upair_ax(L)"
 apply (simp add: upair_ax_def upair_def, clarify)
 apply (rule_tac x="{x,y}" in rexI)
 apply (simp_all add: doubleton_in_L)
 done
 
 theorem Union_ax: "Union_ax(L)"
 apply (simp add: Union_ax_def big_union_def, clarify)
 apply (rule_tac x="\<Union>(x)" in rexI)
 apply (simp_all add: Union_in_L, auto)
 apply (blast intro: transL)
 done
 
 theorem power_ax: "power_ax(L)"
 apply (simp add: power_ax_def powerset_def Relative.subset_def, clarify)
 apply (rule_tac x="{y \<in> Pow(x). L(y)}" in rexI)
 apply (simp_all add: LPow_in_L, auto)
 apply (blast intro: transL)
 done
 
 text\<open>We don't actually need \<^term>\<open>L\<close> to satisfy the foundation axiom.\<close>
 theorem foundation_ax: "foundation_ax(L)"
 apply (simp add: foundation_ax_def)
 apply (rule rallI) 
 apply (cut_tac A=x in foundation)
 apply (blast intro: transL)
 done
 
 subsection\<open>For L to satisfy Replacement\<close>
 
 (*Can't move these to Formula unless the definition of univalent is moved
 there too!*)
 
 lemma LReplace_in_Lset:
      "\<lbrakk>X \<in> Lset(i); univalent(L,X,Q); Ord(i)\<rbrakk>
       \<Longrightarrow> \<exists>j. Ord(j) \<and> Replace(X, \<lambda>x y. Q(x,y) \<and> L(y)) \<subseteq> Lset(j)"
 apply (rule_tac x="\<Union>y \<in> Replace(X, \<lambda>x y. Q(x,y) \<and> L(y)). succ(lrank(y))"
        in exI)
 apply simp
 apply clarify
 apply (rule_tac a=x in UN_I)
  apply (simp_all add: Replace_iff univalent_def)
 apply (blast dest: transL L_I)
 done
 
 lemma LReplace_in_L:
      "\<lbrakk>L(X); univalent(L,X,Q)\<rbrakk>
       \<Longrightarrow> \<exists>Y. L(Y) \<and> Replace(X, \<lambda>x y. Q(x,y) \<and> L(y)) \<subseteq> Y"
 apply (drule L_D, clarify)
 apply (drule LReplace_in_Lset, assumption+)
 apply (blast intro: L_I Lset_in_Lset_succ)
 done
 
 theorem replacement: "replacement(L,P)"
 apply (simp add: replacement_def, clarify)
 apply (frule LReplace_in_L, assumption+, clarify)
 apply (rule_tac x=Y in rexI)
 apply (simp_all add: Replace_iff univalent_def, blast)
 done
 
 lemma strong_replacementI [rule_format]:
     "\<lbrakk>\<forall>B[L]. separation(L, \<lambda>u. \<exists>x[L]. x\<in>B \<and> P(x,u))\<rbrakk>
      \<Longrightarrow> strong_replacement(L,P)"
 apply (simp add: strong_replacement_def, clarify)
 apply (frule replacementD [OF replacement], assumption, clarify)
 apply (drule_tac x=A in rspec, clarify)
 apply (drule_tac z=Y in separationD, assumption, clarify)
 apply (rule_tac x=y in rexI, force, assumption)
 done
 
 
 subsection\<open>Instantiating the locale \<open>M_trivial\<close>\<close>
 text\<open>No instances of Separation yet.\<close>
 
 lemma Lset_mono_le: "mono_le_subset(Lset)"
 by (simp add: mono_le_subset_def le_imp_subset Lset_mono)
 
 lemma Lset_cont: "cont_Ord(Lset)"
 by (simp add: cont_Ord_def Limit_Lset_eq OUnion_def Limit_is_Ord)
 
 lemmas L_nat = Ord_in_L [OF Ord_nat]
 
 theorem M_trivial_L: "M_trivial(L)"
   apply (rule M_trivial.intro)
   apply (rule M_trans.intro)
     apply (erule (1) transL)
    apply(rule exI,rule  nonempty)
   apply (rule M_trivial_axioms.intro)
       apply (rule upair_ax)
    apply (rule Union_ax)
   done
 
 interpretation L: M_trivial L by (rule M_trivial_L)
 
 (* Replaces the following declarations...
 lemmas rall_abs = M_trivial.rall_abs [OF M_trivial_L]
   and rex_abs = M_trivial.rex_abs [OF M_trivial_L]
 ...
 declare rall_abs [simp]
 declare rex_abs [simp]
 ...and dozens of similar ones.
 *)
 
 subsection\<open>Instantiation of the locale \<open>reflection\<close>\<close>
 
 text\<open>instances of locale constants\<close>
 
 definition
   L_F0 :: "[i\<Rightarrow>o,i] \<Rightarrow> i" where
     "L_F0(P,y) \<equiv> \<mu> b. (\<exists>z. L(z) \<and> P(\<langle>y,z\<rangle>)) \<longrightarrow> (\<exists>z\<in>Lset(b). P(\<langle>y,z\<rangle>))"
 
 definition
   L_FF :: "[i\<Rightarrow>o,i] \<Rightarrow> i" where
     "L_FF(P)   \<equiv> \<lambda>a. \<Union>y\<in>Lset(a). L_F0(P,y)"
 
 definition
   L_ClEx :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     "L_ClEx(P) \<equiv> \<lambda>a. Limit(a) \<and> normalize(L_FF(P),a) = a"
 
 
 text\<open>We must use the meta-existential quantifier; otherwise the reflection
       terms become enormous!\<close>
 definition
   L_Reflects :: "[i\<Rightarrow>o,[i,i]\<Rightarrow>o] \<Rightarrow> prop"  (\<open>(3REFLECTS/ [_,/ _])\<close>) where
     "REFLECTS[P,Q] \<equiv> (\<Or>Cl. Closed_Unbounded(Cl) \<and>
                            (\<forall>a. Cl(a) \<longrightarrow> (\<forall>x \<in> Lset(a). P(x) \<longleftrightarrow> Q(a,x))))"
 
 
 theorem Triv_reflection:
      "REFLECTS[P, \<lambda>a x. P(x)]"
 apply (simp add: L_Reflects_def)
 apply (rule meta_exI)
 apply (rule Closed_Unbounded_Ord)
 done
 
 theorem Not_reflection:
      "REFLECTS[P,Q] \<Longrightarrow> REFLECTS[\<lambda>x. \<not>P(x), \<lambda>a x. \<not>Q(a,x)]"
   unfolding L_Reflects_def
 apply (erule meta_exE)
 apply (rule_tac x=Cl in meta_exI, simp)
 done
 
 theorem And_reflection:
      "\<lbrakk>REFLECTS[P,Q]; REFLECTS[P',Q']\<rbrakk>
       \<Longrightarrow> REFLECTS[\<lambda>x. P(x) \<and> P'(x), \<lambda>a x. Q(a,x) \<and> Q'(a,x)]"
   unfolding L_Reflects_def
 apply (elim meta_exE)
 apply (rule_tac x="\<lambda>a. Cl(a) \<and> Cla(a)" in meta_exI)
 apply (simp add: Closed_Unbounded_Int, blast)
 done
 
 theorem Or_reflection:
      "\<lbrakk>REFLECTS[P,Q]; REFLECTS[P',Q']\<rbrakk>
       \<Longrightarrow> REFLECTS[\<lambda>x. P(x) \<or> P'(x), \<lambda>a x. Q(a,x) \<or> Q'(a,x)]"
   unfolding L_Reflects_def
 apply (elim meta_exE)
 apply (rule_tac x="\<lambda>a. Cl(a) \<and> Cla(a)" in meta_exI)
 apply (simp add: Closed_Unbounded_Int, blast)
 done
 
 theorem Imp_reflection:
      "\<lbrakk>REFLECTS[P,Q]; REFLECTS[P',Q']\<rbrakk>
       \<Longrightarrow> REFLECTS[\<lambda>x. P(x) \<longrightarrow> P'(x), \<lambda>a x. Q(a,x) \<longrightarrow> Q'(a,x)]"
   unfolding L_Reflects_def
 apply (elim meta_exE)
 apply (rule_tac x="\<lambda>a. Cl(a) \<and> Cla(a)" in meta_exI)
 apply (simp add: Closed_Unbounded_Int, blast)
 done
 
 theorem Iff_reflection:
      "\<lbrakk>REFLECTS[P,Q]; REFLECTS[P',Q']\<rbrakk>
       \<Longrightarrow> REFLECTS[\<lambda>x. P(x) \<longleftrightarrow> P'(x), \<lambda>a x. Q(a,x) \<longleftrightarrow> Q'(a,x)]"
   unfolding L_Reflects_def
 apply (elim meta_exE)
 apply (rule_tac x="\<lambda>a. Cl(a) \<and> Cla(a)" in meta_exI)
 apply (simp add: Closed_Unbounded_Int, blast)
 done
 
 
 lemma reflection_Lset: "reflection(Lset)"
 by (blast intro: reflection.intro Lset_mono_le Lset_cont 
                  Formula.Pair_in_LLimit)+
 
 
 theorem Ex_reflection:
      "REFLECTS[\<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x))]
       \<Longrightarrow> REFLECTS[\<lambda>x. \<exists>z. L(z) \<and> P(x,z), \<lambda>a x. \<exists>z\<in>Lset(a). Q(a,x,z)]"
-apply (unfold L_Reflects_def L_ClEx_def L_FF_def L_F0_def L_def)
+  unfolding L_Reflects_def L_ClEx_def L_FF_def L_F0_def L_def
 apply (elim meta_exE)
 apply (rule meta_exI)
 apply (erule reflection.Ex_reflection [OF reflection_Lset])
 done
 
 theorem All_reflection:
      "REFLECTS[\<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x))]
       \<Longrightarrow> REFLECTS[\<lambda>x. \<forall>z. L(z) \<longrightarrow> P(x,z), \<lambda>a x. \<forall>z\<in>Lset(a). Q(a,x,z)]"
-apply (unfold L_Reflects_def L_ClEx_def L_FF_def L_F0_def L_def)
+  unfolding L_Reflects_def L_ClEx_def L_FF_def L_F0_def L_def
 apply (elim meta_exE)
 apply (rule meta_exI)
 apply (erule reflection.All_reflection [OF reflection_Lset])
 done
 
 theorem Rex_reflection:
      "REFLECTS[ \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x))]
       \<Longrightarrow> REFLECTS[\<lambda>x. \<exists>z[L]. P(x,z), \<lambda>a x. \<exists>z\<in>Lset(a). Q(a,x,z)]"
   unfolding rex_def
 apply (intro And_reflection Ex_reflection, assumption)
 done
 
 theorem Rall_reflection:
      "REFLECTS[\<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x))]
       \<Longrightarrow> REFLECTS[\<lambda>x. \<forall>z[L]. P(x,z), \<lambda>a x. \<forall>z\<in>Lset(a). Q(a,x,z)]"
   unfolding rall_def
 apply (intro Imp_reflection All_reflection, assumption)
 done
 
 text\<open>This version handles an alternative form of the bounded quantifier
       in the second argument of \<open>REFLECTS\<close>.\<close>
 theorem Rex_reflection':
      "REFLECTS[\<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x))]
       \<Longrightarrow> REFLECTS[\<lambda>x. \<exists>z[L]. P(x,z), \<lambda>a x. \<exists>z[##Lset(a)]. Q(a,x,z)]"
-apply (unfold setclass_def rex_def)
+  unfolding setclass_def rex_def
 apply (erule Rex_reflection [unfolded rex_def Bex_def]) 
 done
 
 text\<open>As above.\<close>
 theorem Rall_reflection':
      "REFLECTS[\<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x))]
       \<Longrightarrow> REFLECTS[\<lambda>x. \<forall>z[L]. P(x,z), \<lambda>a x. \<forall>z[##Lset(a)]. Q(a,x,z)]"
-apply (unfold setclass_def rall_def)
+  unfolding setclass_def rall_def
 apply (erule Rall_reflection [unfolded rall_def Ball_def]) 
 done
 
 lemmas FOL_reflections =
         Triv_reflection Not_reflection And_reflection Or_reflection
         Imp_reflection Iff_reflection Ex_reflection All_reflection
         Rex_reflection Rall_reflection Rex_reflection' Rall_reflection'
 
 lemma ReflectsD:
      "\<lbrakk>REFLECTS[P,Q]; Ord(i)\<rbrakk>
       \<Longrightarrow> \<exists>j. i<j \<and> (\<forall>x \<in> Lset(j). P(x) \<longleftrightarrow> Q(j,x))"
-apply (unfold L_Reflects_def Closed_Unbounded_def)
+  unfolding L_Reflects_def Closed_Unbounded_def
 apply (elim meta_exE, clarify)
 apply (blast dest!: UnboundedD)
 done
 
 lemma ReflectsE:
      "\<lbrakk>REFLECTS[P,Q]; Ord(i);
          \<And>j. \<lbrakk>i<j;  \<forall>x \<in> Lset(j). P(x) \<longleftrightarrow> Q(j,x)\<rbrakk> \<Longrightarrow> R\<rbrakk>
       \<Longrightarrow> R"
 by (drule ReflectsD, assumption, blast)
 
 lemma Collect_mem_eq: "{x\<in>A. x\<in>B} = A \<inter> B"
 by blast
 
 
 subsection\<open>Internalized Formulas for some Set-Theoretic Concepts\<close>
 
 subsubsection\<open>Some numbers to help write de Bruijn indices\<close>
 
 abbreviation
   digit3 :: i   (\<open>3\<close>) where "3 \<equiv> succ(2)"
 
 abbreviation
   digit4 :: i   (\<open>4\<close>) where "4 \<equiv> succ(3)"
 
 abbreviation
   digit5 :: i   (\<open>5\<close>) where "5 \<equiv> succ(4)"
 
 abbreviation
   digit6 :: i   (\<open>6\<close>) where "6 \<equiv> succ(5)"
 
 abbreviation
   digit7 :: i   (\<open>7\<close>) where "7 \<equiv> succ(6)"
 
 abbreviation
   digit8 :: i   (\<open>8\<close>) where "8 \<equiv> succ(7)"
 
 abbreviation
   digit9 :: i   (\<open>9\<close>) where "9 \<equiv> succ(8)"
 
 
 subsubsection\<open>The Empty Set, Internalized\<close>
 
 definition
   empty_fm :: "i\<Rightarrow>i" where
     "empty_fm(x) \<equiv> Forall(Neg(Member(0,succ(x))))"
 
 lemma empty_type [TC]:
      "x \<in> nat \<Longrightarrow> empty_fm(x) \<in> formula"
 by (simp add: empty_fm_def)
 
 lemma sats_empty_fm [simp]:
    "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, empty_fm(x), env) \<longleftrightarrow> empty(##A, nth(x,env))"
 by (simp add: empty_fm_def empty_def)
 
 lemma empty_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> empty(##A, x) \<longleftrightarrow> sats(A, empty_fm(i), env)"
 by simp
 
 theorem empty_reflection:
      "REFLECTS[\<lambda>x. empty(L,f(x)),
                \<lambda>i x. empty(##Lset(i),f(x))]"
 apply (simp only: empty_def)
 apply (intro FOL_reflections)
 done
 
 text\<open>Not used.  But maybe useful?\<close>
 lemma Transset_sats_empty_fm_eq_0:
    "\<lbrakk>n \<in> nat; env \<in> list(A); Transset(A)\<rbrakk>
     \<Longrightarrow> sats(A, empty_fm(n), env) \<longleftrightarrow> nth(n,env) = 0"
 apply (simp add: empty_fm_def empty_def Transset_def, auto)
 apply (case_tac "n < length(env)")
 apply (frule nth_type, assumption+, blast)
 apply (simp_all add: not_lt_iff_le nth_eq_0)
 done
 
 
 subsubsection\<open>Unordered Pairs, Internalized\<close>
 
 definition
   upair_fm :: "[i,i,i]\<Rightarrow>i" where
     "upair_fm(x,y,z) \<equiv>
        And(Member(x,z),
            And(Member(y,z),
                Forall(Implies(Member(0,succ(z)),
                               Or(Equal(0,succ(x)), Equal(0,succ(y)))))))"
 
 lemma upair_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> upair_fm(x,y,z) \<in> formula"
 by (simp add: upair_fm_def)
 
 lemma sats_upair_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, upair_fm(x,y,z), env) \<longleftrightarrow>
             upair(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: upair_fm_def upair_def)
 
 lemma upair_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
           i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> upair(##A, x, y, z) \<longleftrightarrow> sats(A, upair_fm(i,j,k), env)"
 by (simp)
 
 text\<open>Useful? At least it refers to "real" unordered pairs\<close>
 lemma sats_upair_fm2 [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z < length(env); env \<in> list(A); Transset(A)\<rbrakk>
     \<Longrightarrow> sats(A, upair_fm(x,y,z), env) \<longleftrightarrow>
         nth(z,env) = {nth(x,env), nth(y,env)}"
 apply (frule lt_length_in_nat, assumption)
 apply (simp add: upair_fm_def Transset_def, auto)
 apply (blast intro: nth_type)
 done
 
 theorem upair_reflection:
      "REFLECTS[\<lambda>x. upair(L,f(x),g(x),h(x)),
                \<lambda>i x. upair(##Lset(i),f(x),g(x),h(x))]"
 apply (simp add: upair_def)
 apply (intro FOL_reflections)
 done
 
 subsubsection\<open>Ordered pairs, Internalized\<close>
 
 definition
   pair_fm :: "[i,i,i]\<Rightarrow>i" where
     "pair_fm(x,y,z) \<equiv>
        Exists(And(upair_fm(succ(x),succ(x),0),
               Exists(And(upair_fm(succ(succ(x)),succ(succ(y)),0),
                          upair_fm(1,0,succ(succ(z)))))))"
 
 lemma pair_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> pair_fm(x,y,z) \<in> formula"
 by (simp add: pair_fm_def)
 
 lemma sats_pair_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, pair_fm(x,y,z), env) \<longleftrightarrow>
         pair(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: pair_fm_def pair_def)
 
 lemma pair_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
           i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> pair(##A, x, y, z) \<longleftrightarrow> sats(A, pair_fm(i,j,k), env)"
 by (simp)
 
 theorem pair_reflection:
      "REFLECTS[\<lambda>x. pair(L,f(x),g(x),h(x)),
                \<lambda>i x. pair(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: pair_def)
 apply (intro FOL_reflections upair_reflection)
 done
 
 
 subsubsection\<open>Binary Unions, Internalized\<close>
 
 definition
   union_fm :: "[i,i,i]\<Rightarrow>i" where
     "union_fm(x,y,z) \<equiv>
        Forall(Iff(Member(0,succ(z)),
                   Or(Member(0,succ(x)),Member(0,succ(y)))))"
 
 lemma union_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> union_fm(x,y,z) \<in> formula"
 by (simp add: union_fm_def)
 
 lemma sats_union_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, union_fm(x,y,z), env) \<longleftrightarrow>
         union(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: union_fm_def union_def)
 
 lemma union_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
           i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> union(##A, x, y, z) \<longleftrightarrow> sats(A, union_fm(i,j,k), env)"
 by (simp)
 
 theorem union_reflection:
      "REFLECTS[\<lambda>x. union(L,f(x),g(x),h(x)),
                \<lambda>i x. union(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: union_def)
 apply (intro FOL_reflections)
 done
 
 
 subsubsection\<open>Set ``Cons,'' Internalized\<close>
 
 definition
   cons_fm :: "[i,i,i]\<Rightarrow>i" where
     "cons_fm(x,y,z) \<equiv>
        Exists(And(upair_fm(succ(x),succ(x),0),
                   union_fm(0,succ(y),succ(z))))"
 
 
 lemma cons_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> cons_fm(x,y,z) \<in> formula"
 by (simp add: cons_fm_def)
 
 lemma sats_cons_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, cons_fm(x,y,z), env) \<longleftrightarrow>
         is_cons(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: cons_fm_def is_cons_def)
 
 lemma cons_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
           i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> is_cons(##A, x, y, z) \<longleftrightarrow> sats(A, cons_fm(i,j,k), env)"
 by simp
 
 theorem cons_reflection:
      "REFLECTS[\<lambda>x. is_cons(L,f(x),g(x),h(x)),
                \<lambda>i x. is_cons(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: is_cons_def)
 apply (intro FOL_reflections upair_reflection union_reflection)
 done
 
 
 subsubsection\<open>Successor Function, Internalized\<close>
 
 definition
   succ_fm :: "[i,i]\<Rightarrow>i" where
     "succ_fm(x,y) \<equiv> cons_fm(x,x,y)"
 
 lemma succ_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> succ_fm(x,y) \<in> formula"
 by (simp add: succ_fm_def)
 
 lemma sats_succ_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, succ_fm(x,y), env) \<longleftrightarrow>
         successor(##A, nth(x,env), nth(y,env))"
 by (simp add: succ_fm_def successor_def)
 
 lemma successor_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> successor(##A, x, y) \<longleftrightarrow> sats(A, succ_fm(i,j), env)"
 by simp
 
 theorem successor_reflection:
      "REFLECTS[\<lambda>x. successor(L,f(x),g(x)),
                \<lambda>i x. successor(##Lset(i),f(x),g(x))]"
 apply (simp only: successor_def)
 apply (intro cons_reflection)
 done
 
 
 subsubsection\<open>The Number 1, Internalized\<close>
 
 (* "number1(M,a) \<equiv> (\<exists>x[M]. empty(M,x) \<and> successor(M,x,a))" *)
 definition
   number1_fm :: "i\<Rightarrow>i" where
     "number1_fm(a) \<equiv> Exists(And(empty_fm(0), succ_fm(0,succ(a))))"
 
 lemma number1_type [TC]:
      "x \<in> nat \<Longrightarrow> number1_fm(x) \<in> formula"
 by (simp add: number1_fm_def)
 
 lemma sats_number1_fm [simp]:
    "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, number1_fm(x), env) \<longleftrightarrow> number1(##A, nth(x,env))"
 by (simp add: number1_fm_def number1_def)
 
 lemma number1_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> number1(##A, x) \<longleftrightarrow> sats(A, number1_fm(i), env)"
 by simp
 
 theorem number1_reflection:
      "REFLECTS[\<lambda>x. number1(L,f(x)),
                \<lambda>i x. number1(##Lset(i),f(x))]"
 apply (simp only: number1_def)
 apply (intro FOL_reflections empty_reflection successor_reflection)
 done
 
 
 subsubsection\<open>Big Union, Internalized\<close>
 
 (*  "big_union(M,A,z) \<equiv> \<forall>x[M]. x \<in> z \<longleftrightarrow> (\<exists>y[M]. y\<in>A \<and> x \<in> y)" *)
 definition
   big_union_fm :: "[i,i]\<Rightarrow>i" where
     "big_union_fm(A,z) \<equiv>
        Forall(Iff(Member(0,succ(z)),
                   Exists(And(Member(0,succ(succ(A))), Member(1,0)))))"
 
 lemma big_union_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> big_union_fm(x,y) \<in> formula"
 by (simp add: big_union_fm_def)
 
 lemma sats_big_union_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, big_union_fm(x,y), env) \<longleftrightarrow>
         big_union(##A, nth(x,env), nth(y,env))"
 by (simp add: big_union_fm_def big_union_def)
 
 lemma big_union_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> big_union(##A, x, y) \<longleftrightarrow> sats(A, big_union_fm(i,j), env)"
 by simp
 
 theorem big_union_reflection:
      "REFLECTS[\<lambda>x. big_union(L,f(x),g(x)),
                \<lambda>i x. big_union(##Lset(i),f(x),g(x))]"
 apply (simp only: big_union_def)
 apply (intro FOL_reflections)
 done
 
 
 subsubsection\<open>Variants of Satisfaction Definitions for Ordinals, etc.\<close>
 
 text\<open>The \<open>sats\<close> theorems below are standard versions of the ones proved
 in theory \<open>Formula\<close>.  They relate elements of type \<^term>\<open>formula\<close> to
 relativized concepts such as \<^term>\<open>subset\<close> or \<^term>\<open>ordinal\<close> rather than to
 real concepts such as \<^term>\<open>Ord\<close>.  Now that we have instantiated the locale
 \<open>M_trivial\<close>, we no longer require the earlier versions.\<close>
 
 lemma sats_subset_fm':
    "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, subset_fm(x,y), env) \<longleftrightarrow> subset(##A, nth(x,env), nth(y,env))"
 by (simp add: subset_fm_def Relative.subset_def)
 
 theorem subset_reflection:
      "REFLECTS[\<lambda>x. subset(L,f(x),g(x)),
                \<lambda>i x. subset(##Lset(i),f(x),g(x))]"
 apply (simp only: Relative.subset_def)
 apply (intro FOL_reflections)
 done
 
 lemma sats_transset_fm':
    "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, transset_fm(x), env) \<longleftrightarrow> transitive_set(##A, nth(x,env))"
 by (simp add: sats_subset_fm' transset_fm_def transitive_set_def)
 
 theorem transitive_set_reflection:
      "REFLECTS[\<lambda>x. transitive_set(L,f(x)),
                \<lambda>i x. transitive_set(##Lset(i),f(x))]"
 apply (simp only: transitive_set_def)
 apply (intro FOL_reflections subset_reflection)
 done
 
 lemma sats_ordinal_fm':
    "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, ordinal_fm(x), env) \<longleftrightarrow> ordinal(##A,nth(x,env))"
 by (simp add: sats_transset_fm' ordinal_fm_def ordinal_def)
 
 lemma ordinal_iff_sats:
       "\<lbrakk>nth(i,env) = x;  i \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> ordinal(##A, x) \<longleftrightarrow> sats(A, ordinal_fm(i), env)"
 by (simp add: sats_ordinal_fm')
 
 theorem ordinal_reflection:
      "REFLECTS[\<lambda>x. ordinal(L,f(x)), \<lambda>i x. ordinal(##Lset(i),f(x))]"
 apply (simp only: ordinal_def)
 apply (intro FOL_reflections transitive_set_reflection)
 done
 
 
 subsubsection\<open>Membership Relation, Internalized\<close>
 
 definition
   Memrel_fm :: "[i,i]\<Rightarrow>i" where
     "Memrel_fm(A,r) \<equiv>
        Forall(Iff(Member(0,succ(r)),
                   Exists(And(Member(0,succ(succ(A))),
                              Exists(And(Member(0,succ(succ(succ(A)))),
                                         And(Member(1,0),
                                             pair_fm(1,0,2))))))))"
 
 lemma Memrel_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> Memrel_fm(x,y) \<in> formula"
 by (simp add: Memrel_fm_def)
 
 lemma sats_Memrel_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, Memrel_fm(x,y), env) \<longleftrightarrow>
         membership(##A, nth(x,env), nth(y,env))"
 by (simp add: Memrel_fm_def membership_def)
 
 lemma Memrel_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> membership(##A, x, y) \<longleftrightarrow> sats(A, Memrel_fm(i,j), env)"
 by simp
 
 theorem membership_reflection:
      "REFLECTS[\<lambda>x. membership(L,f(x),g(x)),
                \<lambda>i x. membership(##Lset(i),f(x),g(x))]"
 apply (simp only: membership_def)
 apply (intro FOL_reflections pair_reflection)
 done
 
 subsubsection\<open>Predecessor Set, Internalized\<close>
 
 definition
   pred_set_fm :: "[i,i,i,i]\<Rightarrow>i" where
     "pred_set_fm(A,x,r,B) \<equiv>
        Forall(Iff(Member(0,succ(B)),
                   Exists(And(Member(0,succ(succ(r))),
                              And(Member(1,succ(succ(A))),
                                  pair_fm(1,succ(succ(x)),0))))))"
 
 
 lemma pred_set_type [TC]:
      "\<lbrakk>A \<in> nat; x \<in> nat; r \<in> nat; B \<in> nat\<rbrakk>
       \<Longrightarrow> pred_set_fm(A,x,r,B) \<in> formula"
 by (simp add: pred_set_fm_def)
 
 lemma sats_pred_set_fm [simp]:
    "\<lbrakk>U \<in> nat; x \<in> nat; r \<in> nat; B \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, pred_set_fm(U,x,r,B), env) \<longleftrightarrow>
         pred_set(##A, nth(U,env), nth(x,env), nth(r,env), nth(B,env))"
 by (simp add: pred_set_fm_def pred_set_def)
 
 lemma pred_set_iff_sats:
       "\<lbrakk>nth(i,env) = U; nth(j,env) = x; nth(k,env) = r; nth(l,env) = B;
           i \<in> nat; j \<in> nat; k \<in> nat; l \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> pred_set(##A,U,x,r,B) \<longleftrightarrow> sats(A, pred_set_fm(i,j,k,l), env)"
 by (simp)
 
 theorem pred_set_reflection:
      "REFLECTS[\<lambda>x. pred_set(L,f(x),g(x),h(x),b(x)),
                \<lambda>i x. pred_set(##Lset(i),f(x),g(x),h(x),b(x))]"
 apply (simp only: pred_set_def)
 apply (intro FOL_reflections pair_reflection)
 done
 
 
 
 subsubsection\<open>Domain of a Relation, Internalized\<close>
 
 (* "is_domain(M,r,z) \<equiv>
         \<forall>x[M]. (x \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r \<and> (\<exists>y[M]. pair(M,x,y,w))))" *)
 definition
   domain_fm :: "[i,i]\<Rightarrow>i" where
     "domain_fm(r,z) \<equiv>
        Forall(Iff(Member(0,succ(z)),
                   Exists(And(Member(0,succ(succ(r))),
                              Exists(pair_fm(2,0,1))))))"
 
 lemma domain_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> domain_fm(x,y) \<in> formula"
 by (simp add: domain_fm_def)
 
 lemma sats_domain_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, domain_fm(x,y), env) \<longleftrightarrow>
         is_domain(##A, nth(x,env), nth(y,env))"
 by (simp add: domain_fm_def is_domain_def)
 
 lemma domain_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> is_domain(##A, x, y) \<longleftrightarrow> sats(A, domain_fm(i,j), env)"
 by simp
 
 theorem domain_reflection:
      "REFLECTS[\<lambda>x. is_domain(L,f(x),g(x)),
                \<lambda>i x. is_domain(##Lset(i),f(x),g(x))]"
 apply (simp only: is_domain_def)
 apply (intro FOL_reflections pair_reflection)
 done
 
 
 subsubsection\<open>Range of a Relation, Internalized\<close>
 
 (* "is_range(M,r,z) \<equiv>
         \<forall>y[M]. (y \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r \<and> (\<exists>x[M]. pair(M,x,y,w))))" *)
 definition
   range_fm :: "[i,i]\<Rightarrow>i" where
     "range_fm(r,z) \<equiv>
        Forall(Iff(Member(0,succ(z)),
                   Exists(And(Member(0,succ(succ(r))),
                              Exists(pair_fm(0,2,1))))))"
 
 lemma range_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> range_fm(x,y) \<in> formula"
 by (simp add: range_fm_def)
 
 lemma sats_range_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, range_fm(x,y), env) \<longleftrightarrow>
         is_range(##A, nth(x,env), nth(y,env))"
 by (simp add: range_fm_def is_range_def)
 
 lemma range_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> is_range(##A, x, y) \<longleftrightarrow> sats(A, range_fm(i,j), env)"
 by simp
 
 theorem range_reflection:
      "REFLECTS[\<lambda>x. is_range(L,f(x),g(x)),
                \<lambda>i x. is_range(##Lset(i),f(x),g(x))]"
 apply (simp only: is_range_def)
 apply (intro FOL_reflections pair_reflection)
 done
 
 
 subsubsection\<open>Field of a Relation, Internalized\<close>
 
 (* "is_field(M,r,z) \<equiv>
         \<exists>dr[M]. is_domain(M,r,dr) \<and>
             (\<exists>rr[M]. is_range(M,r,rr) \<and> union(M,dr,rr,z))" *)
 definition
   field_fm :: "[i,i]\<Rightarrow>i" where
     "field_fm(r,z) \<equiv>
        Exists(And(domain_fm(succ(r),0),
               Exists(And(range_fm(succ(succ(r)),0),
                          union_fm(1,0,succ(succ(z)))))))"
 
 lemma field_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> field_fm(x,y) \<in> formula"
 by (simp add: field_fm_def)
 
 lemma sats_field_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, field_fm(x,y), env) \<longleftrightarrow>
         is_field(##A, nth(x,env), nth(y,env))"
 by (simp add: field_fm_def is_field_def)
 
 lemma field_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> is_field(##A, x, y) \<longleftrightarrow> sats(A, field_fm(i,j), env)"
 by simp
 
 theorem field_reflection:
      "REFLECTS[\<lambda>x. is_field(L,f(x),g(x)),
                \<lambda>i x. is_field(##Lset(i),f(x),g(x))]"
 apply (simp only: is_field_def)
 apply (intro FOL_reflections domain_reflection range_reflection
              union_reflection)
 done
 
 
 subsubsection\<open>Image under a Relation, Internalized\<close>
 
 (* "image(M,r,A,z) \<equiv>
         \<forall>y[M]. (y \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r \<and> (\<exists>x[M]. x\<in>A \<and> pair(M,x,y,w))))" *)
 definition
   image_fm :: "[i,i,i]\<Rightarrow>i" where
     "image_fm(r,A,z) \<equiv>
        Forall(Iff(Member(0,succ(z)),
                   Exists(And(Member(0,succ(succ(r))),
                              Exists(And(Member(0,succ(succ(succ(A)))),
                                         pair_fm(0,2,1)))))))"
 
 lemma image_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> image_fm(x,y,z) \<in> formula"
 by (simp add: image_fm_def)
 
 lemma sats_image_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, image_fm(x,y,z), env) \<longleftrightarrow>
         image(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: image_fm_def Relative.image_def)
 
 lemma image_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
           i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> image(##A, x, y, z) \<longleftrightarrow> sats(A, image_fm(i,j,k), env)"
 by (simp)
 
 theorem image_reflection:
      "REFLECTS[\<lambda>x. image(L,f(x),g(x),h(x)),
                \<lambda>i x. image(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: Relative.image_def)
 apply (intro FOL_reflections pair_reflection)
 done
 
 
 subsubsection\<open>Pre-Image under a Relation, Internalized\<close>
 
 (* "pre_image(M,r,A,z) \<equiv>
         \<forall>x[M]. x \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r \<and> (\<exists>y[M]. y\<in>A \<and> pair(M,x,y,w)))" *)
 definition
   pre_image_fm :: "[i,i,i]\<Rightarrow>i" where
     "pre_image_fm(r,A,z) \<equiv>
        Forall(Iff(Member(0,succ(z)),
                   Exists(And(Member(0,succ(succ(r))),
                              Exists(And(Member(0,succ(succ(succ(A)))),
                                         pair_fm(2,0,1)))))))"
 
 lemma pre_image_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> pre_image_fm(x,y,z) \<in> formula"
 by (simp add: pre_image_fm_def)
 
 lemma sats_pre_image_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, pre_image_fm(x,y,z), env) \<longleftrightarrow>
         pre_image(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: pre_image_fm_def Relative.pre_image_def)
 
 lemma pre_image_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
           i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> pre_image(##A, x, y, z) \<longleftrightarrow> sats(A, pre_image_fm(i,j,k), env)"
 by (simp)
 
 theorem pre_image_reflection:
      "REFLECTS[\<lambda>x. pre_image(L,f(x),g(x),h(x)),
                \<lambda>i x. pre_image(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: Relative.pre_image_def)
 apply (intro FOL_reflections pair_reflection)
 done
 
 
 subsubsection\<open>Function Application, Internalized\<close>
 
 (* "fun_apply(M,f,x,y) \<equiv>
         (\<exists>xs[M]. \<exists>fxs[M].
          upair(M,x,x,xs) \<and> image(M,f,xs,fxs) \<and> big_union(M,fxs,y))" *)
 definition
   fun_apply_fm :: "[i,i,i]\<Rightarrow>i" where
     "fun_apply_fm(f,x,y) \<equiv>
        Exists(Exists(And(upair_fm(succ(succ(x)), succ(succ(x)), 1),
                          And(image_fm(succ(succ(f)), 1, 0),
                              big_union_fm(0,succ(succ(y)))))))"
 
 lemma fun_apply_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> fun_apply_fm(x,y,z) \<in> formula"
 by (simp add: fun_apply_fm_def)
 
 lemma sats_fun_apply_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, fun_apply_fm(x,y,z), env) \<longleftrightarrow>
         fun_apply(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: fun_apply_fm_def fun_apply_def)
 
 lemma fun_apply_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
           i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> fun_apply(##A, x, y, z) \<longleftrightarrow> sats(A, fun_apply_fm(i,j,k), env)"
 by simp
 
 theorem fun_apply_reflection:
      "REFLECTS[\<lambda>x. fun_apply(L,f(x),g(x),h(x)),
                \<lambda>i x. fun_apply(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: fun_apply_def)
 apply (intro FOL_reflections upair_reflection image_reflection
              big_union_reflection)
 done
 
 
 subsubsection\<open>The Concept of Relation, Internalized\<close>
 
 (* "is_relation(M,r) \<equiv>
         (\<forall>z[M]. z\<in>r \<longrightarrow> (\<exists>x[M]. \<exists>y[M]. pair(M,x,y,z)))" *)
 definition
   relation_fm :: "i\<Rightarrow>i" where
     "relation_fm(r) \<equiv>
        Forall(Implies(Member(0,succ(r)), Exists(Exists(pair_fm(1,0,2)))))"
 
 lemma relation_type [TC]:
      "\<lbrakk>x \<in> nat\<rbrakk> \<Longrightarrow> relation_fm(x) \<in> formula"
 by (simp add: relation_fm_def)
 
 lemma sats_relation_fm [simp]:
    "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, relation_fm(x), env) \<longleftrightarrow> is_relation(##A, nth(x,env))"
 by (simp add: relation_fm_def is_relation_def)
 
 lemma relation_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> is_relation(##A, x) \<longleftrightarrow> sats(A, relation_fm(i), env)"
 by simp
 
 theorem is_relation_reflection:
      "REFLECTS[\<lambda>x. is_relation(L,f(x)),
                \<lambda>i x. is_relation(##Lset(i),f(x))]"
 apply (simp only: is_relation_def)
 apply (intro FOL_reflections pair_reflection)
 done
 
 
 subsubsection\<open>The Concept of Function, Internalized\<close>
 
 (* "is_function(M,r) \<equiv>
         \<forall>x[M]. \<forall>y[M]. \<forall>y'[M]. \<forall>p[M]. \<forall>p'[M].
            pair(M,x,y,p) \<longrightarrow> pair(M,x,y',p') \<longrightarrow> p\<in>r \<longrightarrow> p'\<in>r \<longrightarrow> y=y'" *)
 definition
   function_fm :: "i\<Rightarrow>i" where
     "function_fm(r) \<equiv>
        Forall(Forall(Forall(Forall(Forall(
          Implies(pair_fm(4,3,1),
                  Implies(pair_fm(4,2,0),
                          Implies(Member(1,r#+5),
                                  Implies(Member(0,r#+5), Equal(3,2))))))))))"
 
 lemma function_type [TC]:
      "\<lbrakk>x \<in> nat\<rbrakk> \<Longrightarrow> function_fm(x) \<in> formula"
 by (simp add: function_fm_def)
 
 lemma sats_function_fm [simp]:
    "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, function_fm(x), env) \<longleftrightarrow> is_function(##A, nth(x,env))"
 by (simp add: function_fm_def is_function_def)
 
 lemma is_function_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> is_function(##A, x) \<longleftrightarrow> sats(A, function_fm(i), env)"
 by simp
 
 theorem is_function_reflection:
      "REFLECTS[\<lambda>x. is_function(L,f(x)),
                \<lambda>i x. is_function(##Lset(i),f(x))]"
 apply (simp only: is_function_def)
 apply (intro FOL_reflections pair_reflection)
 done
 
 
 subsubsection\<open>Typed Functions, Internalized\<close>
 
 (* "typed_function(M,A,B,r) \<equiv>
         is_function(M,r) \<and> is_relation(M,r) \<and> is_domain(M,r,A) \<and>
         (\<forall>u[M]. u\<in>r \<longrightarrow> (\<forall>x[M]. \<forall>y[M]. pair(M,x,y,u) \<longrightarrow> y\<in>B))" *)
 
 definition
   typed_function_fm :: "[i,i,i]\<Rightarrow>i" where
     "typed_function_fm(A,B,r) \<equiv>
        And(function_fm(r),
          And(relation_fm(r),
            And(domain_fm(r,A),
              Forall(Implies(Member(0,succ(r)),
                   Forall(Forall(Implies(pair_fm(1,0,2),Member(0,B#+3)))))))))"
 
 lemma typed_function_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> typed_function_fm(x,y,z) \<in> formula"
 by (simp add: typed_function_fm_def)
 
 lemma sats_typed_function_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, typed_function_fm(x,y,z), env) \<longleftrightarrow>
         typed_function(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: typed_function_fm_def typed_function_def)
 
 lemma typed_function_iff_sats:
   "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
       i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> typed_function(##A, x, y, z) \<longleftrightarrow> sats(A, typed_function_fm(i,j,k), env)"
 by simp
 
 lemmas function_reflections =
         empty_reflection number1_reflection
         upair_reflection pair_reflection union_reflection
         big_union_reflection cons_reflection successor_reflection
         fun_apply_reflection subset_reflection
         transitive_set_reflection membership_reflection
         pred_set_reflection domain_reflection range_reflection field_reflection
         image_reflection pre_image_reflection
         is_relation_reflection is_function_reflection
 
 lemmas function_iff_sats =
         empty_iff_sats number1_iff_sats
         upair_iff_sats pair_iff_sats union_iff_sats
         big_union_iff_sats cons_iff_sats successor_iff_sats
         fun_apply_iff_sats  Memrel_iff_sats
         pred_set_iff_sats domain_iff_sats range_iff_sats field_iff_sats
         image_iff_sats pre_image_iff_sats
         relation_iff_sats is_function_iff_sats
 
 
 theorem typed_function_reflection:
      "REFLECTS[\<lambda>x. typed_function(L,f(x),g(x),h(x)),
                \<lambda>i x. typed_function(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: typed_function_def)
 apply (intro FOL_reflections function_reflections)
 done
 
 
 subsubsection\<open>Composition of Relations, Internalized\<close>
 
 (* "composition(M,r,s,t) \<equiv>
         \<forall>p[M]. p \<in> t \<longleftrightarrow>
                (\<exists>x[M]. \<exists>y[M]. \<exists>z[M]. \<exists>xy[M]. \<exists>yz[M].
                 pair(M,x,z,p) \<and> pair(M,x,y,xy) \<and> pair(M,y,z,yz) \<and>
                 xy \<in> s \<and> yz \<in> r)" *)
 definition
   composition_fm :: "[i,i,i]\<Rightarrow>i" where
   "composition_fm(r,s,t) \<equiv>
      Forall(Iff(Member(0,succ(t)),
              Exists(Exists(Exists(Exists(Exists(
               And(pair_fm(4,2,5),
                And(pair_fm(4,3,1),
                 And(pair_fm(3,2,0),
                  And(Member(1,s#+6), Member(0,r#+6))))))))))))"
 
 lemma composition_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> composition_fm(x,y,z) \<in> formula"
 by (simp add: composition_fm_def)
 
 lemma sats_composition_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, composition_fm(x,y,z), env) \<longleftrightarrow>
         composition(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: composition_fm_def composition_def)
 
 lemma composition_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
           i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> composition(##A, x, y, z) \<longleftrightarrow> sats(A, composition_fm(i,j,k), env)"
 by simp
 
 theorem composition_reflection:
      "REFLECTS[\<lambda>x. composition(L,f(x),g(x),h(x)),
                \<lambda>i x. composition(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: composition_def)
 apply (intro FOL_reflections pair_reflection)
 done
 
 
 subsubsection\<open>Injections, Internalized\<close>
 
 (* "injection(M,A,B,f) \<equiv>
         typed_function(M,A,B,f) \<and>
         (\<forall>x[M]. \<forall>x'[M]. \<forall>y[M]. \<forall>p[M]. \<forall>p'[M].
           pair(M,x,y,p) \<longrightarrow> pair(M,x',y,p') \<longrightarrow> p\<in>f \<longrightarrow> p'\<in>f \<longrightarrow> x=x')" *)
 definition
   injection_fm :: "[i,i,i]\<Rightarrow>i" where
   "injection_fm(A,B,f) \<equiv>
     And(typed_function_fm(A,B,f),
        Forall(Forall(Forall(Forall(Forall(
          Implies(pair_fm(4,2,1),
                  Implies(pair_fm(3,2,0),
                          Implies(Member(1,f#+5),
                                  Implies(Member(0,f#+5), Equal(4,3)))))))))))"
 
 
 lemma injection_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> injection_fm(x,y,z) \<in> formula"
 by (simp add: injection_fm_def)
 
 lemma sats_injection_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, injection_fm(x,y,z), env) \<longleftrightarrow>
         injection(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: injection_fm_def injection_def)
 
 lemma injection_iff_sats:
   "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
       i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> injection(##A, x, y, z) \<longleftrightarrow> sats(A, injection_fm(i,j,k), env)"
 by simp
 
 theorem injection_reflection:
      "REFLECTS[\<lambda>x. injection(L,f(x),g(x),h(x)),
                \<lambda>i x. injection(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: injection_def)
 apply (intro FOL_reflections function_reflections typed_function_reflection)
 done
 
 
 subsubsection\<open>Surjections, Internalized\<close>
 
 (*  surjection :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o"
     "surjection(M,A,B,f) \<equiv>
         typed_function(M,A,B,f) \<and>
         (\<forall>y[M]. y\<in>B \<longrightarrow> (\<exists>x[M]. x\<in>A \<and> fun_apply(M,f,x,y)))" *)
 definition
   surjection_fm :: "[i,i,i]\<Rightarrow>i" where
   "surjection_fm(A,B,f) \<equiv>
     And(typed_function_fm(A,B,f),
        Forall(Implies(Member(0,succ(B)),
                       Exists(And(Member(0,succ(succ(A))),
                                  fun_apply_fm(succ(succ(f)),0,1))))))"
 
 lemma surjection_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> surjection_fm(x,y,z) \<in> formula"
 by (simp add: surjection_fm_def)
 
 lemma sats_surjection_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, surjection_fm(x,y,z), env) \<longleftrightarrow>
         surjection(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: surjection_fm_def surjection_def)
 
 lemma surjection_iff_sats:
   "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
       i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> surjection(##A, x, y, z) \<longleftrightarrow> sats(A, surjection_fm(i,j,k), env)"
 by simp
 
 theorem surjection_reflection:
      "REFLECTS[\<lambda>x. surjection(L,f(x),g(x),h(x)),
                \<lambda>i x. surjection(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: surjection_def)
 apply (intro FOL_reflections function_reflections typed_function_reflection)
 done
 
 
 
 subsubsection\<open>Bijections, Internalized\<close>
 
 (*   bijection :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o"
     "bijection(M,A,B,f) \<equiv> injection(M,A,B,f) \<and> surjection(M,A,B,f)" *)
 definition
   bijection_fm :: "[i,i,i]\<Rightarrow>i" where
   "bijection_fm(A,B,f) \<equiv> And(injection_fm(A,B,f), surjection_fm(A,B,f))"
 
 lemma bijection_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> bijection_fm(x,y,z) \<in> formula"
 by (simp add: bijection_fm_def)
 
 lemma sats_bijection_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, bijection_fm(x,y,z), env) \<longleftrightarrow>
         bijection(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: bijection_fm_def bijection_def)
 
 lemma bijection_iff_sats:
   "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
       i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> bijection(##A, x, y, z) \<longleftrightarrow> sats(A, bijection_fm(i,j,k), env)"
 by simp
 
 theorem bijection_reflection:
      "REFLECTS[\<lambda>x. bijection(L,f(x),g(x),h(x)),
                \<lambda>i x. bijection(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: bijection_def)
 apply (intro And_reflection injection_reflection surjection_reflection)
 done
 
 
 subsubsection\<open>Restriction of a Relation, Internalized\<close>
 
 
 (* "restriction(M,r,A,z) \<equiv>
         \<forall>x[M]. x \<in> z \<longleftrightarrow> (x \<in> r \<and> (\<exists>u[M]. u\<in>A \<and> (\<exists>v[M]. pair(M,u,v,x))))" *)
 definition
   restriction_fm :: "[i,i,i]\<Rightarrow>i" where
     "restriction_fm(r,A,z) \<equiv>
        Forall(Iff(Member(0,succ(z)),
                   And(Member(0,succ(r)),
                       Exists(And(Member(0,succ(succ(A))),
                                  Exists(pair_fm(1,0,2)))))))"
 
 lemma restriction_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> restriction_fm(x,y,z) \<in> formula"
 by (simp add: restriction_fm_def)
 
 lemma sats_restriction_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, restriction_fm(x,y,z), env) \<longleftrightarrow>
         restriction(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: restriction_fm_def restriction_def)
 
 lemma restriction_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
           i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> restriction(##A, x, y, z) \<longleftrightarrow> sats(A, restriction_fm(i,j,k), env)"
 by simp
 
 theorem restriction_reflection:
      "REFLECTS[\<lambda>x. restriction(L,f(x),g(x),h(x)),
                \<lambda>i x. restriction(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: restriction_def)
 apply (intro FOL_reflections pair_reflection)
 done
 
 subsubsection\<open>Order-Isomorphisms, Internalized\<close>
 
 (*  order_isomorphism :: "[i\<Rightarrow>o,i,i,i,i,i] \<Rightarrow> o"
    "order_isomorphism(M,A,r,B,s,f) \<equiv>
         bijection(M,A,B,f) \<and>
         (\<forall>x[M]. x\<in>A \<longrightarrow> (\<forall>y[M]. y\<in>A \<longrightarrow>
           (\<forall>p[M]. \<forall>fx[M]. \<forall>fy[M]. \<forall>q[M].
             pair(M,x,y,p) \<longrightarrow> fun_apply(M,f,x,fx) \<longrightarrow> fun_apply(M,f,y,fy) \<longrightarrow>
             pair(M,fx,fy,q) \<longrightarrow> (p\<in>r \<longleftrightarrow> q\<in>s))))"
   *)
 
 definition
   order_isomorphism_fm :: "[i,i,i,i,i]\<Rightarrow>i" where
  "order_isomorphism_fm(A,r,B,s,f) \<equiv>
    And(bijection_fm(A,B,f),
      Forall(Implies(Member(0,succ(A)),
        Forall(Implies(Member(0,succ(succ(A))),
          Forall(Forall(Forall(Forall(
            Implies(pair_fm(5,4,3),
              Implies(fun_apply_fm(f#+6,5,2),
                Implies(fun_apply_fm(f#+6,4,1),
                  Implies(pair_fm(2,1,0),
                    Iff(Member(3,r#+6), Member(0,s#+6)))))))))))))))"
 
 lemma order_isomorphism_type [TC]:
      "\<lbrakk>A \<in> nat; r \<in> nat; B \<in> nat; s \<in> nat; f \<in> nat\<rbrakk>
       \<Longrightarrow> order_isomorphism_fm(A,r,B,s,f) \<in> formula"
 by (simp add: order_isomorphism_fm_def)
 
 lemma sats_order_isomorphism_fm [simp]:
    "\<lbrakk>U \<in> nat; r \<in> nat; B \<in> nat; s \<in> nat; f \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, order_isomorphism_fm(U,r,B,s,f), env) \<longleftrightarrow>
         order_isomorphism(##A, nth(U,env), nth(r,env), nth(B,env),
                                nth(s,env), nth(f,env))"
 by (simp add: order_isomorphism_fm_def order_isomorphism_def)
 
 lemma order_isomorphism_iff_sats:
   "\<lbrakk>nth(i,env) = U; nth(j,env) = r; nth(k,env) = B; nth(j',env) = s;
       nth(k',env) = f;
       i \<in> nat; j \<in> nat; k \<in> nat; j' \<in> nat; k' \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> order_isomorphism(##A,U,r,B,s,f) \<longleftrightarrow>
        sats(A, order_isomorphism_fm(i,j,k,j',k'), env)"
 by simp
 
 theorem order_isomorphism_reflection:
      "REFLECTS[\<lambda>x. order_isomorphism(L,f(x),g(x),h(x),g'(x),h'(x)),
                \<lambda>i x. order_isomorphism(##Lset(i),f(x),g(x),h(x),g'(x),h'(x))]"
 apply (simp only: order_isomorphism_def)
 apply (intro FOL_reflections function_reflections bijection_reflection)
 done
 
 subsubsection\<open>Limit Ordinals, Internalized\<close>
 
 text\<open>A limit ordinal is a non-empty, successor-closed ordinal\<close>
 
 (* "limit_ordinal(M,a) \<equiv>
         ordinal(M,a) \<and> \<not> empty(M,a) \<and>
         (\<forall>x[M]. x\<in>a \<longrightarrow> (\<exists>y[M]. y\<in>a \<and> successor(M,x,y)))" *)
 
 definition
   limit_ordinal_fm :: "i\<Rightarrow>i" where
     "limit_ordinal_fm(x) \<equiv>
         And(ordinal_fm(x),
             And(Neg(empty_fm(x)),
                 Forall(Implies(Member(0,succ(x)),
                                Exists(And(Member(0,succ(succ(x))),
                                           succ_fm(1,0)))))))"
 
 lemma limit_ordinal_type [TC]:
      "x \<in> nat \<Longrightarrow> limit_ordinal_fm(x) \<in> formula"
 by (simp add: limit_ordinal_fm_def)
 
 lemma sats_limit_ordinal_fm [simp]:
    "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, limit_ordinal_fm(x), env) \<longleftrightarrow> limit_ordinal(##A, nth(x,env))"
 by (simp add: limit_ordinal_fm_def limit_ordinal_def sats_ordinal_fm')
 
 lemma limit_ordinal_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> limit_ordinal(##A, x) \<longleftrightarrow> sats(A, limit_ordinal_fm(i), env)"
 by simp
 
 theorem limit_ordinal_reflection:
      "REFLECTS[\<lambda>x. limit_ordinal(L,f(x)),
                \<lambda>i x. limit_ordinal(##Lset(i),f(x))]"
 apply (simp only: limit_ordinal_def)
 apply (intro FOL_reflections ordinal_reflection
              empty_reflection successor_reflection)
 done
 
 subsubsection\<open>Finite Ordinals: The Predicate ``Is A Natural Number''\<close>
 
 (*     "finite_ordinal(M,a) \<equiv> 
         ordinal(M,a) \<and> \<not> limit_ordinal(M,a) \<and> 
         (\<forall>x[M]. x\<in>a \<longrightarrow> \<not> limit_ordinal(M,x))" *)
 definition
   finite_ordinal_fm :: "i\<Rightarrow>i" where
     "finite_ordinal_fm(x) \<equiv>
        And(ordinal_fm(x),
           And(Neg(limit_ordinal_fm(x)),
            Forall(Implies(Member(0,succ(x)),
                           Neg(limit_ordinal_fm(0))))))"
 
 lemma finite_ordinal_type [TC]:
      "x \<in> nat \<Longrightarrow> finite_ordinal_fm(x) \<in> formula"
 by (simp add: finite_ordinal_fm_def)
 
 lemma sats_finite_ordinal_fm [simp]:
    "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, finite_ordinal_fm(x), env) \<longleftrightarrow> finite_ordinal(##A, nth(x,env))"
 by (simp add: finite_ordinal_fm_def sats_ordinal_fm' finite_ordinal_def)
 
 lemma finite_ordinal_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> finite_ordinal(##A, x) \<longleftrightarrow> sats(A, finite_ordinal_fm(i), env)"
 by simp
 
 theorem finite_ordinal_reflection:
      "REFLECTS[\<lambda>x. finite_ordinal(L,f(x)),
                \<lambda>i x. finite_ordinal(##Lset(i),f(x))]"
 apply (simp only: finite_ordinal_def)
 apply (intro FOL_reflections ordinal_reflection limit_ordinal_reflection)
 done
 
 
 subsubsection\<open>Omega: The Set of Natural Numbers\<close>
 
 (* omega(M,a) \<equiv> limit_ordinal(M,a) \<and> (\<forall>x[M]. x\<in>a \<longrightarrow> \<not> limit_ordinal(M,x)) *)
 definition
   omega_fm :: "i\<Rightarrow>i" where
     "omega_fm(x) \<equiv>
        And(limit_ordinal_fm(x),
            Forall(Implies(Member(0,succ(x)),
                           Neg(limit_ordinal_fm(0)))))"
 
 lemma omega_type [TC]:
      "x \<in> nat \<Longrightarrow> omega_fm(x) \<in> formula"
 by (simp add: omega_fm_def)
 
 lemma sats_omega_fm [simp]:
    "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, omega_fm(x), env) \<longleftrightarrow> omega(##A, nth(x,env))"
 by (simp add: omega_fm_def omega_def)
 
 lemma omega_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
           i \<in> nat; env \<in> list(A)\<rbrakk>
        \<Longrightarrow> omega(##A, x) \<longleftrightarrow> sats(A, omega_fm(i), env)"
 by simp
 
 theorem omega_reflection:
      "REFLECTS[\<lambda>x. omega(L,f(x)),
                \<lambda>i x. omega(##Lset(i),f(x))]"
 apply (simp only: omega_def)
 apply (intro FOL_reflections limit_ordinal_reflection)
 done
 
 
 lemmas fun_plus_reflections =
         typed_function_reflection composition_reflection
         injection_reflection surjection_reflection
         bijection_reflection restriction_reflection
         order_isomorphism_reflection finite_ordinal_reflection 
         ordinal_reflection limit_ordinal_reflection omega_reflection
 
 lemmas fun_plus_iff_sats =
         typed_function_iff_sats composition_iff_sats
         injection_iff_sats surjection_iff_sats
         bijection_iff_sats restriction_iff_sats
         order_isomorphism_iff_sats finite_ordinal_iff_sats
         ordinal_iff_sats limit_ordinal_iff_sats omega_iff_sats
 
 end
diff --git a/src/ZF/Constructible/Rank.thy b/src/ZF/Constructible/Rank.thy
--- a/src/ZF/Constructible/Rank.thy
+++ b/src/ZF/Constructible/Rank.thy
@@ -1,942 +1,942 @@
 (*  Title:      ZF/Constructible/Rank.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
 *)
 
 section \<open>Absoluteness for Order Types, Rank Functions and Well-Founded 
          Relations\<close>
 
 theory Rank imports WF_absolute begin
 
 subsection \<open>Order Types: A Direct Construction by Replacement\<close>
 
 locale M_ordertype = M_basic +
 assumes well_ord_iso_separation:
      "\<lbrakk>M(A); M(f); M(r)\<rbrakk>
       \<Longrightarrow> separation (M, \<lambda>x. x\<in>A \<longrightarrow> (\<exists>y[M]. (\<exists>p[M].
                      fun_apply(M,f,x,y) \<and> pair(M,y,x,p) \<and> p \<in> r)))"
   and obase_separation:
      \<comment> \<open>part of the order type formalization\<close>
      "\<lbrakk>M(A); M(r)\<rbrakk>
       \<Longrightarrow> separation(M, \<lambda>a. \<exists>x[M]. \<exists>g[M]. \<exists>mx[M]. \<exists>par[M].
              ordinal(M,x) \<and> membership(M,x,mx) \<and> pred_set(M,A,a,r,par) \<and>
              order_isomorphism(M,par,r,x,mx,g))"
   and obase_equals_separation:
      "\<lbrakk>M(A); M(r)\<rbrakk>
       \<Longrightarrow> separation (M, \<lambda>x. x\<in>A \<longrightarrow> \<not>(\<exists>y[M]. \<exists>g[M].
                               ordinal(M,y) \<and> (\<exists>my[M]. \<exists>pxr[M].
                               membership(M,y,my) \<and> pred_set(M,A,x,r,pxr) \<and>
                               order_isomorphism(M,pxr,r,y,my,g))))"
   and omap_replacement:
      "\<lbrakk>M(A); M(r)\<rbrakk>
       \<Longrightarrow> strong_replacement(M,
              \<lambda>a z. \<exists>x[M]. \<exists>g[M]. \<exists>mx[M]. \<exists>par[M].
              ordinal(M,x) \<and> pair(M,a,x,z) \<and> membership(M,x,mx) \<and>
              pred_set(M,A,a,r,par) \<and> order_isomorphism(M,par,r,x,mx,g))"
 
 
 text\<open>Inductive argument for Kunen's Lemma I 6.1, etc.
       Simple proof from Halmos, page 72\<close>
 lemma  (in M_ordertype) wellordered_iso_subset_lemma: 
      "\<lbrakk>wellordered(M,A,r);  f \<in> ord_iso(A,r, A',r);  A'<= A;  y \<in> A;  
        M(A);  M(f);  M(r)\<rbrakk> \<Longrightarrow> \<not> <f`y, y> \<in> r"
-apply (unfold wellordered_def ord_iso_def)
+  unfolding wellordered_def ord_iso_def
 apply (elim conjE CollectE) 
 apply (erule wellfounded_on_induct, assumption+)
  apply (insert well_ord_iso_separation [of A f r])
  apply (simp, clarify) 
 apply (drule_tac a = x in bij_is_fun [THEN apply_type], assumption, blast)
 done
 
 
 text\<open>Kunen's Lemma I 6.1, page 14: 
       there's no order-isomorphism to an initial segment of a well-ordering\<close>
 lemma (in M_ordertype) wellordered_iso_predD:
      "\<lbrakk>wellordered(M,A,r);  f \<in> ord_iso(A, r, Order.pred(A,x,r), r);  
        M(A);  M(f);  M(r)\<rbrakk> \<Longrightarrow> x \<notin> A"
 apply (rule notI) 
 apply (frule wellordered_iso_subset_lemma, assumption)
 apply (auto elim: predE)  
 (*Now we know  \<not> (f`x < x) *)
 apply (drule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type], assumption)
 (*Now we also know f`x  \<in> pred(A,x,r);  contradiction! *)
 apply (simp add: Order.pred_def)
 done
 
 
 lemma (in M_ordertype) wellordered_iso_pred_eq_lemma:
      "\<lbrakk>f \<in> \<langle>Order.pred(A,y,r), r\<rangle> \<cong> \<langle>Order.pred(A,x,r), r\<rangle>;
        wellordered(M,A,r); x\<in>A; y\<in>A; M(A); M(f); M(r)\<rbrakk> \<Longrightarrow> \<langle>x,y\<rangle> \<notin> r"
 apply (frule wellordered_is_trans_on, assumption)
 apply (rule notI) 
 apply (drule_tac x2=y and x=x and r2=r in 
          wellordered_subset [OF _ pred_subset, THEN wellordered_iso_predD]) 
 apply (simp add: trans_pred_pred_eq) 
 apply (blast intro: predI dest: transM)+
 done
 
 
 text\<open>Simple consequence of Lemma 6.1\<close>
 lemma (in M_ordertype) wellordered_iso_pred_eq:
      "\<lbrakk>wellordered(M,A,r);
        f \<in> ord_iso(Order.pred(A,a,r), r, Order.pred(A,c,r), r);   
        M(A);  M(f);  M(r);  a\<in>A;  c\<in>A\<rbrakk> \<Longrightarrow> a=c"
 apply (frule wellordered_is_trans_on, assumption)
 apply (frule wellordered_is_linear, assumption)
 apply (erule_tac x=a and y=c in linearE, auto) 
 apply (drule ord_iso_sym)
 (*two symmetric cases*)
 apply (blast dest: wellordered_iso_pred_eq_lemma)+ 
 done
 
 
 text\<open>Following Kunen's Theorem I 7.6, page 17.  Note that this material is
 not required elsewhere.\<close>
 
 text\<open>Can't use \<open>well_ord_iso_preserving\<close> because it needs the
 strong premise \<^term>\<open>well_ord(A,r)\<close>\<close>
 lemma (in M_ordertype) ord_iso_pred_imp_lt:
      "\<lbrakk>f \<in> ord_iso(Order.pred(A,x,r), r, i, Memrel(i));
          g \<in> ord_iso(Order.pred(A,y,r), r, j, Memrel(j));
          wellordered(M,A,r);  x \<in> A;  y \<in> A; M(A); M(r); M(f); M(g); M(j);
          Ord(i); Ord(j); \<langle>x,y\<rangle> \<in> r\<rbrakk>
       \<Longrightarrow> i < j"
 apply (frule wellordered_is_trans_on, assumption)
 apply (frule_tac y=y in transM, assumption) 
 apply (rule_tac i=i and j=j in Ord_linear_lt, auto)  
 txt\<open>case \<^term>\<open>i=j\<close> yields a contradiction\<close>
  apply (rule_tac x1=x and A1="Order.pred(A,y,r)" in 
           wellordered_iso_predD [THEN notE]) 
    apply (blast intro: wellordered_subset [OF _ pred_subset]) 
   apply (simp add: trans_pred_pred_eq)
   apply (blast intro: Ord_iso_implies_eq ord_iso_sym ord_iso_trans) 
  apply (simp_all add: pred_iff)
 txt\<open>case \<^term>\<open>j<i\<close> also yields a contradiction\<close>
 apply (frule restrict_ord_iso2, assumption+) 
 apply (frule ord_iso_sym [THEN ord_iso_is_bij, THEN bij_is_fun]) 
 apply (frule apply_type, blast intro: ltD) 
   \<comment> \<open>thus \<^term>\<open>converse(f)`j \<in> Order.pred(A,x,r)\<close>\<close>
 apply (simp add: pred_iff) 
 apply (subgoal_tac
        "\<exists>h[M]. h \<in> ord_iso(Order.pred(A,y,r), r, 
                                Order.pred(A, converse(f)`j, r), r)")
  apply (clarify, frule wellordered_iso_pred_eq, assumption+)
  apply (blast dest: wellordered_asym)  
 apply (intro rexI)
  apply (blast intro: Ord_iso_implies_eq ord_iso_sym ord_iso_trans)+
 done
 
 
 lemma ord_iso_converse1:
      "\<lbrakk>f: ord_iso(A,r,B,s);  <b, f`a>: s;  a:A;  b:B\<rbrakk> 
       \<Longrightarrow> <converse(f) ` b, a> \<in> r"
 apply (frule ord_iso_converse, assumption+) 
 apply (blast intro: ord_iso_is_bij [THEN bij_is_fun, THEN apply_funtype]) 
 apply (simp add: left_inverse_bij [OF ord_iso_is_bij])
 done
 
 
 definition  
   obase :: "[i\<Rightarrow>o,i,i] \<Rightarrow> i" where
        \<comment> \<open>the domain of \<open>om\<close>, eventually shown to equal \<open>A\<close>\<close>
    "obase(M,A,r) \<equiv> {a\<in>A. \<exists>x[M]. \<exists>g[M]. Ord(x) \<and> 
                           g \<in> ord_iso(Order.pred(A,a,r),r,x,Memrel(x))}"
 
 definition
   omap :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     \<comment> \<open>the function that maps wosets to order types\<close>
    "omap(M,A,r,f) \<equiv> 
         \<forall>z[M].
          z \<in> f \<longleftrightarrow> (\<exists>a\<in>A. \<exists>x[M]. \<exists>g[M]. z = \<langle>a,x\<rangle> \<and> Ord(x) \<and> 
                         g \<in> ord_iso(Order.pred(A,a,r),r,x,Memrel(x)))"
 
 definition
   otype :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where \<comment> \<open>the order types themselves\<close>
    "otype(M,A,r,i) \<equiv> \<exists>f[M]. omap(M,A,r,f) \<and> is_range(M,f,i)"
 
 
 text\<open>Can also be proved with the premise \<^term>\<open>M(z)\<close> instead of
       \<^term>\<open>M(f)\<close>, but that version is less useful.  This lemma
       is also more useful than the definition, \<open>omap_def\<close>.\<close>
 lemma (in M_ordertype) omap_iff:
      "\<lbrakk>omap(M,A,r,f); M(A); M(f)\<rbrakk> 
       \<Longrightarrow> z \<in> f \<longleftrightarrow>
           (\<exists>a\<in>A. \<exists>x[M]. \<exists>g[M]. z = \<langle>a,x\<rangle> \<and> Ord(x) \<and> 
                                 g \<in> ord_iso(Order.pred(A,a,r),r,x,Memrel(x)))"
 apply (simp add: omap_def) 
 apply (rule iffI)
  apply (drule_tac [2] x=z in rspec)
  apply (drule_tac x=z in rspec)
  apply (blast dest: transM)+
 done
 
 lemma (in M_ordertype) omap_unique:
      "\<lbrakk>omap(M,A,r,f); omap(M,A,r,f'); M(A); M(r); M(f); M(f')\<rbrakk> \<Longrightarrow> f' = f" 
 apply (rule equality_iffI) 
 apply (simp add: omap_iff) 
 done
 
 lemma (in M_ordertype) omap_yields_Ord:
      "\<lbrakk>omap(M,A,r,f); \<langle>a,x\<rangle> \<in> f; M(a); M(x)\<rbrakk>  \<Longrightarrow> Ord(x)"
   by (simp add: omap_def)
 
 lemma (in M_ordertype) otype_iff:
      "\<lbrakk>otype(M,A,r,i); M(A); M(r); M(i)\<rbrakk> 
       \<Longrightarrow> x \<in> i \<longleftrightarrow> 
           (M(x) \<and> Ord(x) \<and> 
            (\<exists>a\<in>A. \<exists>g[M]. g \<in> ord_iso(Order.pred(A,a,r),r,x,Memrel(x))))"
 apply (auto simp add: omap_iff otype_def)
  apply (blast intro: transM) 
 apply (rule rangeI) 
 apply (frule transM, assumption)
 apply (simp add: omap_iff, blast)
 done
 
 lemma (in M_ordertype) otype_eq_range:
      "\<lbrakk>omap(M,A,r,f); otype(M,A,r,i); M(A); M(r); M(f); M(i)\<rbrakk> 
       \<Longrightarrow> i = range(f)"
 apply (auto simp add: otype_def omap_iff)
 apply (blast dest: omap_unique) 
 done
 
 
 lemma (in M_ordertype) Ord_otype:
      "\<lbrakk>otype(M,A,r,i); trans[A](r); M(A); M(r); M(i)\<rbrakk> \<Longrightarrow> Ord(i)"
 apply (rule OrdI) 
 prefer 2 
     apply (simp add: Ord_def otype_def omap_def) 
     apply clarify 
     apply (frule pair_components_in_M, assumption) 
     apply blast 
 apply (auto simp add: Transset_def otype_iff) 
   apply (blast intro: transM)
  apply (blast intro: Ord_in_Ord) 
 apply (rename_tac y a g)
 apply (frule ord_iso_sym [THEN ord_iso_is_bij, THEN bij_is_fun, 
                           THEN apply_funtype],  assumption)  
 apply (rule_tac x="converse(g)`y" in bexI)
  apply (frule_tac a="converse(g) ` y" in ord_iso_restrict_pred, assumption) 
 apply (safe elim!: predE) 
 apply (blast intro: restrict_ord_iso ord_iso_sym ltI dest: transM)
 done
 
 lemma (in M_ordertype) domain_omap:
      "\<lbrakk>omap(M,A,r,f);  M(A); M(r); M(B); M(f)\<rbrakk> 
       \<Longrightarrow> domain(f) = obase(M,A,r)"
 apply (simp add: obase_def) 
 apply (rule equality_iffI) 
 apply (simp add: domain_iff omap_iff, blast) 
 done
 
 lemma (in M_ordertype) omap_subset: 
      "\<lbrakk>omap(M,A,r,f); otype(M,A,r,i); 
        M(A); M(r); M(f); M(B); M(i)\<rbrakk> \<Longrightarrow> f \<subseteq> obase(M,A,r) * i"
 apply clarify 
 apply (simp add: omap_iff obase_def) 
 apply (force simp add: otype_iff) 
 done
 
 lemma (in M_ordertype) omap_funtype: 
      "\<lbrakk>omap(M,A,r,f); otype(M,A,r,i); 
          M(A); M(r); M(f); M(i)\<rbrakk> \<Longrightarrow> f \<in> obase(M,A,r) -> i"
 apply (simp add: domain_omap omap_subset Pi_iff function_def omap_iff) 
 apply (blast intro: Ord_iso_implies_eq ord_iso_sym ord_iso_trans) 
 done
 
 
 lemma (in M_ordertype) wellordered_omap_bij:
      "\<lbrakk>wellordered(M,A,r); omap(M,A,r,f); otype(M,A,r,i); 
        M(A); M(r); M(f); M(i)\<rbrakk> \<Longrightarrow> f \<in> bij(obase(M,A,r),i)"
 apply (insert omap_funtype [of A r f i]) 
 apply (auto simp add: bij_def inj_def) 
 prefer 2  apply (blast intro: fun_is_surj dest: otype_eq_range) 
 apply (frule_tac a=w in apply_Pair, assumption) 
 apply (frule_tac a=x in apply_Pair, assumption) 
 apply (simp add: omap_iff) 
 apply (blast intro: wellordered_iso_pred_eq ord_iso_sym ord_iso_trans) 
 done
 
 
 text\<open>This is not the final result: we must show \<^term>\<open>oB(A,r) = A\<close>\<close>
 lemma (in M_ordertype) omap_ord_iso:
      "\<lbrakk>wellordered(M,A,r); omap(M,A,r,f); otype(M,A,r,i); 
        M(A); M(r); M(f); M(i)\<rbrakk> \<Longrightarrow> f \<in> ord_iso(obase(M,A,r),r,i,Memrel(i))"
 apply (rule ord_isoI)
  apply (erule wellordered_omap_bij, assumption+) 
 apply (insert omap_funtype [of A r f i], simp) 
 apply (frule_tac a=x in apply_Pair, assumption) 
 apply (frule_tac a=y in apply_Pair, assumption) 
 apply (auto simp add: omap_iff)
  txt\<open>direction 1: assuming \<^term>\<open>\<langle>x,y\<rangle> \<in> r\<close>\<close>
  apply (blast intro: ltD ord_iso_pred_imp_lt)
  txt\<open>direction 2: proving \<^term>\<open>\<langle>x,y\<rangle> \<in> r\<close> using linearity of \<^term>\<open>r\<close>\<close>
 apply (rename_tac x y g ga) 
 apply (frule wellordered_is_linear, assumption, 
        erule_tac x=x and y=y in linearE, assumption+) 
 txt\<open>the case \<^term>\<open>x=y\<close> leads to immediate contradiction\<close> 
 apply (blast elim: mem_irrefl) 
 txt\<open>the case \<^term>\<open>\<langle>y,x\<rangle> \<in> r\<close>: handle like the opposite direction\<close>
 apply (blast dest: ord_iso_pred_imp_lt ltD elim: mem_asym) 
 done
 
 lemma (in M_ordertype) Ord_omap_image_pred:
      "\<lbrakk>wellordered(M,A,r); omap(M,A,r,f); otype(M,A,r,i); 
        M(A); M(r); M(f); M(i); b \<in> A\<rbrakk> \<Longrightarrow> Ord(f `` Order.pred(A,b,r))"
 apply (frule wellordered_is_trans_on, assumption)
 apply (rule OrdI) 
         prefer 2 apply (simp add: image_iff omap_iff Ord_def, blast) 
 txt\<open>Hard part is to show that the image is a transitive set.\<close>
 apply (simp add: Transset_def, clarify) 
 apply (simp add: image_iff pred_iff apply_iff [OF omap_funtype [of A r f i]])
 apply (rename_tac c j, clarify)
 apply (frule omap_funtype [of A r f, THEN apply_funtype], assumption+)
 apply (subgoal_tac "j \<in> i") 
         prefer 2 apply (blast intro: Ord_trans Ord_otype)
 apply (subgoal_tac "converse(f) ` j \<in> obase(M,A,r)") 
         prefer 2 
         apply (blast dest: wellordered_omap_bij [THEN bij_converse_bij, 
                                       THEN bij_is_fun, THEN apply_funtype])
 apply (rule_tac x="converse(f) ` j" in bexI) 
  apply (simp add: right_inverse_bij [OF wellordered_omap_bij]) 
 apply (intro predI conjI)
  apply (erule_tac b=c in trans_onD) 
  apply (rule ord_iso_converse1 [OF omap_ord_iso [of A r f i]])
 apply (auto simp add: obase_def)
 done
 
 lemma (in M_ordertype) restrict_omap_ord_iso:
      "\<lbrakk>wellordered(M,A,r); omap(M,A,r,f); otype(M,A,r,i); 
        D \<subseteq> obase(M,A,r); M(A); M(r); M(f); M(i)\<rbrakk> 
       \<Longrightarrow> restrict(f,D) \<in> (\<langle>D,r\<rangle> \<cong> \<langle>f``D, Memrel(f``D)\<rangle>)"
 apply (frule ord_iso_restrict_image [OF omap_ord_iso [of A r f i]], 
        assumption+)
 apply (drule ord_iso_sym [THEN subset_ord_iso_Memrel]) 
 apply (blast dest: subsetD [OF omap_subset]) 
 apply (drule ord_iso_sym, simp) 
 done
 
 lemma (in M_ordertype) obase_equals: 
      "\<lbrakk>wellordered(M,A,r); omap(M,A,r,f); otype(M,A,r,i);
        M(A); M(r); M(f); M(i)\<rbrakk> \<Longrightarrow> obase(M,A,r) = A"
 apply (rule equalityI, force simp add: obase_def, clarify) 
 apply (unfold obase_def, simp) 
 apply (frule wellordered_is_wellfounded_on, assumption)
 apply (erule wellfounded_on_induct, assumption+)
  apply (frule obase_equals_separation [of A r], assumption) 
  apply (simp, clarify) 
 apply (rename_tac b) 
 apply (subgoal_tac "Order.pred(A,b,r) \<subseteq> obase(M,A,r)") 
  apply (blast intro!: restrict_omap_ord_iso Ord_omap_image_pred)
 apply (force simp add: pred_iff obase_def)  
 done
 
 
 
 text\<open>Main result: \<^term>\<open>om\<close> gives the order-isomorphism 
       \<^term>\<open>\<langle>A,r\<rangle> \<cong> \<langle>i, Memrel(i)\<rangle>\<close>\<close>
 theorem (in M_ordertype) omap_ord_iso_otype:
      "\<lbrakk>wellordered(M,A,r); omap(M,A,r,f); otype(M,A,r,i);
        M(A); M(r); M(f); M(i)\<rbrakk> \<Longrightarrow> f \<in> ord_iso(A, r, i, Memrel(i))"
 apply (frule omap_ord_iso, assumption+)
 apply (simp add: obase_equals)  
 done 
 
 lemma (in M_ordertype) obase_exists:
      "\<lbrakk>M(A); M(r)\<rbrakk> \<Longrightarrow> M(obase(M,A,r))"
 apply (simp add: obase_def) 
 apply (insert obase_separation [of A r])
 apply (simp add: separation_def)  
 done
 
 lemma (in M_ordertype) omap_exists:
      "\<lbrakk>M(A); M(r)\<rbrakk> \<Longrightarrow> \<exists>z[M]. omap(M,A,r,z)"
 apply (simp add: omap_def) 
 apply (insert omap_replacement [of A r])
 apply (simp add: strong_replacement_def) 
 apply (drule_tac x="obase(M,A,r)" in rspec) 
  apply (simp add: obase_exists) 
 apply (simp add: obase_def)
 apply (erule impE) 
  apply (clarsimp simp add: univalent_def)
  apply (blast intro: Ord_iso_implies_eq ord_iso_sym ord_iso_trans, clarify)  
 apply (rule_tac x=Y in rexI) 
 apply (simp add: obase_def, blast, assumption)
 done
 
 lemma (in M_ordertype) otype_exists:
      "\<lbrakk>wellordered(M,A,r); M(A); M(r)\<rbrakk> \<Longrightarrow> \<exists>i[M]. otype(M,A,r,i)"
 apply (insert omap_exists [of A r])  
 apply (simp add: otype_def, safe)
 apply (rule_tac x="range(x)" in rexI) 
 apply blast+
 done
 
 lemma (in M_ordertype) ordertype_exists:
      "\<lbrakk>wellordered(M,A,r); M(A); M(r)\<rbrakk>
       \<Longrightarrow> \<exists>f[M]. (\<exists>i[M]. Ord(i) \<and> f \<in> ord_iso(A, r, i, Memrel(i)))"
 apply (insert obase_exists [of A r] omap_exists [of A r] otype_exists [of A r], simp, clarify)
 apply (rename_tac i) 
 apply (subgoal_tac "Ord(i)", blast intro: omap_ord_iso_otype)
 apply (rule Ord_otype) 
     apply (force simp add: otype_def) 
    apply (simp_all add: wellordered_is_trans_on) 
 done
 
 
 lemma (in M_ordertype) relativized_imp_well_ord: 
      "\<lbrakk>wellordered(M,A,r); M(A); M(r)\<rbrakk> \<Longrightarrow> well_ord(A,r)" 
 apply (insert ordertype_exists [of A r], simp)
 apply (blast intro: well_ord_ord_iso well_ord_Memrel)  
 done
 
 subsection \<open>Kunen's theorem 5.4, page 127\<close>
 
 text\<open>(a) The notion of Wellordering is absolute\<close>
 theorem (in M_ordertype) well_ord_abs [simp]: 
      "\<lbrakk>M(A); M(r)\<rbrakk> \<Longrightarrow> wellordered(M,A,r) \<longleftrightarrow> well_ord(A,r)" 
 by (blast intro: well_ord_imp_relativized relativized_imp_well_ord)  
 
 
 text\<open>(b) Order types are absolute\<close>
 theorem (in M_ordertype) ordertypes_are_absolute:
      "\<lbrakk>wellordered(M,A,r); f \<in> ord_iso(A, r, i, Memrel(i));
        M(A); M(r); M(f); M(i); Ord(i)\<rbrakk> \<Longrightarrow> i = ordertype(A,r)"
 by (blast intro: Ord_ordertype relativized_imp_well_ord ordertype_ord_iso
                  Ord_iso_implies_eq ord_iso_sym ord_iso_trans)
 
 
 subsection\<open>Ordinal Arithmetic: Two Examples of Recursion\<close>
 
 text\<open>Note: the remainder of this theory is not needed elsewhere.\<close>
 
 subsubsection\<open>Ordinal Addition\<close>
 
 (*FIXME: update to use new techniques\<And>*)
  (*This expresses ordinal addition in the language of ZF.  It also 
    provides an abbreviation that can be used in the instance of strong
    replacement below.  Here j is used to define the relation, namely
    Memrel(succ(j)), while x determines the domain of f.*)
 definition
   is_oadd_fun :: "[i\<Rightarrow>o,i,i,i,i] \<Rightarrow> o" where
     "is_oadd_fun(M,i,j,x,f) \<equiv> 
        (\<forall>sj msj. M(sj) \<longrightarrow> M(msj) \<longrightarrow> 
                  successor(M,j,sj) \<longrightarrow> membership(M,sj,msj) \<longrightarrow> 
                  M_is_recfun(M, 
                      \<lambda>x g y. \<exists>gx[M]. image(M,g,x,gx) \<and> union(M,i,gx,y),
                      msj, x, f))"
 
 definition
   is_oadd :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "is_oadd(M,i,j,k) \<equiv> 
         (\<not> ordinal(M,i) \<and> \<not> ordinal(M,j) \<and> k=0) |
         (\<not> ordinal(M,i) \<and> ordinal(M,j) \<and> k=j) |
         (ordinal(M,i) \<and> \<not> ordinal(M,j) \<and> k=i) |
         (ordinal(M,i) \<and> ordinal(M,j) \<and> 
          (\<exists>f fj sj. M(f) \<and> M(fj) \<and> M(sj) \<and> 
                     successor(M,j,sj) \<and> is_oadd_fun(M,i,sj,sj,f) \<and> 
                     fun_apply(M,f,j,fj) \<and> fj = k))"
 
 definition
  (*NEEDS RELATIVIZATION*)
   omult_eqns :: "[i,i,i,i] \<Rightarrow> o" where
     "omult_eqns(i,x,g,z) \<equiv>
             Ord(x) \<and> 
             (x=0 \<longrightarrow> z=0) \<and>
             (\<forall>j. x = succ(j) \<longrightarrow> z = g`j ++ i) \<and>
             (Limit(x) \<longrightarrow> z = \<Union>(g``x))"
 
 definition
   is_omult_fun :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "is_omult_fun(M,i,j,f) \<equiv> 
             (\<exists>df. M(df) \<and> is_function(M,f) \<and> 
                   is_domain(M,f,df) \<and> subset(M, j, df)) \<and> 
             (\<forall>x\<in>j. omult_eqns(i,x,f,f`x))"
 
 definition
   is_omult :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "is_omult(M,i,j,k) \<equiv> 
         \<exists>f fj sj. M(f) \<and> M(fj) \<and> M(sj) \<and> 
                   successor(M,j,sj) \<and> is_omult_fun(M,i,sj,f) \<and> 
                   fun_apply(M,f,j,fj) \<and> fj = k"
 
 
 locale M_ord_arith = M_ordertype +
   assumes oadd_strong_replacement:
    "\<lbrakk>M(i); M(j)\<rbrakk> \<Longrightarrow>
     strong_replacement(M, 
          \<lambda>x z. \<exists>y[M]. pair(M,x,y,z) \<and> 
                   (\<exists>f[M]. \<exists>fx[M]. is_oadd_fun(M,i,j,x,f) \<and> 
                            image(M,f,x,fx) \<and> y = i \<union> fx))"
 
  and omult_strong_replacement':
    "\<lbrakk>M(i); M(j)\<rbrakk> \<Longrightarrow>
     strong_replacement(M, 
          \<lambda>x z. \<exists>y[M]. z = \<langle>x,y\<rangle> \<and>
              (\<exists>g[M]. is_recfun(Memrel(succ(j)),x,\<lambda>x g. THE z. omult_eqns(i,x,g,z),g) \<and> 
              y = (THE z. omult_eqns(i, x, g, z))))" 
 
 
 
 text\<open>\<open>is_oadd_fun\<close>: Relating the pure "language of set theory" to Isabelle/ZF\<close>
 lemma (in M_ord_arith) is_oadd_fun_iff:
    "\<lbrakk>a\<le>j; M(i); M(j); M(a); M(f)\<rbrakk> 
     \<Longrightarrow> is_oadd_fun(M,i,j,a,f) \<longleftrightarrow>
         f \<in> a \<rightarrow> range(f) \<and> (\<forall>x. M(x) \<longrightarrow> x < a \<longrightarrow> f`x = i \<union> f``x)"
 apply (frule lt_Ord) 
 apply (simp add: is_oadd_fun_def  
              relation2_def is_recfun_abs [of "\<lambda>x g. i \<union> g``x"]
              is_recfun_iff_equation  
              Ball_def lt_trans [OF ltI, of _ a] lt_Memrel)
 apply (simp add: lt_def) 
 apply (blast dest: transM) 
 done
 
 
 lemma (in M_ord_arith) oadd_strong_replacement':
     "\<lbrakk>M(i); M(j)\<rbrakk> \<Longrightarrow>
      strong_replacement(M, 
             \<lambda>x z. \<exists>y[M]. z = \<langle>x,y\<rangle> \<and>
                   (\<exists>g[M]. is_recfun(Memrel(succ(j)),x,\<lambda>x g. i \<union> g``x,g) \<and> 
                   y = i \<union> g``x))" 
 apply (insert oadd_strong_replacement [of i j]) 
 apply (simp add: is_oadd_fun_def relation2_def
                  is_recfun_abs [of "\<lambda>x g. i \<union> g``x"])  
 done
 
 
 lemma (in M_ord_arith) exists_oadd:
     "\<lbrakk>Ord(j);  M(i);  M(j)\<rbrakk>
      \<Longrightarrow> \<exists>f[M]. is_recfun(Memrel(succ(j)), j, \<lambda>x g. i \<union> g``x, f)"
 apply (rule wf_exists_is_recfun [OF wf_Memrel trans_Memrel])
     apply (simp_all add: Memrel_type oadd_strong_replacement') 
 done 
 
 lemma (in M_ord_arith) exists_oadd_fun:
     "\<lbrakk>Ord(j);  M(i);  M(j)\<rbrakk> \<Longrightarrow> \<exists>f[M]. is_oadd_fun(M,i,succ(j),succ(j),f)"
 apply (rule exists_oadd [THEN rexE])
 apply (erule Ord_succ, assumption, simp) 
 apply (rename_tac f) 
 apply (frule is_recfun_type)
 apply (rule_tac x=f in rexI) 
  apply (simp add: fun_is_function domain_of_fun lt_Memrel apply_recfun lt_def
                   is_oadd_fun_iff Ord_trans [OF _ succI1], assumption)
 done
 
 lemma (in M_ord_arith) is_oadd_fun_apply:
     "\<lbrakk>x < j; M(i); M(j); M(f); is_oadd_fun(M,i,j,j,f)\<rbrakk> 
      \<Longrightarrow> f`x = i \<union> (\<Union>k\<in>x. {f ` k})"
 apply (simp add: is_oadd_fun_iff lt_Ord2, clarify) 
 apply (frule lt_closed, simp)
 apply (frule leI [THEN le_imp_subset])  
 apply (simp add: image_fun, blast) 
 done
 
 lemma (in M_ord_arith) is_oadd_fun_iff_oadd [rule_format]:
     "\<lbrakk>is_oadd_fun(M,i,J,J,f); M(i); M(J); M(f); Ord(i); Ord(j)\<rbrakk> 
      \<Longrightarrow> j<J \<longrightarrow> f`j = i++j"
 apply (erule_tac i=j in trans_induct, clarify) 
 apply (subgoal_tac "\<forall>k\<in>x. k<J")
  apply (simp (no_asm_simp) add: is_oadd_def oadd_unfold is_oadd_fun_apply)
 apply (blast intro: lt_trans ltI lt_Ord) 
 done
 
 lemma (in M_ord_arith) Ord_oadd_abs:
     "\<lbrakk>M(i); M(j); M(k); Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> is_oadd(M,i,j,k) \<longleftrightarrow> k = i++j"
 apply (simp add: is_oadd_def is_oadd_fun_iff_oadd)
 apply (frule exists_oadd_fun [of j i], blast+)
 done
 
 lemma (in M_ord_arith) oadd_abs:
     "\<lbrakk>M(i); M(j); M(k)\<rbrakk> \<Longrightarrow> is_oadd(M,i,j,k) \<longleftrightarrow> k = i++j"
 apply (case_tac "Ord(i) \<and> Ord(j)")
  apply (simp add: Ord_oadd_abs)
 apply (auto simp add: is_oadd_def oadd_eq_if_raw_oadd)
 done
 
 lemma (in M_ord_arith) oadd_closed [intro,simp]:
     "\<lbrakk>M(i); M(j)\<rbrakk> \<Longrightarrow> M(i++j)"
 apply (simp add: oadd_eq_if_raw_oadd, clarify) 
 apply (simp add: raw_oadd_eq_oadd) 
 apply (frule exists_oadd_fun [of j i], auto)
 apply (simp add: is_oadd_fun_iff_oadd [symmetric]) 
 done
 
 
 subsubsection\<open>Ordinal Multiplication\<close>
 
 lemma omult_eqns_unique:
      "\<lbrakk>omult_eqns(i,x,g,z); omult_eqns(i,x,g,z')\<rbrakk> \<Longrightarrow> z=z'"
 apply (simp add: omult_eqns_def, clarify) 
 apply (erule Ord_cases, simp_all) 
 done
 
 lemma omult_eqns_0: "omult_eqns(i,0,g,z) \<longleftrightarrow> z=0"
 by (simp add: omult_eqns_def)
 
 lemma the_omult_eqns_0: "(THE z. omult_eqns(i,0,g,z)) = 0"
 by (simp add: omult_eqns_0)
 
 lemma omult_eqns_succ: "omult_eqns(i,succ(j),g,z) \<longleftrightarrow> Ord(j) \<and> z = g`j ++ i"
 by (simp add: omult_eqns_def)
 
 lemma the_omult_eqns_succ:
      "Ord(j) \<Longrightarrow> (THE z. omult_eqns(i,succ(j),g,z)) = g`j ++ i"
 by (simp add: omult_eqns_succ) 
 
 lemma omult_eqns_Limit:
      "Limit(x) \<Longrightarrow> omult_eqns(i,x,g,z) \<longleftrightarrow> z = \<Union>(g``x)"
 apply (simp add: omult_eqns_def) 
 apply (blast intro: Limit_is_Ord) 
 done
 
 lemma the_omult_eqns_Limit:
      "Limit(x) \<Longrightarrow> (THE z. omult_eqns(i,x,g,z)) = \<Union>(g``x)"
 by (simp add: omult_eqns_Limit)
 
 lemma omult_eqns_Not: "\<not> Ord(x) \<Longrightarrow> \<not> omult_eqns(i,x,g,z)"
 by (simp add: omult_eqns_def)
 
 
 lemma (in M_ord_arith) the_omult_eqns_closed:
     "\<lbrakk>M(i); M(x); M(g); function(g)\<rbrakk> 
      \<Longrightarrow> M(THE z. omult_eqns(i, x, g, z))"
 apply (case_tac "Ord(x)")
  prefer 2 apply (simp add: omult_eqns_Not) \<comment> \<open>trivial, non-Ord case\<close>
 apply (erule Ord_cases) 
   apply (simp add: omult_eqns_0)
  apply (simp add: omult_eqns_succ) 
 apply (simp add: omult_eqns_Limit) 
 done
 
 lemma (in M_ord_arith) exists_omult:
     "\<lbrakk>Ord(j);  M(i);  M(j)\<rbrakk>
      \<Longrightarrow> \<exists>f[M]. is_recfun(Memrel(succ(j)), j, \<lambda>x g. THE z. omult_eqns(i,x,g,z), f)"
 apply (rule wf_exists_is_recfun [OF wf_Memrel trans_Memrel])
     apply (simp_all add: Memrel_type omult_strong_replacement') 
 apply (blast intro: the_omult_eqns_closed) 
 done
 
 lemma (in M_ord_arith) exists_omult_fun:
     "\<lbrakk>Ord(j);  M(i);  M(j)\<rbrakk> \<Longrightarrow> \<exists>f[M]. is_omult_fun(M,i,succ(j),f)"
 apply (rule exists_omult [THEN rexE])
 apply (erule Ord_succ, assumption, simp) 
 apply (rename_tac f) 
 apply (frule is_recfun_type)
 apply (rule_tac x=f in rexI) 
 apply (simp add: fun_is_function domain_of_fun lt_Memrel apply_recfun lt_def
                  is_omult_fun_def Ord_trans [OF _ succI1])
  apply (force dest: Ord_in_Ord' 
               simp add: omult_eqns_def the_omult_eqns_0 the_omult_eqns_succ
                         the_omult_eqns_Limit, assumption)
 done
 
 lemma (in M_ord_arith) is_omult_fun_apply_0:
     "\<lbrakk>0 < j; is_omult_fun(M,i,j,f)\<rbrakk> \<Longrightarrow> f`0 = 0"
 by (simp add: is_omult_fun_def omult_eqns_def lt_def ball_conj_distrib)
 
 lemma (in M_ord_arith) is_omult_fun_apply_succ:
     "\<lbrakk>succ(x) < j; is_omult_fun(M,i,j,f)\<rbrakk> \<Longrightarrow> f`succ(x) = f`x ++ i"
 by (simp add: is_omult_fun_def omult_eqns_def lt_def, blast) 
 
 lemma (in M_ord_arith) is_omult_fun_apply_Limit:
     "\<lbrakk>x < j; Limit(x); M(j); M(f); is_omult_fun(M,i,j,f)\<rbrakk> 
      \<Longrightarrow> f ` x = (\<Union>y\<in>x. f`y)"
 apply (simp add: is_omult_fun_def omult_eqns_def lt_def, clarify)
 apply (drule subset_trans [OF OrdmemD], assumption+)  
 apply (simp add: ball_conj_distrib omult_Limit image_function)
 done
 
 lemma (in M_ord_arith) is_omult_fun_eq_omult:
     "\<lbrakk>is_omult_fun(M,i,J,f); M(J); M(f); Ord(i); Ord(j)\<rbrakk> 
      \<Longrightarrow> j<J \<longrightarrow> f`j = i**j"
 apply (erule_tac i=j in trans_induct3)
 apply (safe del: impCE)
   apply (simp add: is_omult_fun_apply_0) 
  apply (subgoal_tac "x<J") 
   apply (simp add: is_omult_fun_apply_succ omult_succ)  
  apply (blast intro: lt_trans) 
 apply (subgoal_tac "\<forall>k\<in>x. k<J")
  apply (simp add: is_omult_fun_apply_Limit omult_Limit) 
 apply (blast intro: lt_trans ltI lt_Ord) 
 done
 
 lemma (in M_ord_arith) omult_abs:
     "\<lbrakk>M(i); M(j); M(k); Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> is_omult(M,i,j,k) \<longleftrightarrow> k = i**j"
 apply (simp add: is_omult_def is_omult_fun_eq_omult)
 apply (frule exists_omult_fun [of j i], blast+)
 done
 
 
 
 subsection \<open>Absoluteness of Well-Founded Relations\<close>
 
 text\<open>Relativized to \<^term>\<open>M\<close>: Every well-founded relation is a subset of some
 inverse image of an ordinal.  Key step is the construction (in \<^term>\<open>M\<close>) of a
 rank function.\<close>
 
 locale M_wfrank = M_trancl +
   assumes wfrank_separation:
      "M(r) \<Longrightarrow>
       separation (M, \<lambda>x. 
          \<forall>rplus[M]. tran_closure(M,r,rplus) \<longrightarrow>
          \<not> (\<exists>f[M]. M_is_recfun(M, \<lambda>x f y. is_range(M,f,y), rplus, x, f)))"
  and wfrank_strong_replacement:
      "M(r) \<Longrightarrow>
       strong_replacement(M, \<lambda>x z. 
          \<forall>rplus[M]. tran_closure(M,r,rplus) \<longrightarrow>
          (\<exists>y[M]. \<exists>f[M]. pair(M,x,y,z)  \<and> 
                         M_is_recfun(M, \<lambda>x f y. is_range(M,f,y), rplus, x, f) \<and>
                         is_range(M,f,y)))"
  and Ord_wfrank_separation:
      "M(r) \<Longrightarrow>
       separation (M, \<lambda>x.
          \<forall>rplus[M]. tran_closure(M,r,rplus) \<longrightarrow> 
           \<not> (\<forall>f[M]. \<forall>rangef[M]. 
              is_range(M,f,rangef) \<longrightarrow>
              M_is_recfun(M, \<lambda>x f y. is_range(M,f,y), rplus, x, f) \<longrightarrow>
              ordinal(M,rangef)))" 
 
 
 text\<open>Proving that the relativized instances of Separation or Replacement
 agree with the "real" ones.\<close>
 
 lemma (in M_wfrank) wfrank_separation':
      "M(r) \<Longrightarrow>
       separation
            (M, \<lambda>x. \<not> (\<exists>f[M]. is_recfun(r^+, x, \<lambda>x f. range(f), f)))"
 apply (insert wfrank_separation [of r])
 apply (simp add: relation2_def is_recfun_abs [of "\<lambda>x. range"])
 done
 
 lemma (in M_wfrank) wfrank_strong_replacement':
      "M(r) \<Longrightarrow>
       strong_replacement(M, \<lambda>x z. \<exists>y[M]. \<exists>f[M]. 
                   pair(M,x,y,z) \<and> is_recfun(r^+, x, \<lambda>x f. range(f), f) \<and>
                   y = range(f))"
 apply (insert wfrank_strong_replacement [of r])
 apply (simp add: relation2_def is_recfun_abs [of "\<lambda>x. range"])
 done
 
 lemma (in M_wfrank) Ord_wfrank_separation':
      "M(r) \<Longrightarrow>
       separation (M, \<lambda>x. 
          \<not> (\<forall>f[M]. is_recfun(r^+, x, \<lambda>x. range, f) \<longrightarrow> Ord(range(f))))" 
 apply (insert Ord_wfrank_separation [of r])
 apply (simp add: relation2_def is_recfun_abs [of "\<lambda>x. range"])
 done
 
 text\<open>This function, defined using replacement, is a rank function for
 well-founded relations within the class M.\<close>
 definition
   wellfoundedrank :: "[i\<Rightarrow>o,i,i] \<Rightarrow> i" where
     "wellfoundedrank(M,r,A) \<equiv>
         {p. x\<in>A, \<exists>y[M]. \<exists>f[M]. 
                        p = \<langle>x,y\<rangle> \<and> is_recfun(r^+, x, \<lambda>x f. range(f), f) \<and>
                        y = range(f)}"
 
 lemma (in M_wfrank) exists_wfrank:
     "\<lbrakk>wellfounded(M,r); M(a); M(r)\<rbrakk>
      \<Longrightarrow> \<exists>f[M]. is_recfun(r^+, a, \<lambda>x f. range(f), f)"
 apply (rule wellfounded_exists_is_recfun)
       apply (blast intro: wellfounded_trancl)
      apply (rule trans_trancl)
     apply (erule wfrank_separation')
    apply (erule wfrank_strong_replacement')
 apply (simp_all add: trancl_subset_times)
 done
 
 lemma (in M_wfrank) M_wellfoundedrank:
     "\<lbrakk>wellfounded(M,r); M(r); M(A)\<rbrakk> \<Longrightarrow> M(wellfoundedrank(M,r,A))"
 apply (insert wfrank_strong_replacement' [of r])
 apply (simp add: wellfoundedrank_def)
 apply (rule strong_replacement_closed)
    apply assumption+
  apply (rule univalent_is_recfun)
    apply (blast intro: wellfounded_trancl)
   apply (rule trans_trancl)
  apply (simp add: trancl_subset_times) 
 apply (blast dest: transM) 
 done
 
 lemma (in M_wfrank) Ord_wfrank_range [rule_format]:
     "\<lbrakk>wellfounded(M,r); a\<in>A; M(r); M(A)\<rbrakk>
      \<Longrightarrow> \<forall>f[M]. is_recfun(r^+, a, \<lambda>x f. range(f), f) \<longrightarrow> Ord(range(f))"
 apply (drule wellfounded_trancl, assumption)
 apply (rule wellfounded_induct, assumption, erule (1) transM)
   apply simp
  apply (blast intro: Ord_wfrank_separation', clarify)
 txt\<open>The reasoning in both cases is that we get \<^term>\<open>y\<close> such that
    \<^term>\<open>\<langle>y, x\<rangle> \<in> r^+\<close>.  We find that
    \<^term>\<open>f`y = restrict(f, r^+ -`` {y})\<close>.\<close>
 apply (rule OrdI [OF _ Ord_is_Transset])
  txt\<open>An ordinal is a transitive set...\<close>
  apply (simp add: Transset_def)
  apply clarify
  apply (frule apply_recfun2, assumption)
  apply (force simp add: restrict_iff)
 txt\<open>...of ordinals.  This second case requires the induction hyp.\<close>
 apply clarify
 apply (rename_tac i y)
 apply (frule apply_recfun2, assumption)
 apply (frule is_recfun_imp_in_r, assumption)
 apply (frule is_recfun_restrict)
     (*simp_all won't work*)
     apply (simp add: trans_trancl trancl_subset_times)+
 apply (drule spec [THEN mp], assumption)
 apply (subgoal_tac "M(restrict(f, r^+ -`` {y}))")
  apply (drule_tac x="restrict(f, r^+ -`` {y})" in rspec)
 apply assumption
  apply (simp add: function_apply_equality [OF _ is_recfun_imp_function])
 apply (blast dest: pair_components_in_M)
 done
 
 lemma (in M_wfrank) Ord_range_wellfoundedrank:
     "\<lbrakk>wellfounded(M,r); r \<subseteq> A*A;  M(r); M(A)\<rbrakk>
      \<Longrightarrow> Ord (range(wellfoundedrank(M,r,A)))"
 apply (frule wellfounded_trancl, assumption)
 apply (frule trancl_subset_times)
 apply (simp add: wellfoundedrank_def)
 apply (rule OrdI [OF _ Ord_is_Transset])
  prefer 2
  txt\<open>by our previous result the range consists of ordinals.\<close>
  apply (blast intro: Ord_wfrank_range)
 txt\<open>We still must show that the range is a transitive set.\<close>
 apply (simp add: Transset_def, clarify, simp)
 apply (rename_tac x i f u)
 apply (frule is_recfun_imp_in_r, assumption)
 apply (subgoal_tac "M(u) \<and> M(i) \<and> M(x)")
  prefer 2 apply (blast dest: transM, clarify)
 apply (rule_tac a=u in rangeI)
 apply (rule_tac x=u in ReplaceI)
   apply simp 
   apply (rule_tac x="restrict(f, r^+ -`` {u})" in rexI)
    apply (blast intro: is_recfun_restrict trans_trancl dest: apply_recfun2)
   apply simp 
 apply blast 
 txt\<open>Unicity requirement of Replacement\<close>
 apply clarify
 apply (frule apply_recfun2, assumption)
 apply (simp add: trans_trancl is_recfun_cut)
 done
 
 lemma (in M_wfrank) function_wellfoundedrank:
     "\<lbrakk>wellfounded(M,r); M(r); M(A)\<rbrakk>
      \<Longrightarrow> function(wellfoundedrank(M,r,A))"
 apply (simp add: wellfoundedrank_def function_def, clarify)
 txt\<open>Uniqueness: repeated below!\<close>
 apply (drule is_recfun_functional, assumption)
      apply (blast intro: wellfounded_trancl)
     apply (simp_all add: trancl_subset_times trans_trancl)
 done
 
 lemma (in M_wfrank) domain_wellfoundedrank:
     "\<lbrakk>wellfounded(M,r); M(r); M(A)\<rbrakk>
      \<Longrightarrow> domain(wellfoundedrank(M,r,A)) = A"
 apply (simp add: wellfoundedrank_def function_def)
 apply (rule equalityI, auto)
 apply (frule transM, assumption)
 apply (frule_tac a=x in exists_wfrank, assumption+, clarify)
 apply (rule_tac b="range(f)" in domainI)
 apply (rule_tac x=x in ReplaceI)
   apply simp 
   apply (rule_tac x=f in rexI, blast, simp_all)
 txt\<open>Uniqueness (for Replacement): repeated above!\<close>
 apply clarify
 apply (drule is_recfun_functional, assumption)
     apply (blast intro: wellfounded_trancl)
     apply (simp_all add: trancl_subset_times trans_trancl)
 done
 
 lemma (in M_wfrank) wellfoundedrank_type:
     "\<lbrakk>wellfounded(M,r);  M(r); M(A)\<rbrakk>
      \<Longrightarrow> wellfoundedrank(M,r,A) \<in> A -> range(wellfoundedrank(M,r,A))"
 apply (frule function_wellfoundedrank [of r A], assumption+)
 apply (frule function_imp_Pi)
  apply (simp add: wellfoundedrank_def relation_def)
  apply blast
 apply (simp add: domain_wellfoundedrank)
 done
 
 lemma (in M_wfrank) Ord_wellfoundedrank:
     "\<lbrakk>wellfounded(M,r); a \<in> A; r \<subseteq> A*A;  M(r); M(A)\<rbrakk>
      \<Longrightarrow> Ord(wellfoundedrank(M,r,A) ` a)"
 by (blast intro: apply_funtype [OF wellfoundedrank_type]
                  Ord_in_Ord [OF Ord_range_wellfoundedrank])
 
 lemma (in M_wfrank) wellfoundedrank_eq:
      "\<lbrakk>is_recfun(r^+, a, \<lambda>x. range, f);
          wellfounded(M,r);  a \<in> A; M(f); M(r); M(A)\<rbrakk>
       \<Longrightarrow> wellfoundedrank(M,r,A) ` a = range(f)"
 apply (rule apply_equality)
  prefer 2 apply (blast intro: wellfoundedrank_type)
 apply (simp add: wellfoundedrank_def)
 apply (rule ReplaceI)
   apply (rule_tac x="range(f)" in rexI) 
   apply blast
  apply simp_all
 txt\<open>Unicity requirement of Replacement\<close>
 apply clarify
 apply (drule is_recfun_functional, assumption)
     apply (blast intro: wellfounded_trancl)
     apply (simp_all add: trancl_subset_times trans_trancl)
 done
 
 
 lemma (in M_wfrank) wellfoundedrank_lt:
      "\<lbrakk>\<langle>a,b\<rangle> \<in> r;
          wellfounded(M,r); r \<subseteq> A*A;  M(r); M(A)\<rbrakk>
       \<Longrightarrow> wellfoundedrank(M,r,A) ` a < wellfoundedrank(M,r,A) ` b"
 apply (frule wellfounded_trancl, assumption)
 apply (subgoal_tac "a\<in>A \<and> b\<in>A")
  prefer 2 apply blast
 apply (simp add: lt_def Ord_wellfoundedrank, clarify)
 apply (frule exists_wfrank [of concl: _ b], erule (1) transM, assumption)
 apply clarify
 apply (rename_tac fb)
 apply (frule is_recfun_restrict [of concl: "r^+" a])
     apply (rule trans_trancl, assumption)
    apply (simp_all add: r_into_trancl trancl_subset_times)
 txt\<open>Still the same goal, but with new \<open>is_recfun\<close> assumptions.\<close>
 apply (simp add: wellfoundedrank_eq)
 apply (frule_tac a=a in wellfoundedrank_eq, assumption+)
    apply (simp_all add: transM [of a])
 txt\<open>We have used equations for wellfoundedrank and now must use some
     for  \<open>is_recfun\<close>.\<close>
 apply (rule_tac a=a in rangeI)
 apply (simp add: is_recfun_type [THEN apply_iff] vimage_singleton_iff
                  r_into_trancl apply_recfun)
 done
 
 
 lemma (in M_wfrank) wellfounded_imp_subset_rvimage:
      "\<lbrakk>wellfounded(M,r); r \<subseteq> A*A; M(r); M(A)\<rbrakk>
       \<Longrightarrow> \<exists>i f. Ord(i) \<and> r \<subseteq> rvimage(A, f, Memrel(i))"
 apply (rule_tac x="range(wellfoundedrank(M,r,A))" in exI)
 apply (rule_tac x="wellfoundedrank(M,r,A)" in exI)
 apply (simp add: Ord_range_wellfoundedrank, clarify)
 apply (frule subsetD, assumption, clarify)
 apply (simp add: rvimage_iff wellfoundedrank_lt [THEN ltD])
 apply (blast intro: apply_rangeI wellfoundedrank_type)
 done
 
 lemma (in M_wfrank) wellfounded_imp_wf:
      "\<lbrakk>wellfounded(M,r); relation(r); M(r)\<rbrakk> \<Longrightarrow> wf(r)"
 by (blast dest!: relation_field_times_field wellfounded_imp_subset_rvimage
           intro: wf_rvimage_Ord [THEN wf_subset])
 
 lemma (in M_wfrank) wellfounded_on_imp_wf_on:
      "\<lbrakk>wellfounded_on(M,A,r); relation(r); M(r); M(A)\<rbrakk> \<Longrightarrow> wf[A](r)"
 apply (simp add: wellfounded_on_iff_wellfounded wf_on_def)
 apply (rule wellfounded_imp_wf)
 apply (simp_all add: relation_def)
 done
 
 
 theorem (in M_wfrank) wf_abs:
      "\<lbrakk>relation(r); M(r)\<rbrakk> \<Longrightarrow> wellfounded(M,r) \<longleftrightarrow> wf(r)"
 by (blast intro: wellfounded_imp_wf wf_imp_relativized)
 
 theorem (in M_wfrank) wf_on_abs:
      "\<lbrakk>relation(r); M(r); M(A)\<rbrakk> \<Longrightarrow> wellfounded_on(M,A,r) \<longleftrightarrow> wf[A](r)"
 by (blast intro: wellfounded_on_imp_wf_on wf_on_imp_relativized)
 
 end
diff --git a/src/ZF/Constructible/Reflection.thy b/src/ZF/Constructible/Reflection.thy
--- a/src/ZF/Constructible/Reflection.thy
+++ b/src/ZF/Constructible/Reflection.thy
@@ -1,370 +1,370 @@
 (*  Title:      ZF/Constructible/Reflection.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
 *)
 
 section \<open>The Reflection Theorem\<close>
 
 theory Reflection imports Normal begin
 
 lemma all_iff_not_ex_not: "(\<forall>x. P(x)) \<longleftrightarrow> (\<not> (\<exists>x. \<not> P(x)))"
   by blast
 
 lemma ball_iff_not_bex_not: "(\<forall>x\<in>A. P(x)) \<longleftrightarrow> (\<not> (\<exists>x\<in>A. \<not> P(x)))"
   by blast
 
 text\<open>From the notes of A. S. Kechris, page 6, and from
       Andrzej Mostowski, \emph{Constructible Sets with Applications},
       North-Holland, 1969, page 23.\<close>
 
 
 subsection\<open>Basic Definitions\<close>
 
 text\<open>First part: the cumulative hierarchy defining the class \<open>M\<close>.
 To avoid handling multiple arguments, we assume that \<open>Mset(l)\<close> is
 closed under ordered pairing provided \<open>l\<close> is limit.  Possibly this
 could be avoided: the induction hypothesis \<^term>\<open>Cl_reflects\<close>
 (in locale \<open>ex_reflection\<close>) could be weakened to
 \<^term>\<open>\<forall>y\<in>Mset(a). \<forall>z\<in>Mset(a). P(\<langle>y,z\<rangle>) \<longleftrightarrow> Q(a,\<langle>y,z\<rangle>)\<close>, removing most
 uses of \<^term>\<open>Pair_in_Mset\<close>.  But there isn't much point in doing so, since
 ultimately the \<open>ex_reflection\<close> proof is packaged up using the
 predicate \<open>Reflects\<close>.
 \<close>
 locale reflection =
   fixes Mset and M and Reflects
   assumes Mset_mono_le : "mono_le_subset(Mset)"
       and Mset_cont    : "cont_Ord(Mset)"
       and Pair_in_Mset : "\<lbrakk>x \<in> Mset(a); y \<in> Mset(a); Limit(a)\<rbrakk>
                           \<Longrightarrow> \<langle>x,y\<rangle> \<in> Mset(a)"
   defines "M(x) \<equiv> \<exists>a. Ord(a) \<and> x \<in> Mset(a)"
       and "Reflects(Cl,P,Q) \<equiv> Closed_Unbounded(Cl) \<and>
                               (\<forall>a. Cl(a) \<longrightarrow> (\<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x)))"
   fixes F0 \<comment> \<open>ordinal for a specific value \<^term>\<open>y\<close>\<close>
   fixes FF \<comment> \<open>sup over the whole level, \<^term>\<open>y\<in>Mset(a)\<close>\<close>
   fixes ClEx \<comment> \<open>Reflecting ordinals for the formula \<^term>\<open>\<exists>z. P\<close>\<close>
   defines "F0(P,y) \<equiv> \<mu> b. (\<exists>z. M(z) \<and> P(\<langle>y,z\<rangle>)) \<longrightarrow>
                                (\<exists>z\<in>Mset(b). P(\<langle>y,z\<rangle>))"
       and "FF(P)   \<equiv> \<lambda>a. \<Union>y\<in>Mset(a). F0(P,y)"
       and "ClEx(P,a) \<equiv> Limit(a) \<and> normalize(FF(P),a) = a"
 
 begin 
 
 lemma Mset_mono: "i\<le>j \<Longrightarrow> Mset(i) \<subseteq> Mset(j)"
   using Mset_mono_le by (simp add: mono_le_subset_def leI)
 
 text\<open>Awkward: we need a version of \<open>ClEx_def\<close> as an equality
       at the level of classes, which do not really exist\<close>
 lemma ClEx_eq:
      "ClEx(P) \<equiv> \<lambda>a. Limit(a) \<and> normalize(FF(P),a) = a"
 by (simp add: ClEx_def [symmetric])
 
 
 subsection\<open>Easy Cases of the Reflection Theorem\<close>
 
 theorem Triv_reflection [intro]:
   "Reflects(Ord, P, \<lambda>a x. P(x))"
   by (simp add: Reflects_def)
 
 theorem Not_reflection [intro]:
   "Reflects(Cl,P,Q) \<Longrightarrow> Reflects(Cl, \<lambda>x. \<not>P(x), \<lambda>a x. \<not>Q(a,x))"
   by (simp add: Reflects_def)
 
 theorem And_reflection [intro]:
   "\<lbrakk>Reflects(Cl,P,Q); Reflects(C',P',Q')\<rbrakk>
       \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> C'(a), \<lambda>x. P(x) \<and> P'(x),
                                       \<lambda>a x. Q(a,x) \<and> Q'(a,x))"
   by (simp add: Reflects_def Closed_Unbounded_Int, blast)
 
 theorem Or_reflection [intro]:
      "\<lbrakk>Reflects(Cl,P,Q); Reflects(C',P',Q')\<rbrakk>
       \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> C'(a), \<lambda>x. P(x) \<or> P'(x),
                                       \<lambda>a x. Q(a,x) \<or> Q'(a,x))"
 by (simp add: Reflects_def Closed_Unbounded_Int, blast)
 
 theorem Imp_reflection [intro]:
      "\<lbrakk>Reflects(Cl,P,Q); Reflects(C',P',Q')\<rbrakk>
       \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> C'(a),
                    \<lambda>x. P(x) \<longrightarrow> P'(x),
                    \<lambda>a x. Q(a,x) \<longrightarrow> Q'(a,x))"
 by (simp add: Reflects_def Closed_Unbounded_Int, blast)
 
 theorem Iff_reflection [intro]:
      "\<lbrakk>Reflects(Cl,P,Q); Reflects(C',P',Q')\<rbrakk>
       \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> C'(a),
                    \<lambda>x. P(x) \<longleftrightarrow> P'(x),
                    \<lambda>a x. Q(a,x) \<longleftrightarrow> Q'(a,x))"
 by (simp add: Reflects_def Closed_Unbounded_Int, blast)
 
 subsection\<open>Reflection for Existential Quantifiers\<close>
 
 lemma F0_works:
   "\<lbrakk>y\<in>Mset(a); Ord(a); M(z); P(\<langle>y,z\<rangle>)\<rbrakk> \<Longrightarrow> \<exists>z\<in>Mset(F0(P,y)). P(\<langle>y,z\<rangle>)"
   unfolding F0_def M_def
   apply clarify
   apply (rule LeastI2)
     apply (blast intro: Mset_mono [THEN subsetD])
    apply (blast intro: lt_Ord2, blast)
   done
 
 lemma Ord_F0 [intro,simp]: "Ord(F0(P,y))"
   by (simp add: F0_def)
 
 lemma Ord_FF [intro,simp]: "Ord(FF(P,y))"
   by (simp add: FF_def)
 
 lemma cont_Ord_FF: "cont_Ord(FF(P))"
   using Mset_cont by (simp add: cont_Ord_def FF_def, blast)
 
 text\<open>Recall that \<^term>\<open>F0\<close> depends upon \<^term>\<open>y\<in>Mset(a)\<close>,
 while \<^term>\<open>FF\<close> depends only upon \<^term>\<open>a\<close>.\<close>
 lemma FF_works:
   "\<lbrakk>M(z); y\<in>Mset(a); P(\<langle>y,z\<rangle>); Ord(a)\<rbrakk> \<Longrightarrow> \<exists>z\<in>Mset(FF(P,a)). P(\<langle>y,z\<rangle>)"
   apply (simp add: FF_def)
   apply (simp_all add: cont_Ord_Union [of concl: Mset]
       Mset_cont Mset_mono_le not_emptyI)
   apply (blast intro: F0_works)
   done
 
 lemma FFN_works:
      "\<lbrakk>M(z); y\<in>Mset(a); P(\<langle>y,z\<rangle>); Ord(a)\<rbrakk>
       \<Longrightarrow> \<exists>z\<in>Mset(normalize(FF(P),a)). P(\<langle>y,z\<rangle>)"
 apply (drule FF_works [of concl: P], assumption+)
 apply (blast intro: cont_Ord_FF le_normalize [THEN Mset_mono, THEN subsetD])
 done
 
 end
 
 text\<open>Locale for the induction hypothesis\<close>
 
 locale ex_reflection = reflection +
   fixes P  \<comment> \<open>the original formula\<close>
   fixes Q  \<comment> \<open>the reflected formula\<close>
   fixes Cl \<comment> \<open>the class of reflecting ordinals\<close>
   assumes Cl_reflects: "\<lbrakk>Cl(a); Ord(a)\<rbrakk> \<Longrightarrow> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x)"
 
 begin
 
 lemma ClEx_downward:
      "\<lbrakk>M(z); y\<in>Mset(a); P(\<langle>y,z\<rangle>); Cl(a); ClEx(P,a)\<rbrakk>
       \<Longrightarrow> \<exists>z\<in>Mset(a). Q(a,\<langle>y,z\<rangle>)"
 apply (simp add: ClEx_def, clarify)
 apply (frule Limit_is_Ord)
 apply (frule FFN_works [of concl: P], assumption+)
 apply (drule Cl_reflects, assumption+)
 apply (auto simp add: Limit_is_Ord Pair_in_Mset)
 done
 
 lemma ClEx_upward:
      "\<lbrakk>z\<in>Mset(a); y\<in>Mset(a); Q(a,\<langle>y,z\<rangle>); Cl(a); ClEx(P,a)\<rbrakk>
       \<Longrightarrow> \<exists>z. M(z) \<and> P(\<langle>y,z\<rangle>)"
 apply (simp add: ClEx_def M_def)
 apply (blast dest: Cl_reflects
              intro: Limit_is_Ord Pair_in_Mset)
 done
 
 text\<open>Class \<open>ClEx\<close> indeed consists of reflecting ordinals...\<close>
 lemma ZF_ClEx_iff:
      "\<lbrakk>y\<in>Mset(a); Cl(a); ClEx(P,a)\<rbrakk>
       \<Longrightarrow> (\<exists>z. M(z) \<and> P(\<langle>y,z\<rangle>)) \<longleftrightarrow> (\<exists>z\<in>Mset(a). Q(a,\<langle>y,z\<rangle>))"
 by (blast intro: dest: ClEx_downward ClEx_upward)
 
 text\<open>...and it is closed and unbounded\<close>
 lemma ZF_Closed_Unbounded_ClEx:
      "Closed_Unbounded(ClEx(P))"
 apply (simp add: ClEx_eq)
 apply (fast intro: Closed_Unbounded_Int Normal_imp_fp_Closed_Unbounded
                    Closed_Unbounded_Limit Normal_normalize)
 done
 
 end
 
 text\<open>The same two theorems, exported to locale \<open>reflection\<close>.\<close>
 
 context reflection
 begin
 
 text\<open>Class \<open>ClEx\<close> indeed consists of reflecting ordinals...\<close>
 lemma ClEx_iff:
      "\<lbrakk>y\<in>Mset(a); Cl(a); ClEx(P,a);
         \<And>a. \<lbrakk>Cl(a); Ord(a)\<rbrakk> \<Longrightarrow> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x)\<rbrakk>
       \<Longrightarrow> (\<exists>z. M(z) \<and> P(\<langle>y,z\<rangle>)) \<longleftrightarrow> (\<exists>z\<in>Mset(a). Q(a,\<langle>y,z\<rangle>))"
-apply (unfold ClEx_def FF_def F0_def M_def)
+  unfolding ClEx_def FF_def F0_def M_def
 apply (rule ex_reflection.ZF_ClEx_iff
   [OF ex_reflection.intro, OF reflection.intro ex_reflection_axioms.intro,
     of Mset Cl])
 apply (simp_all add: Mset_mono_le Mset_cont Pair_in_Mset)
 done
 
 (*Alternative proof, less unfolding:
 apply (rule Reflection.ZF_ClEx_iff [of Mset _ _ Cl, folded M_def])
 apply (fold ClEx_def FF_def F0_def)
 apply (rule ex_reflection.intro, assumption)
 apply (simp add: ex_reflection_axioms.intro, assumption+)
 *)
 
 lemma Closed_Unbounded_ClEx:
      "(\<And>a. \<lbrakk>Cl(a); Ord(a)\<rbrakk> \<Longrightarrow> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x))
       \<Longrightarrow> Closed_Unbounded(ClEx(P))"
-apply (unfold ClEx_eq FF_def F0_def M_def)
+  unfolding ClEx_eq FF_def F0_def M_def
 apply (rule ex_reflection.ZF_Closed_Unbounded_ClEx [of Mset _ _ Cl])
 apply (rule ex_reflection.intro, rule reflection_axioms)
 apply (blast intro: ex_reflection_axioms.intro)
 done
 
 subsection\<open>Packaging the Quantifier Reflection Rules\<close>
 
 lemma Ex_reflection_0:
      "Reflects(Cl,P0,Q0)
       \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(P0,a),
                    \<lambda>x. \<exists>z. M(z) \<and> P0(\<langle>x,z\<rangle>),
                    \<lambda>a x. \<exists>z\<in>Mset(a). Q0(a,\<langle>x,z\<rangle>))"
 apply (simp add: Reflects_def)
 apply (intro conjI Closed_Unbounded_Int)
   apply blast
  apply (rule Closed_Unbounded_ClEx [of Cl P0 Q0], blast, clarify)
 apply (rule_tac Cl=Cl in  ClEx_iff, assumption+, blast)
 done
 
 lemma All_reflection_0:
      "Reflects(Cl,P0,Q0)
       \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(\<lambda>x.\<not>P0(x), a),
                    \<lambda>x. \<forall>z. M(z) \<longrightarrow> P0(\<langle>x,z\<rangle>),
                    \<lambda>a x. \<forall>z\<in>Mset(a). Q0(a,\<langle>x,z\<rangle>))"
 apply (simp only: all_iff_not_ex_not ball_iff_not_bex_not)
 apply (rule Not_reflection, drule Not_reflection, simp)
 apply (erule Ex_reflection_0)
 done
 
 theorem Ex_reflection [intro]:
      "Reflects(Cl, \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
       \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(\<lambda>x. P(fst(x),snd(x)), a),
                    \<lambda>x. \<exists>z. M(z) \<and> P(x,z),
                    \<lambda>a x. \<exists>z\<in>Mset(a). Q(a,x,z))"
 by (rule Ex_reflection_0 [of _ " \<lambda>x. P(fst(x),snd(x))"
                                "\<lambda>a x. Q(a,fst(x),snd(x))", simplified])
 
 theorem All_reflection [intro]:
      "Reflects(Cl,  \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
       \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(\<lambda>x. \<not>P(fst(x),snd(x)), a),
                    \<lambda>x. \<forall>z. M(z) \<longrightarrow> P(x,z),
                    \<lambda>a x. \<forall>z\<in>Mset(a). Q(a,x,z))"
 by (rule All_reflection_0 [of _ "\<lambda>x. P(fst(x),snd(x))"
                                 "\<lambda>a x. Q(a,fst(x),snd(x))", simplified])
 
 text\<open>And again, this time using class-bounded quantifiers\<close>
 
 theorem Rex_reflection [intro]:
      "Reflects(Cl, \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
       \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(\<lambda>x. P(fst(x),snd(x)), a),
                    \<lambda>x. \<exists>z[M]. P(x,z),
                    \<lambda>a x. \<exists>z\<in>Mset(a). Q(a,x,z))"
 by (unfold rex_def, blast)
 
 theorem Rall_reflection [intro]:
      "Reflects(Cl,  \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
       \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(\<lambda>x. \<not>P(fst(x),snd(x)), a),
                    \<lambda>x. \<forall>z[M]. P(x,z),
                    \<lambda>a x. \<forall>z\<in>Mset(a). Q(a,x,z))"
 by (unfold rall_def, blast)
 
 
 text\<open>No point considering bounded quantifiers, where reflection is trivial.\<close>
 
 
 subsection\<open>Simple Examples of Reflection\<close>
 
 text\<open>Example 1: reflecting a simple formula.  The reflecting class is first
 given as the variable \<open>?Cl\<close> and later retrieved from the final
 proof state.\<close>
 schematic_goal
      "Reflects(?Cl,
                \<lambda>x. \<exists>y. M(y) \<and> x \<in> y,
                \<lambda>a x. \<exists>y\<in>Mset(a). x \<in> y)"
 by fast
 
 text\<open>Problem here: there needs to be a conjunction (class intersection)
 in the class of reflecting ordinals.  The \<^term>\<open>Ord(a)\<close> is redundant,
 though harmless.\<close>
 lemma
      "Reflects(\<lambda>a. Ord(a) \<and> ClEx(\<lambda>x. fst(x) \<in> snd(x), a),
                \<lambda>x. \<exists>y. M(y) \<and> x \<in> y,
                \<lambda>a x. \<exists>y\<in>Mset(a). x \<in> y)"
 by fast
 
 
 text\<open>Example 2\<close>
 schematic_goal
      "Reflects(?Cl,
                \<lambda>x. \<exists>y. M(y) \<and> (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
                \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
 by fast
 
 text\<open>Example 2'.  We give the reflecting class explicitly.\<close>
 lemma
   "Reflects
     (\<lambda>a. (Ord(a) \<and>
           ClEx(\<lambda>x. \<not> (snd(x) \<subseteq> fst(fst(x)) \<longrightarrow> snd(x) \<in> snd(fst(x))), a)) \<and>
           ClEx(\<lambda>x. \<forall>z. M(z) \<longrightarrow> z \<subseteq> fst(x) \<longrightarrow> z \<in> snd(x), a),
             \<lambda>x. \<exists>y. M(y) \<and> (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
             \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
 by fast
 
 text\<open>Example 2''.  We expand the subset relation.\<close>
 schematic_goal
   "Reflects(?Cl,
         \<lambda>x. \<exists>y. M(y) \<and> (\<forall>z. M(z) \<longrightarrow> (\<forall>w. M(w) \<longrightarrow> w\<in>z \<longrightarrow> w\<in>x) \<longrightarrow> z\<in>y),
         \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). (\<forall>w\<in>Mset(a). w\<in>z \<longrightarrow> w\<in>x) \<longrightarrow> z\<in>y)"
 by fast
 
 text\<open>Example 2'''.  Single-step version, to reveal the reflecting class.\<close>
 schematic_goal
      "Reflects(?Cl,
                \<lambda>x. \<exists>y. M(y) \<and> (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
                \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
 apply (rule Ex_reflection)
 txt\<open>
 @{goals[display,indent=0,margin=60]}
 \<close>
 apply (rule All_reflection)
 txt\<open>
 @{goals[display,indent=0,margin=60]}
 \<close>
 apply (rule Triv_reflection)
 txt\<open>
 @{goals[display,indent=0,margin=60]}
 \<close>
 done
 
 text\<open>Example 3.  Warning: the following examples make sense only
 if \<^term>\<open>P\<close> is quantifier-free, since it is not being relativized.\<close>
 schematic_goal
      "Reflects(?Cl,
                \<lambda>x. \<exists>y. M(y) \<and> (\<forall>z. M(z) \<longrightarrow> z \<in> y \<longleftrightarrow> z \<in> x \<and> P(z)),
                \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<in> y \<longleftrightarrow> z \<in> x \<and> P(z))"
 by fast
 
 text\<open>Example 3'\<close>
 schematic_goal
      "Reflects(?Cl,
                \<lambda>x. \<exists>y. M(y) \<and> y = Collect(x,P),
                \<lambda>a x. \<exists>y\<in>Mset(a). y = Collect(x,P))"
 by fast
 
 text\<open>Example 3''\<close>
 schematic_goal
      "Reflects(?Cl,
                \<lambda>x. \<exists>y. M(y) \<and> y = Replace(x,P),
                \<lambda>a x. \<exists>y\<in>Mset(a). y = Replace(x,P))"
 by fast
 
 text\<open>Example 4: Axiom of Choice.  Possibly wrong, since \<open>\<Pi>\<close> needs
 to be relativized.\<close>
 schematic_goal
      "Reflects(?Cl,
                \<lambda>A. 0\<notin>A \<longrightarrow> (\<exists>f. M(f) \<and> f \<in> (\<Prod>X \<in> A. X)),
                \<lambda>a A. 0\<notin>A \<longrightarrow> (\<exists>f\<in>Mset(a). f \<in> (\<Prod>X \<in> A. X)))"
 by fast
 
 end
 
 end
 
diff --git a/src/ZF/Constructible/Relative.thy b/src/ZF/Constructible/Relative.thy
--- a/src/ZF/Constructible/Relative.thy
+++ b/src/ZF/Constructible/Relative.thy
@@ -1,1671 +1,1671 @@
 (*  Title:      ZF/Constructible/Relative.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
                 With modifications by E. Gunther, M. Pagano, 
                 and P. Sánchez Terraf
 *)
 
 section \<open>Relativization and Absoluteness\<close>
 
 theory Relative imports ZF begin
 
 subsection\<open>Relativized versions of standard set-theoretic concepts\<close>
 
 definition
   empty :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     "empty(M,z) \<equiv> \<forall>x[M]. x \<notin> z"
 
 definition
   subset :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
     "subset(M,A,B) \<equiv> \<forall>x[M]. x\<in>A \<longrightarrow> x \<in> B"
 
 definition
   upair :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "upair(M,a,b,z) \<equiv> a \<in> z \<and> b \<in> z \<and> (\<forall>x[M]. x\<in>z \<longrightarrow> x = a \<or> x = b)"
 
 definition
   pair :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "pair(M,a,b,z) \<equiv> \<exists>x[M]. upair(M,a,a,x) \<and>
                      (\<exists>y[M]. upair(M,a,b,y) \<and> upair(M,x,y,z))"
 
 
 definition
   union :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "union(M,a,b,z) \<equiv> \<forall>x[M]. x \<in> z \<longleftrightarrow> x \<in> a \<or> x \<in> b"
 
 definition
   is_cons :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "is_cons(M,a,b,z) \<equiv> \<exists>x[M]. upair(M,a,a,x) \<and> union(M,x,b,z)"
 
 definition
   successor :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
     "successor(M,a,z) \<equiv> is_cons(M,a,a,z)"
 
 definition
   number1 :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     "number1(M,a) \<equiv> \<exists>x[M]. empty(M,x) \<and> successor(M,x,a)"
 
 definition
   number2 :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     "number2(M,a) \<equiv> \<exists>x[M]. number1(M,x) \<and> successor(M,x,a)"
 
 definition
   number3 :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     "number3(M,a) \<equiv> \<exists>x[M]. number2(M,x) \<and> successor(M,x,a)"
 
 definition
   powerset :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
     "powerset(M,A,z) \<equiv> \<forall>x[M]. x \<in> z \<longleftrightarrow> subset(M,x,A)"
 
 definition
   is_Collect :: "[i\<Rightarrow>o,i,i\<Rightarrow>o,i] \<Rightarrow> o" where
     "is_Collect(M,A,P,z) \<equiv> \<forall>x[M]. x \<in> z \<longleftrightarrow> x \<in> A \<and> P(x)"
 
 definition
   is_Replace :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>o,i] \<Rightarrow> o" where
     "is_Replace(M,A,P,z) \<equiv> \<forall>u[M]. u \<in> z \<longleftrightarrow> (\<exists>x[M]. x\<in>A \<and> P(x,u))"
 
 definition
   inter :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "inter(M,a,b,z) \<equiv> \<forall>x[M]. x \<in> z \<longleftrightarrow> x \<in> a \<and> x \<in> b"
 
 definition
   setdiff :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "setdiff(M,a,b,z) \<equiv> \<forall>x[M]. x \<in> z \<longleftrightarrow> x \<in> a \<and> x \<notin> b"
 
 definition
   big_union :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
     "big_union(M,A,z) \<equiv> \<forall>x[M]. x \<in> z \<longleftrightarrow> (\<exists>y[M]. y\<in>A \<and> x \<in> y)"
 
 definition
   big_inter :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
     "big_inter(M,A,z) \<equiv>
              (A=0 \<longrightarrow> z=0) \<and>
              (A\<noteq>0 \<longrightarrow> (\<forall>x[M]. x \<in> z \<longleftrightarrow> (\<forall>y[M]. y\<in>A \<longrightarrow> x \<in> y)))"
 
 definition
   cartprod :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "cartprod(M,A,B,z) \<equiv>
         \<forall>u[M]. u \<in> z \<longleftrightarrow> (\<exists>x[M]. x\<in>A \<and> (\<exists>y[M]. y\<in>B \<and> pair(M,x,y,u)))"
 
 definition
   is_sum :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "is_sum(M,A,B,Z) \<equiv>
        \<exists>A0[M]. \<exists>n1[M]. \<exists>s1[M]. \<exists>B1[M].
        number1(M,n1) \<and> cartprod(M,n1,A,A0) \<and> upair(M,n1,n1,s1) \<and>
        cartprod(M,s1,B,B1) \<and> union(M,A0,B1,Z)"
 
 definition
   is_Inl :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
     "is_Inl(M,a,z) \<equiv> \<exists>zero[M]. empty(M,zero) \<and> pair(M,zero,a,z)"
 
 definition
   is_Inr :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
     "is_Inr(M,a,z) \<equiv> \<exists>n1[M]. number1(M,n1) \<and> pair(M,n1,a,z)"
 
 definition
   is_converse :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
     "is_converse(M,r,z) \<equiv>
         \<forall>x[M]. x \<in> z \<longleftrightarrow>
              (\<exists>w[M]. w\<in>r \<and> (\<exists>u[M]. \<exists>v[M]. pair(M,u,v,w) \<and> pair(M,v,u,x)))"
 
 definition
   pre_image :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "pre_image(M,r,A,z) \<equiv>
         \<forall>x[M]. x \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r \<and> (\<exists>y[M]. y\<in>A \<and> pair(M,x,y,w)))"
 
 definition
   is_domain :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
     "is_domain(M,r,z) \<equiv>
         \<forall>x[M]. x \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r \<and> (\<exists>y[M]. pair(M,x,y,w)))"
 
 definition
   image :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "image(M,r,A,z) \<equiv>
         \<forall>y[M]. y \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r \<and> (\<exists>x[M]. x\<in>A \<and> pair(M,x,y,w)))"
 
 definition
   is_range :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
     \<comment> \<open>the cleaner
       \<^term>\<open>\<exists>r'[M]. is_converse(M,r,r') \<and> is_domain(M,r',z)\<close>
       unfortunately needs an instance of separation in order to prove
         \<^term>\<open>M(converse(r))\<close>.\<close>
     "is_range(M,r,z) \<equiv>
         \<forall>y[M]. y \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r \<and> (\<exists>x[M]. pair(M,x,y,w)))"
 
 definition
   is_field :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
     "is_field(M,r,z) \<equiv>
         \<exists>dr[M]. \<exists>rr[M]. is_domain(M,r,dr) \<and> is_range(M,r,rr) \<and>
                         union(M,dr,rr,z)"
 
 definition
   is_relation :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     "is_relation(M,r) \<equiv>
         (\<forall>z[M]. z\<in>r \<longrightarrow> (\<exists>x[M]. \<exists>y[M]. pair(M,x,y,z)))"
 
 definition
   is_function :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     "is_function(M,r) \<equiv>
         \<forall>x[M]. \<forall>y[M]. \<forall>y'[M]. \<forall>p[M]. \<forall>p'[M].
            pair(M,x,y,p) \<longrightarrow> pair(M,x,y',p') \<longrightarrow> p\<in>r \<longrightarrow> p'\<in>r \<longrightarrow> y=y'"
 
 definition
   fun_apply :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "fun_apply(M,f,x,y) \<equiv>
         (\<exists>xs[M]. \<exists>fxs[M].
          upair(M,x,x,xs) \<and> image(M,f,xs,fxs) \<and> big_union(M,fxs,y))"
 
 definition
   typed_function :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "typed_function(M,A,B,r) \<equiv>
         is_function(M,r) \<and> is_relation(M,r) \<and> is_domain(M,r,A) \<and>
         (\<forall>u[M]. u\<in>r \<longrightarrow> (\<forall>x[M]. \<forall>y[M]. pair(M,x,y,u) \<longrightarrow> y\<in>B))"
 
 definition
   is_funspace :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "is_funspace(M,A,B,F) \<equiv>
         \<forall>f[M]. f \<in> F \<longleftrightarrow> typed_function(M,A,B,f)"
 
 definition
   composition :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "composition(M,r,s,t) \<equiv>
         \<forall>p[M]. p \<in> t \<longleftrightarrow>
                (\<exists>x[M]. \<exists>y[M]. \<exists>z[M]. \<exists>xy[M]. \<exists>yz[M].
                 pair(M,x,z,p) \<and> pair(M,x,y,xy) \<and> pair(M,y,z,yz) \<and>
                 xy \<in> s \<and> yz \<in> r)"
 
 definition
   injection :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "injection(M,A,B,f) \<equiv>
         typed_function(M,A,B,f) \<and>
         (\<forall>x[M]. \<forall>x'[M]. \<forall>y[M]. \<forall>p[M]. \<forall>p'[M].
           pair(M,x,y,p) \<longrightarrow> pair(M,x',y,p') \<longrightarrow> p\<in>f \<longrightarrow> p'\<in>f \<longrightarrow> x=x')"
 
 definition
   surjection :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "surjection(M,A,B,f) \<equiv>
         typed_function(M,A,B,f) \<and>
         (\<forall>y[M]. y\<in>B \<longrightarrow> (\<exists>x[M]. x\<in>A \<and> fun_apply(M,f,x,y)))"
 
 definition
   bijection :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "bijection(M,A,B,f) \<equiv> injection(M,A,B,f) \<and> surjection(M,A,B,f)"
 
 definition
   restriction :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
     "restriction(M,r,A,z) \<equiv>
         \<forall>x[M]. x \<in> z \<longleftrightarrow> (x \<in> r \<and> (\<exists>u[M]. u\<in>A \<and> (\<exists>v[M]. pair(M,u,v,x))))"
 
 definition
   transitive_set :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     "transitive_set(M,a) \<equiv> \<forall>x[M]. x\<in>a \<longrightarrow> subset(M,x,a)"
 
 definition
   ordinal :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
      \<comment> \<open>an ordinal is a transitive set of transitive sets\<close>
     "ordinal(M,a) \<equiv> transitive_set(M,a) \<and> (\<forall>x[M]. x\<in>a \<longrightarrow> transitive_set(M,x))"
 
 definition
   limit_ordinal :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     \<comment> \<open>a limit ordinal is a non-empty, successor-closed ordinal\<close>
     "limit_ordinal(M,a) \<equiv>
         ordinal(M,a) \<and> \<not> empty(M,a) \<and>
         (\<forall>x[M]. x\<in>a \<longrightarrow> (\<exists>y[M]. y\<in>a \<and> successor(M,x,y)))"
 
 definition
   successor_ordinal :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     \<comment> \<open>a successor ordinal is any ordinal that is neither empty nor limit\<close>
     "successor_ordinal(M,a) \<equiv>
         ordinal(M,a) \<and> \<not> empty(M,a) \<and> \<not> limit_ordinal(M,a)"
 
 definition
   finite_ordinal :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     \<comment> \<open>an ordinal is finite if neither it nor any of its elements are limit\<close>
     "finite_ordinal(M,a) \<equiv>
         ordinal(M,a) \<and> \<not> limit_ordinal(M,a) \<and>
         (\<forall>x[M]. x\<in>a \<longrightarrow> \<not> limit_ordinal(M,x))"
 
 definition
   omega :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     \<comment> \<open>omega is a limit ordinal none of whose elements are limit\<close>
     "omega(M,a) \<equiv> limit_ordinal(M,a) \<and> (\<forall>x[M]. x\<in>a \<longrightarrow> \<not> limit_ordinal(M,x))"
 
 definition
   is_quasinat :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     "is_quasinat(M,z) \<equiv> empty(M,z) \<or> (\<exists>m[M]. successor(M,m,z))"
 
 definition
   is_nat_case :: "[i\<Rightarrow>o, i, [i,i]\<Rightarrow>o, i, i] \<Rightarrow> o" where
     "is_nat_case(M, a, is_b, k, z) \<equiv>
        (empty(M,k) \<longrightarrow> z=a) \<and>
        (\<forall>m[M]. successor(M,m,k) \<longrightarrow> is_b(m,z)) \<and>
        (is_quasinat(M,k) \<or> empty(M,z))"
 
 definition
   relation1 :: "[i\<Rightarrow>o, [i,i]\<Rightarrow>o, i\<Rightarrow>i] \<Rightarrow> o" where
     "relation1(M,is_f,f) \<equiv> \<forall>x[M]. \<forall>y[M]. is_f(x,y) \<longleftrightarrow> y = f(x)"
 
 definition
   Relation1 :: "[i\<Rightarrow>o, i, [i,i]\<Rightarrow>o, i\<Rightarrow>i] \<Rightarrow> o" where
     \<comment> \<open>as above, but typed\<close>
     "Relation1(M,A,is_f,f) \<equiv>
         \<forall>x[M]. \<forall>y[M]. x\<in>A \<longrightarrow> is_f(x,y) \<longleftrightarrow> y = f(x)"
 
 definition
   relation2 :: "[i\<Rightarrow>o, [i,i,i]\<Rightarrow>o, [i,i]\<Rightarrow>i] \<Rightarrow> o" where
     "relation2(M,is_f,f) \<equiv> \<forall>x[M]. \<forall>y[M]. \<forall>z[M]. is_f(x,y,z) \<longleftrightarrow> z = f(x,y)"
 
 definition
   Relation2 :: "[i\<Rightarrow>o, i, i, [i,i,i]\<Rightarrow>o, [i,i]\<Rightarrow>i] \<Rightarrow> o" where
     "Relation2(M,A,B,is_f,f) \<equiv>
         \<forall>x[M]. \<forall>y[M]. \<forall>z[M]. x\<in>A \<longrightarrow> y\<in>B \<longrightarrow> is_f(x,y,z) \<longleftrightarrow> z = f(x,y)"
 
 definition
   relation3 :: "[i\<Rightarrow>o, [i,i,i,i]\<Rightarrow>o, [i,i,i]\<Rightarrow>i] \<Rightarrow> o" where
     "relation3(M,is_f,f) \<equiv>
        \<forall>x[M]. \<forall>y[M]. \<forall>z[M]. \<forall>u[M]. is_f(x,y,z,u) \<longleftrightarrow> u = f(x,y,z)"
 
 definition
   Relation3 :: "[i\<Rightarrow>o, i, i, i, [i,i,i,i]\<Rightarrow>o, [i,i,i]\<Rightarrow>i] \<Rightarrow> o" where
     "Relation3(M,A,B,C,is_f,f) \<equiv>
        \<forall>x[M]. \<forall>y[M]. \<forall>z[M]. \<forall>u[M].
          x\<in>A \<longrightarrow> y\<in>B \<longrightarrow> z\<in>C \<longrightarrow> is_f(x,y,z,u) \<longleftrightarrow> u = f(x,y,z)"
 
 definition
   relation4 :: "[i\<Rightarrow>o, [i,i,i,i,i]\<Rightarrow>o, [i,i,i,i]\<Rightarrow>i] \<Rightarrow> o" where
     "relation4(M,is_f,f) \<equiv>
        \<forall>u[M]. \<forall>x[M]. \<forall>y[M]. \<forall>z[M]. \<forall>a[M]. is_f(u,x,y,z,a) \<longleftrightarrow> a = f(u,x,y,z)"
 
 
 text\<open>Useful when absoluteness reasoning has replaced the predicates by terms\<close>
 lemma triv_Relation1:
      "Relation1(M, A, \<lambda>x y. y = f(x), f)"
 by (simp add: Relation1_def)
 
 lemma triv_Relation2:
      "Relation2(M, A, B, \<lambda>x y a. a = f(x,y), f)"
 by (simp add: Relation2_def)
 
 
 subsection \<open>The relativized ZF axioms\<close>
 
 definition
   extensionality :: "(i\<Rightarrow>o) \<Rightarrow> o" where
     "extensionality(M) \<equiv>
         \<forall>x[M]. \<forall>y[M]. (\<forall>z[M]. z \<in> x \<longleftrightarrow> z \<in> y) \<longrightarrow> x=y"
 
 definition
   separation :: "[i\<Rightarrow>o, i\<Rightarrow>o] \<Rightarrow> o" where
     \<comment> \<open>The formula \<open>P\<close> should only involve parameters
         belonging to \<open>M\<close> and all its quantifiers must be relativized
         to \<open>M\<close>.  We do not have separation as a scheme; every instance
         that we need must be assumed (and later proved) separately.\<close>
     "separation(M,P) \<equiv>
         \<forall>z[M]. \<exists>y[M]. \<forall>x[M]. x \<in> y \<longleftrightarrow> x \<in> z \<and> P(x)"
 
 definition
   upair_ax :: "(i\<Rightarrow>o) \<Rightarrow> o" where
     "upair_ax(M) \<equiv> \<forall>x[M]. \<forall>y[M]. \<exists>z[M]. upair(M,x,y,z)"
 
 definition
   Union_ax :: "(i\<Rightarrow>o) \<Rightarrow> o" where
     "Union_ax(M) \<equiv> \<forall>x[M]. \<exists>z[M]. big_union(M,x,z)"
 
 definition
   power_ax :: "(i\<Rightarrow>o) \<Rightarrow> o" where
     "power_ax(M) \<equiv> \<forall>x[M]. \<exists>z[M]. powerset(M,x,z)"
 
 definition
   univalent :: "[i\<Rightarrow>o, i, [i,i]\<Rightarrow>o] \<Rightarrow> o" where
     "univalent(M,A,P) \<equiv>
         \<forall>x[M]. x\<in>A \<longrightarrow> (\<forall>y[M]. \<forall>z[M]. P(x,y) \<and> P(x,z) \<longrightarrow> y=z)"
 
 definition
   replacement :: "[i\<Rightarrow>o, [i,i]\<Rightarrow>o] \<Rightarrow> o" where
     "replacement(M,P) \<equiv>
       \<forall>A[M]. univalent(M,A,P) \<longrightarrow>
       (\<exists>Y[M]. \<forall>b[M]. (\<exists>x[M]. x\<in>A \<and> P(x,b)) \<longrightarrow> b \<in> Y)"
 
 definition
   strong_replacement :: "[i\<Rightarrow>o, [i,i]\<Rightarrow>o] \<Rightarrow> o" where
     "strong_replacement(M,P) \<equiv>
       \<forall>A[M]. univalent(M,A,P) \<longrightarrow>
       (\<exists>Y[M]. \<forall>b[M]. b \<in> Y \<longleftrightarrow> (\<exists>x[M]. x\<in>A \<and> P(x,b)))"
 
 definition
   foundation_ax :: "(i\<Rightarrow>o) \<Rightarrow> o" where
     "foundation_ax(M) \<equiv>
         \<forall>x[M]. (\<exists>y[M]. y\<in>x) \<longrightarrow> (\<exists>y[M]. y\<in>x \<and> \<not>(\<exists>z[M]. z\<in>x \<and> z \<in> y))"
 
 
 subsection\<open>A trivial consistency proof for $V_\omega$\<close>
 
 text\<open>We prove that $V_\omega$
       (or \<open>univ\<close> in Isabelle) satisfies some ZF axioms.
      Kunen, Theorem IV 3.13, page 123.\<close>
 
 lemma univ0_downwards_mem: "\<lbrakk>y \<in> x; x \<in> univ(0)\<rbrakk> \<Longrightarrow> y \<in> univ(0)"
 apply (insert Transset_univ [OF Transset_0])
 apply (simp add: Transset_def, blast)
 done
 
 lemma univ0_Ball_abs [simp]:
      "A \<in> univ(0) \<Longrightarrow> (\<forall>x\<in>A. x \<in> univ(0) \<longrightarrow> P(x)) \<longleftrightarrow> (\<forall>x\<in>A. P(x))"
 by (blast intro: univ0_downwards_mem)
 
 lemma univ0_Bex_abs [simp]:
      "A \<in> univ(0) \<Longrightarrow> (\<exists>x\<in>A. x \<in> univ(0) \<and> P(x)) \<longleftrightarrow> (\<exists>x\<in>A. P(x))"
 by (blast intro: univ0_downwards_mem)
 
 text\<open>Congruence rule for separation: can assume the variable is in \<open>M\<close>\<close>
 lemma separation_cong [cong]:
      "(\<And>x. M(x) \<Longrightarrow> P(x) \<longleftrightarrow> P'(x))
       \<Longrightarrow> separation(M, \<lambda>x. P(x)) \<longleftrightarrow> separation(M, \<lambda>x. P'(x))"
 by (simp add: separation_def)
 
 lemma univalent_cong [cong]:
      "\<lbrakk>A=A'; \<And>x y. \<lbrakk>x\<in>A; M(x); M(y)\<rbrakk> \<Longrightarrow> P(x,y) \<longleftrightarrow> P'(x,y)\<rbrakk>
       \<Longrightarrow> univalent(M, A, \<lambda>x y. P(x,y)) \<longleftrightarrow> univalent(M, A', \<lambda>x y. P'(x,y))"
 by (simp add: univalent_def)
 
 lemma univalent_triv [intro,simp]:
      "univalent(M, A, \<lambda>x y. y = f(x))"
 by (simp add: univalent_def)
 
 lemma univalent_conjI2 [intro,simp]:
      "univalent(M,A,Q) \<Longrightarrow> univalent(M, A, \<lambda>x y. P(x,y) \<and> Q(x,y))"
 by (simp add: univalent_def, blast)
 
 text\<open>Congruence rule for replacement\<close>
 lemma strong_replacement_cong [cong]:
      "\<lbrakk>\<And>x y. \<lbrakk>M(x); M(y)\<rbrakk> \<Longrightarrow> P(x,y) \<longleftrightarrow> P'(x,y)\<rbrakk>
       \<Longrightarrow> strong_replacement(M, \<lambda>x y. P(x,y)) \<longleftrightarrow>
           strong_replacement(M, \<lambda>x y. P'(x,y))"
 by (simp add: strong_replacement_def)
 
 text\<open>The extensionality axiom\<close>
 lemma "extensionality(\<lambda>x. x \<in> univ(0))"
 apply (simp add: extensionality_def)
 apply (blast intro: univ0_downwards_mem)
 done
 
 text\<open>The separation axiom requires some lemmas\<close>
 lemma Collect_in_Vfrom:
      "\<lbrakk>X \<in> Vfrom(A,j);  Transset(A)\<rbrakk> \<Longrightarrow> Collect(X,P) \<in> Vfrom(A, succ(j))"
 apply (drule Transset_Vfrom)
 apply (rule subset_mem_Vfrom)
 apply (unfold Transset_def, blast)
 done
 
 lemma Collect_in_VLimit:
      "\<lbrakk>X \<in> Vfrom(A,i);  Limit(i);  Transset(A)\<rbrakk>
       \<Longrightarrow> Collect(X,P) \<in> Vfrom(A,i)"
 apply (rule Limit_VfromE, assumption+)
 apply (blast intro: Limit_has_succ VfromI Collect_in_Vfrom)
 done
 
 lemma Collect_in_univ:
      "\<lbrakk>X \<in> univ(A);  Transset(A)\<rbrakk> \<Longrightarrow> Collect(X,P) \<in> univ(A)"
 by (simp add: univ_def Collect_in_VLimit)
 
 lemma "separation(\<lambda>x. x \<in> univ(0), P)"
 apply (simp add: separation_def, clarify)
 apply (rule_tac x = "Collect(z,P)" in bexI)
 apply (blast intro: Collect_in_univ Transset_0)+
 done
 
 text\<open>Unordered pairing axiom\<close>
 lemma "upair_ax(\<lambda>x. x \<in> univ(0))"
 apply (simp add: upair_ax_def upair_def)
 apply (blast intro: doubleton_in_univ)
 done
 
 text\<open>Union axiom\<close>
 lemma "Union_ax(\<lambda>x. x \<in> univ(0))"
 apply (simp add: Union_ax_def big_union_def, clarify)
 apply (rule_tac x="\<Union>x" in bexI)
  apply (blast intro: univ0_downwards_mem)
 apply (blast intro: Union_in_univ Transset_0)
 done
 
 text\<open>Powerset axiom\<close>
 
 lemma Pow_in_univ:
      "\<lbrakk>X \<in> univ(A);  Transset(A)\<rbrakk> \<Longrightarrow> Pow(X) \<in> univ(A)"
 apply (simp add: univ_def Pow_in_VLimit)
 done
 
 lemma "power_ax(\<lambda>x. x \<in> univ(0))"
 apply (simp add: power_ax_def powerset_def subset_def, clarify)
 apply (rule_tac x="Pow(x)" in bexI)
  apply (blast intro: univ0_downwards_mem)
 apply (blast intro: Pow_in_univ Transset_0)
 done
 
 text\<open>Foundation axiom\<close>
 lemma "foundation_ax(\<lambda>x. x \<in> univ(0))"
 apply (simp add: foundation_ax_def, clarify)
 apply (cut_tac A=x in foundation)
 apply (blast intro: univ0_downwards_mem)
 done
 
 lemma "replacement(\<lambda>x. x \<in> univ(0), P)"
 apply (simp add: replacement_def, clarify)
 oops
 text\<open>no idea: maybe prove by induction on the rank of A?\<close>
 
 text\<open>Still missing: Replacement, Choice\<close>
 
 subsection\<open>Lemmas Needed to Reduce Some Set Constructions to Instances
       of Separation\<close>
 
 lemma image_iff_Collect: "r `` A = {y \<in> \<Union>(\<Union>(r)). \<exists>p\<in>r. \<exists>x\<in>A. p=\<langle>x,y\<rangle>}"
 apply (rule equalityI, auto)
 apply (simp add: Pair_def, blast)
 done
 
 lemma vimage_iff_Collect:
      "r -`` A = {x \<in> \<Union>(\<Union>(r)). \<exists>p\<in>r. \<exists>y\<in>A. p=\<langle>x,y\<rangle>}"
 apply (rule equalityI, auto)
 apply (simp add: Pair_def, blast)
 done
 
 text\<open>These two lemmas lets us prove \<open>domain_closed\<close> and
       \<open>range_closed\<close> without new instances of separation\<close>
 
 lemma domain_eq_vimage: "domain(r) = r -`` Union(Union(r))"
 apply (rule equalityI, auto)
 apply (rule vimageI, assumption)
 apply (simp add: Pair_def, blast)
 done
 
 lemma range_eq_image: "range(r) = r `` Union(Union(r))"
 apply (rule equalityI, auto)
 apply (rule imageI, assumption)
 apply (simp add: Pair_def, blast)
 done
 
 lemma replacementD:
     "\<lbrakk>replacement(M,P); M(A);  univalent(M,A,P)\<rbrakk>
      \<Longrightarrow> \<exists>Y[M]. (\<forall>b[M]. ((\<exists>x[M]. x\<in>A \<and> P(x,b)) \<longrightarrow> b \<in> Y))"
 by (simp add: replacement_def)
 
 lemma strong_replacementD:
     "\<lbrakk>strong_replacement(M,P); M(A);  univalent(M,A,P)\<rbrakk>
      \<Longrightarrow> \<exists>Y[M]. (\<forall>b[M]. (b \<in> Y \<longleftrightarrow> (\<exists>x[M]. x\<in>A \<and> P(x,b))))"
 by (simp add: strong_replacement_def)
 
 lemma separationD:
     "\<lbrakk>separation(M,P); M(z)\<rbrakk> \<Longrightarrow> \<exists>y[M]. \<forall>x[M]. x \<in> y \<longleftrightarrow> x \<in> z \<and> P(x)"
 by (simp add: separation_def)
 
 
 text\<open>More constants, for order types\<close>
 
 definition
   order_isomorphism :: "[i\<Rightarrow>o,i,i,i,i,i] \<Rightarrow> o" where
     "order_isomorphism(M,A,r,B,s,f) \<equiv>
         bijection(M,A,B,f) \<and>
         (\<forall>x[M]. x\<in>A \<longrightarrow> (\<forall>y[M]. y\<in>A \<longrightarrow>
           (\<forall>p[M]. \<forall>fx[M]. \<forall>fy[M]. \<forall>q[M].
             pair(M,x,y,p) \<longrightarrow> fun_apply(M,f,x,fx) \<longrightarrow> fun_apply(M,f,y,fy) \<longrightarrow>
             pair(M,fx,fy,q) \<longrightarrow> (p\<in>r \<longleftrightarrow> q\<in>s))))"
 
 definition
   pred_set :: "[i\<Rightarrow>o,i,i,i,i] \<Rightarrow> o" where
     "pred_set(M,A,x,r,B) \<equiv>
         \<forall>y[M]. y \<in> B \<longleftrightarrow> (\<exists>p[M]. p\<in>r \<and> y \<in> A \<and> pair(M,y,x,p))"
 
 definition
   membership :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where \<comment> \<open>membership relation\<close>
     "membership(M,A,r) \<equiv>
         \<forall>p[M]. p \<in> r \<longleftrightarrow> (\<exists>x[M]. x\<in>A \<and> (\<exists>y[M]. y\<in>A \<and> x\<in>y \<and> pair(M,x,y,p)))"
 
 
 subsection\<open>Introducing a Transitive Class Model\<close>
 
 text\<open>The class M is assumed to be transitive and inhabited\<close>
 locale M_trans =
   fixes M
   assumes transM:   "\<lbrakk>y\<in>x; M(x)\<rbrakk> \<Longrightarrow> M(y)"
     and M_inhabited: "\<exists>x . M(x)"
 
 lemma (in M_trans) nonempty [simp]:  "M(0)"
 proof -
   have "M(x) \<longrightarrow> M(0)" for x
   proof (rule_tac P="\<lambda>w. M(w) \<longrightarrow> M(0)" in eps_induct)
     {
     fix x
     assume "\<forall>y\<in>x. M(y) \<longrightarrow> M(0)" "M(x)"
     consider (a) "\<exists>y. y\<in>x" | (b) "x=0" by auto
     then 
     have "M(x) \<longrightarrow> M(0)" 
     proof cases
       case a
       then show ?thesis using \<open>\<forall>y\<in>x._\<close> \<open>M(x)\<close> transM by auto
     next
       case b
       then show ?thesis by simp
     qed
   }
   then show "M(x) \<longrightarrow> M(0)" if "\<forall>y\<in>x. M(y) \<longrightarrow> M(0)" for x
     using that by auto
   qed
   with M_inhabited
   show "M(0)" using M_inhabited by blast
 qed
 
 text\<open>The class M is assumed to be transitive and to satisfy some
       relativized ZF axioms\<close>
 locale M_trivial = M_trans +
   assumes upair_ax:         "upair_ax(M)"
       and Union_ax:         "Union_ax(M)"
 
 lemma (in M_trans) rall_abs [simp]:
      "M(A) \<Longrightarrow> (\<forall>x[M]. x\<in>A \<longrightarrow> P(x)) \<longleftrightarrow> (\<forall>x\<in>A. P(x))"
 by (blast intro: transM)
 
 lemma (in M_trans) rex_abs [simp]:
      "M(A) \<Longrightarrow> (\<exists>x[M]. x\<in>A \<and> P(x)) \<longleftrightarrow> (\<exists>x\<in>A. P(x))"
 by (blast intro: transM)
 
 lemma (in M_trans) ball_iff_equiv:
      "M(A) \<Longrightarrow> (\<forall>x[M]. (x\<in>A \<longleftrightarrow> P(x))) \<longleftrightarrow>
                (\<forall>x\<in>A. P(x)) \<and> (\<forall>x. P(x) \<longrightarrow> M(x) \<longrightarrow> x\<in>A)"
 by (blast intro: transM)
 
 text\<open>Simplifies proofs of equalities when there's an iff-equality
       available for rewriting, universally quantified over M.
       But it's not the only way to prove such equalities: its
       premises \<^term>\<open>M(A)\<close> and  \<^term>\<open>M(B)\<close> can be too strong.\<close>
 lemma (in M_trans) M_equalityI:
      "\<lbrakk>\<And>x. M(x) \<Longrightarrow> x\<in>A \<longleftrightarrow> x\<in>B; M(A); M(B)\<rbrakk> \<Longrightarrow> A=B"
 by (blast dest: transM)
 
 
 subsubsection\<open>Trivial Absoluteness Proofs: Empty Set, Pairs, etc.\<close>
 
 lemma (in M_trans) empty_abs [simp]:
      "M(z) \<Longrightarrow> empty(M,z) \<longleftrightarrow> z=0"
 apply (simp add: empty_def)
 apply (blast intro: transM)
 done
 
 lemma (in M_trans) subset_abs [simp]:
      "M(A) \<Longrightarrow> subset(M,A,B) \<longleftrightarrow> A \<subseteq> B"
 apply (simp add: subset_def)
 apply (blast intro: transM)
 done
 
 lemma (in M_trans) upair_abs [simp]:
      "M(z) \<Longrightarrow> upair(M,a,b,z) \<longleftrightarrow> z={a,b}"
 apply (simp add: upair_def)
 apply (blast intro: transM)
 done
 
 lemma (in M_trivial) upair_in_MI [intro!]:
      " M(a) \<and> M(b) \<Longrightarrow> M({a,b})"
 by (insert upair_ax, simp add: upair_ax_def)
 
 lemma (in M_trans) upair_in_MD [dest!]:
      "M({a,b}) \<Longrightarrow> M(a) \<and> M(b)"
   by (blast intro: transM)
 
 lemma (in M_trivial) upair_in_M_iff [simp]:
   "M({a,b}) \<longleftrightarrow> M(a) \<and> M(b)"
   by blast
 
 lemma (in M_trivial) singleton_in_MI [intro!]:
      "M(a) \<Longrightarrow> M({a})"
   by (insert upair_in_M_iff [of a a], simp)
 
 lemma (in M_trans) singleton_in_MD [dest!]:
      "M({a}) \<Longrightarrow> M(a)"
   by (insert upair_in_MD [of a a], simp)
 
 lemma (in M_trivial) singleton_in_M_iff [simp]:
      "M({a}) \<longleftrightarrow> M(a)"
   by blast
 
 lemma (in M_trans) pair_abs [simp]:
      "M(z) \<Longrightarrow> pair(M,a,b,z) \<longleftrightarrow> z=\<langle>a,b\<rangle>"
 apply (simp add: pair_def Pair_def)
 apply (blast intro: transM)
 done
 
 lemma (in M_trans) pair_in_MD [dest!]:
      "M(\<langle>a,b\<rangle>) \<Longrightarrow> M(a) \<and> M(b)"
   by (simp add: Pair_def, blast intro: transM)
 
 lemma (in M_trivial) pair_in_MI [intro!]:
      "M(a) \<and> M(b) \<Longrightarrow> M(\<langle>a,b\<rangle>)"
   by (simp add: Pair_def)
 
 lemma (in M_trivial) pair_in_M_iff [simp]:
      "M(\<langle>a,b\<rangle>) \<longleftrightarrow> M(a) \<and> M(b)"
   by blast
 
 lemma (in M_trans) pair_components_in_M:
      "\<lbrakk>\<langle>x,y\<rangle> \<in> A; M(A)\<rbrakk> \<Longrightarrow> M(x) \<and> M(y)"
   by (blast dest: transM)
 
 lemma (in M_trivial) cartprod_abs [simp]:
      "\<lbrakk>M(A); M(B); M(z)\<rbrakk> \<Longrightarrow> cartprod(M,A,B,z) \<longleftrightarrow> z = A*B"
 apply (simp add: cartprod_def)
 apply (rule iffI)
  apply (blast intro!: equalityI intro: transM dest!: rspec)
 apply (blast dest: transM)
 done
 
 subsubsection\<open>Absoluteness for Unions and Intersections\<close>
 
 lemma (in M_trans) union_abs [simp]:
      "\<lbrakk>M(a); M(b); M(z)\<rbrakk> \<Longrightarrow> union(M,a,b,z) \<longleftrightarrow> z = a \<union> b"
   unfolding union_def
   by (blast intro: transM )
 
 lemma (in M_trans) inter_abs [simp]:
      "\<lbrakk>M(a); M(b); M(z)\<rbrakk> \<Longrightarrow> inter(M,a,b,z) \<longleftrightarrow> z = a \<inter> b"
   unfolding inter_def
   by (blast intro: transM)
 
 lemma (in M_trans) setdiff_abs [simp]:
      "\<lbrakk>M(a); M(b); M(z)\<rbrakk> \<Longrightarrow> setdiff(M,a,b,z) \<longleftrightarrow> z = a-b"
   unfolding setdiff_def
   by (blast intro: transM)
 
 lemma (in M_trans) Union_abs [simp]:
      "\<lbrakk>M(A); M(z)\<rbrakk> \<Longrightarrow> big_union(M,A,z) \<longleftrightarrow> z = \<Union>(A)"
   unfolding big_union_def
   by (blast  dest: transM)
 
 lemma (in M_trivial) Union_closed [intro,simp]:
      "M(A) \<Longrightarrow> M(\<Union>(A))"
 by (insert Union_ax, simp add: Union_ax_def)
 
 lemma (in M_trivial) Un_closed [intro,simp]:
      "\<lbrakk>M(A); M(B)\<rbrakk> \<Longrightarrow> M(A \<union> B)"
 by (simp only: Un_eq_Union, blast)
 
 lemma (in M_trivial) cons_closed [intro,simp]:
      "\<lbrakk>M(a); M(A)\<rbrakk> \<Longrightarrow> M(cons(a,A))"
 by (subst cons_eq [symmetric], blast)
 
 lemma (in M_trivial) cons_abs [simp]:
      "\<lbrakk>M(b); M(z)\<rbrakk> \<Longrightarrow> is_cons(M,a,b,z) \<longleftrightarrow> z = cons(a,b)"
 by (simp add: is_cons_def, blast intro: transM)
 
 lemma (in M_trivial) successor_abs [simp]:
      "\<lbrakk>M(a); M(z)\<rbrakk> \<Longrightarrow> successor(M,a,z) \<longleftrightarrow> z = succ(a)"
 by (simp add: successor_def, blast)
 
 lemma (in M_trans) succ_in_MD [dest!]:
      "M(succ(a)) \<Longrightarrow> M(a)"
   unfolding succ_def
   by (blast intro: transM)
 
 lemma (in M_trivial) succ_in_MI [intro!]:
      "M(a) \<Longrightarrow> M(succ(a))"
   unfolding succ_def
   by (blast intro: transM)
 
 lemma (in M_trivial) succ_in_M_iff [simp]:
      "M(succ(a)) \<longleftrightarrow> M(a)"
   by blast
 
 subsubsection\<open>Absoluteness for Separation and Replacement\<close>
 
 lemma (in M_trans) separation_closed [intro,simp]:
      "\<lbrakk>separation(M,P); M(A)\<rbrakk> \<Longrightarrow> M(Collect(A,P))"
 apply (insert separation, simp add: separation_def)
 apply (drule rspec, assumption, clarify)
 apply (subgoal_tac "y = Collect(A,P)", blast)
 apply (blast dest: transM)
 done
 
 lemma separation_iff:
      "separation(M,P) \<longleftrightarrow> (\<forall>z[M]. \<exists>y[M]. is_Collect(M,z,P,y))"
 by (simp add: separation_def is_Collect_def)
 
 lemma (in M_trans) Collect_abs [simp]:
      "\<lbrakk>M(A); M(z)\<rbrakk> \<Longrightarrow> is_Collect(M,A,P,z) \<longleftrightarrow> z = Collect(A,P)"
   unfolding is_Collect_def
   by (blast dest: transM)
 
 subsubsection\<open>The Operator \<^term>\<open>is_Replace\<close>\<close>
 
 
 lemma is_Replace_cong [cong]:
      "\<lbrakk>A=A';
          \<And>x y. \<lbrakk>M(x); M(y)\<rbrakk> \<Longrightarrow> P(x,y) \<longleftrightarrow> P'(x,y);
          z=z'\<rbrakk>
       \<Longrightarrow> is_Replace(M, A, \<lambda>x y. P(x,y), z) \<longleftrightarrow>
           is_Replace(M, A', \<lambda>x y. P'(x,y), z')"
 by (simp add: is_Replace_def)
 
 lemma (in M_trans) univalent_Replace_iff:
      "\<lbrakk>M(A); univalent(M,A,P);
          \<And>x y. \<lbrakk>x\<in>A; P(x,y)\<rbrakk> \<Longrightarrow> M(y)\<rbrakk>
       \<Longrightarrow> u \<in> Replace(A,P) \<longleftrightarrow> (\<exists>x. x\<in>A \<and> P(x,u))"
   unfolding Replace_iff univalent_def
   by (blast dest: transM)
 
 (*The last premise expresses that P takes M to M*)
 lemma (in M_trans) strong_replacement_closed [intro,simp]:
      "\<lbrakk>strong_replacement(M,P); M(A); univalent(M,A,P);
          \<And>x y. \<lbrakk>x\<in>A; P(x,y)\<rbrakk> \<Longrightarrow> M(y)\<rbrakk> \<Longrightarrow> M(Replace(A,P))"
 apply (simp add: strong_replacement_def)
 apply (drule_tac x=A in rspec, safe)
 apply (subgoal_tac "Replace(A,P) = Y")
  apply simp
 apply (rule equality_iffI)
 apply (simp add: univalent_Replace_iff)
 apply (blast dest: transM)
 done
 
 lemma (in M_trans) Replace_abs:
      "\<lbrakk>M(A); M(z); univalent(M,A,P);
          \<And>x y. \<lbrakk>x\<in>A; P(x,y)\<rbrakk> \<Longrightarrow> M(y)\<rbrakk>
       \<Longrightarrow> is_Replace(M,A,P,z) \<longleftrightarrow> z = Replace(A,P)"
 apply (simp add: is_Replace_def)
 apply (rule iffI)
  apply (rule equality_iffI)
  apply (simp_all add: univalent_Replace_iff)
  apply (blast dest: transM)+
 done
 
 
 (*The first premise can't simply be assumed as a schema.
   It is essential to take care when asserting instances of Replacement.
   Let K be a nonconstructible subset of nat and define
   f(x) = x if x \<in> K and f(x)=0 otherwise.  Then RepFun(nat,f) = cons(0,K), a
   nonconstructible set.  So we cannot assume that M(X) implies M(RepFun(X,f))
   even for f \<in> M -> M.
 *)
 lemma (in M_trans) RepFun_closed:
      "\<lbrakk>strong_replacement(M, \<lambda>x y. y = f(x)); M(A); \<forall>x\<in>A. M(f(x))\<rbrakk>
       \<Longrightarrow> M(RepFun(A,f))"
 apply (simp add: RepFun_def)
 done
 
 lemma Replace_conj_eq: "{y . x \<in> A, x\<in>A \<and> y=f(x)} = {y . x\<in>A, y=f(x)}"
 by simp
 
 text\<open>Better than \<open>RepFun_closed\<close> when having the formula \<^term>\<open>x\<in>A\<close>
       makes relativization easier.\<close>
 lemma (in M_trans) RepFun_closed2:
      "\<lbrakk>strong_replacement(M, \<lambda>x y. x\<in>A \<and> y = f(x)); M(A); \<forall>x\<in>A. M(f(x))\<rbrakk>
       \<Longrightarrow> M(RepFun(A, \<lambda>x. f(x)))"
 apply (simp add: RepFun_def)
 apply (frule strong_replacement_closed, assumption)
 apply (auto dest: transM  simp add: Replace_conj_eq univalent_def)
 done
 
 subsubsection \<open>Absoluteness for \<^term>\<open>Lambda\<close>\<close>
 
 definition
  is_lambda :: "[i\<Rightarrow>o, i, [i,i]\<Rightarrow>o, i] \<Rightarrow> o" where
     "is_lambda(M, A, is_b, z) \<equiv>
        \<forall>p[M]. p \<in> z \<longleftrightarrow>
         (\<exists>u[M]. \<exists>v[M]. u\<in>A \<and> pair(M,u,v,p) \<and> is_b(u,v))"
 
 lemma (in M_trivial) lam_closed:
      "\<lbrakk>strong_replacement(M, \<lambda>x y. y = <x,b(x)>); M(A); \<forall>x\<in>A. M(b(x))\<rbrakk>
       \<Longrightarrow> M(\<lambda>x\<in>A. b(x))"
 by (simp add: lam_def, blast intro: RepFun_closed dest: transM)
 
 text\<open>Better than \<open>lam_closed\<close>: has the formula \<^term>\<open>x\<in>A\<close>\<close>
 lemma (in M_trivial) lam_closed2:
   "\<lbrakk>strong_replacement(M, \<lambda>x y. x\<in>A \<and> y = \<langle>x, b(x)\<rangle>);
      M(A); \<forall>m[M]. m\<in>A \<longrightarrow> M(b(m))\<rbrakk> \<Longrightarrow> M(Lambda(A,b))"
 apply (simp add: lam_def)
 apply (blast intro: RepFun_closed2 dest: transM)
 done
 
 lemma (in M_trivial) lambda_abs2:
      "\<lbrakk>Relation1(M,A,is_b,b); M(A); \<forall>m[M]. m\<in>A \<longrightarrow> M(b(m)); M(z)\<rbrakk>
       \<Longrightarrow> is_lambda(M,A,is_b,z) \<longleftrightarrow> z = Lambda(A,b)"
 apply (simp add: Relation1_def is_lambda_def)
 apply (rule iffI)
  prefer 2 apply (simp add: lam_def)
 apply (rule equality_iffI)
 apply (simp add: lam_def)
 apply (rule iffI)
  apply (blast dest: transM)
 apply (auto simp add: transM [of _ A])
 done
 
 lemma is_lambda_cong [cong]:
      "\<lbrakk>A=A';  z=z';
          \<And>x y. \<lbrakk>x\<in>A; M(x); M(y)\<rbrakk> \<Longrightarrow> is_b(x,y) \<longleftrightarrow> is_b'(x,y)\<rbrakk>
       \<Longrightarrow> is_lambda(M, A, \<lambda>x y. is_b(x,y), z) \<longleftrightarrow>
           is_lambda(M, A', \<lambda>x y. is_b'(x,y), z')"
 by (simp add: is_lambda_def)
 
 lemma (in M_trans) image_abs [simp]:
      "\<lbrakk>M(r); M(A); M(z)\<rbrakk> \<Longrightarrow> image(M,r,A,z) \<longleftrightarrow> z = r``A"
 apply (simp add: image_def)
 apply (rule iffI)
  apply (blast intro!: equalityI dest: transM, blast)
 done
 
 subsubsection\<open>Relativization of Powerset\<close>
 
 text\<open>What about \<open>Pow_abs\<close>?  Powerset is NOT absolute!
       This result is one direction of absoluteness.\<close>
 
 lemma (in M_trans) powerset_Pow:
      "powerset(M, x, Pow(x))"
 by (simp add: powerset_def)
 
 text\<open>But we can't prove that the powerset in \<open>M\<close> includes the
       real powerset.\<close>
 
 lemma (in M_trans) powerset_imp_subset_Pow:
      "\<lbrakk>powerset(M,x,y); M(y)\<rbrakk> \<Longrightarrow> y \<subseteq> Pow(x)"
 apply (simp add: powerset_def)
 apply (blast dest: transM)
 done
 
 lemma (in M_trans) powerset_abs:
   assumes
      "M(y)"
   shows
     "powerset(M,x,y) \<longleftrightarrow> y = {a\<in>Pow(x) . M(a)}"
 proof (intro iffI equalityI)
   (* First show the converse implication by double inclusion *)
   assume "powerset(M,x,y)"
   with \<open>M(y)\<close>  
   show "y \<subseteq> {a\<in>Pow(x) . M(a)}"
     using powerset_imp_subset_Pow transM by blast
   from \<open>powerset(M,x,y)\<close>
   show "{a\<in>Pow(x) . M(a)} \<subseteq> y"
     using transM unfolding powerset_def by auto
 next (* we show the direct implication *)
   assume
     "y = {a \<in> Pow(x) . M(a)}"
   then
   show "powerset(M, x, y)"
     unfolding powerset_def subset_def using transM by blast
 qed
 
 subsubsection\<open>Absoluteness for the Natural Numbers\<close>
 
 lemma (in M_trivial) nat_into_M [intro]:
      "n \<in> nat \<Longrightarrow> M(n)"
 by (induct n rule: nat_induct, simp_all)
 
 lemma (in M_trans) nat_case_closed [intro,simp]:
   "\<lbrakk>M(k); M(a); \<forall>m[M]. M(b(m))\<rbrakk> \<Longrightarrow> M(nat_case(a,b,k))"
 apply (case_tac "k=0", simp)
 apply (case_tac "\<exists>m. k = succ(m)", force)
 apply (simp add: nat_case_def)
 done
 
 lemma (in M_trivial) quasinat_abs [simp]:
      "M(z) \<Longrightarrow> is_quasinat(M,z) \<longleftrightarrow> quasinat(z)"
 by (auto simp add: is_quasinat_def quasinat_def)
 
 lemma (in M_trivial) nat_case_abs [simp]:
      "\<lbrakk>relation1(M,is_b,b); M(k); M(z)\<rbrakk>
       \<Longrightarrow> is_nat_case(M,a,is_b,k,z) \<longleftrightarrow> z = nat_case(a,b,k)"
 apply (case_tac "quasinat(k)")
  prefer 2
  apply (simp add: is_nat_case_def non_nat_case)
  apply (force simp add: quasinat_def)
 apply (simp add: quasinat_def is_nat_case_def)
 apply (elim disjE exE)
  apply (simp_all add: relation1_def)
 done
 
 (*NOT for the simplifier.  The assumption M(z') is apparently necessary, but
   causes the error "Failed congruence proof!"  It may be better to replace
   is_nat_case by nat_case before attempting congruence reasoning.*)
 lemma is_nat_case_cong:
      "\<lbrakk>a = a'; k = k';  z = z';  M(z');
        \<And>x y. \<lbrakk>M(x); M(y)\<rbrakk> \<Longrightarrow> is_b(x,y) \<longleftrightarrow> is_b'(x,y)\<rbrakk>
       \<Longrightarrow> is_nat_case(M, a, is_b, k, z) \<longleftrightarrow> is_nat_case(M, a', is_b', k', z')"
 by (simp add: is_nat_case_def)
 
 
 subsection\<open>Absoluteness for Ordinals\<close>
 text\<open>These results constitute Theorem IV 5.1 of Kunen (page 126).\<close>
 
 lemma (in M_trans) lt_closed:
      "\<lbrakk>j<i; M(i)\<rbrakk> \<Longrightarrow> M(j)"
 by (blast dest: ltD intro: transM)
 
 lemma (in M_trans) transitive_set_abs [simp]:
      "M(a) \<Longrightarrow> transitive_set(M,a) \<longleftrightarrow> Transset(a)"
 by (simp add: transitive_set_def Transset_def)
 
 lemma (in M_trans) ordinal_abs [simp]:
      "M(a) \<Longrightarrow> ordinal(M,a) \<longleftrightarrow> Ord(a)"
 by (simp add: ordinal_def Ord_def)
 
 lemma (in M_trivial) limit_ordinal_abs [simp]:
      "M(a) \<Longrightarrow> limit_ordinal(M,a) \<longleftrightarrow> Limit(a)"
-apply (unfold Limit_def limit_ordinal_def)
+  unfolding Limit_def limit_ordinal_def
 apply (simp add: Ord_0_lt_iff)
 apply (simp add: lt_def, blast)
 done
 
 lemma (in M_trivial) successor_ordinal_abs [simp]:
      "M(a) \<Longrightarrow> successor_ordinal(M,a) \<longleftrightarrow> Ord(a) \<and> (\<exists>b[M]. a = succ(b))"
 apply (simp add: successor_ordinal_def, safe)
 apply (drule Ord_cases_disj, auto)
 done
 
 lemma finite_Ord_is_nat:
       "\<lbrakk>Ord(a); \<not> Limit(a); \<forall>x\<in>a. \<not> Limit(x)\<rbrakk> \<Longrightarrow> a \<in> nat"
 by (induct a rule: trans_induct3, simp_all)
 
 lemma (in M_trivial) finite_ordinal_abs [simp]:
      "M(a) \<Longrightarrow> finite_ordinal(M,a) \<longleftrightarrow> a \<in> nat"
 apply (simp add: finite_ordinal_def)
 apply (blast intro: finite_Ord_is_nat intro: nat_into_Ord
              dest: Ord_trans naturals_not_limit)
 done
 
 lemma Limit_non_Limit_implies_nat:
      "\<lbrakk>Limit(a); \<forall>x\<in>a. \<not> Limit(x)\<rbrakk> \<Longrightarrow> a = nat"
 apply (rule le_anti_sym)
 apply (rule all_lt_imp_le, blast, blast intro: Limit_is_Ord)
  apply (simp add: lt_def)
  apply (blast intro: Ord_in_Ord Ord_trans finite_Ord_is_nat)
 apply (erule nat_le_Limit)
 done
 
 lemma (in M_trivial) omega_abs [simp]:
      "M(a) \<Longrightarrow> omega(M,a) \<longleftrightarrow> a = nat"
 apply (simp add: omega_def)
 apply (blast intro: Limit_non_Limit_implies_nat dest: naturals_not_limit)
 done
 
 lemma (in M_trivial) number1_abs [simp]:
      "M(a) \<Longrightarrow> number1(M,a) \<longleftrightarrow> a = 1"
 by (simp add: number1_def)
 
 lemma (in M_trivial) number2_abs [simp]:
      "M(a) \<Longrightarrow> number2(M,a) \<longleftrightarrow> a = succ(1)"
 by (simp add: number2_def)
 
 lemma (in M_trivial) number3_abs [simp]:
      "M(a) \<Longrightarrow> number3(M,a) \<longleftrightarrow> a = succ(succ(1))"
 by (simp add: number3_def)
 
 text\<open>Kunen continued to 20...\<close>
 
 (*Could not get this to work.  The \<lambda>x\<in>nat is essential because everything
   but the recursion variable must stay unchanged.  But then the recursion
   equations only hold for x\<in>nat (or in some other set) and not for the
   whole of the class M.
   consts
     natnumber_aux :: "[i\<Rightarrow>o,i] \<Rightarrow> i"
 
   primrec
       "natnumber_aux(M,0) = (\<lambda>x\<in>nat. if empty(M,x) then 1 else 0)"
       "natnumber_aux(M,succ(n)) =
            (\<lambda>x\<in>nat. if (\<exists>y[M]. natnumber_aux(M,n)`y=1 \<and> successor(M,y,x))
                      then 1 else 0)"
 
   definition
     natnumber :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o"
       "natnumber(M,n,x) \<equiv> natnumber_aux(M,n)`x = 1"
 
   lemma (in M_trivial) [simp]:
        "natnumber(M,0,x) \<equiv> x=0"
 *)
 
 subsection\<open>Some instances of separation and strong replacement\<close>
 
 locale M_basic = M_trivial +
 assumes Inter_separation:
      "M(A) \<Longrightarrow> separation(M, \<lambda>x. \<forall>y[M]. y\<in>A \<longrightarrow> x\<in>y)"
   and Diff_separation:
      "M(B) \<Longrightarrow> separation(M, \<lambda>x. x \<notin> B)"
   and cartprod_separation:
      "\<lbrakk>M(A); M(B)\<rbrakk>
       \<Longrightarrow> separation(M, \<lambda>z. \<exists>x[M]. x\<in>A \<and> (\<exists>y[M]. y\<in>B \<and> pair(M,x,y,z)))"
   and image_separation:
      "\<lbrakk>M(A); M(r)\<rbrakk>
       \<Longrightarrow> separation(M, \<lambda>y. \<exists>p[M]. p\<in>r \<and> (\<exists>x[M]. x\<in>A \<and> pair(M,x,y,p)))"
   and converse_separation:
      "M(r) \<Longrightarrow> separation(M,
          \<lambda>z. \<exists>p[M]. p\<in>r \<and> (\<exists>x[M]. \<exists>y[M]. pair(M,x,y,p) \<and> pair(M,y,x,z)))"
   and restrict_separation:
      "M(A) \<Longrightarrow> separation(M, \<lambda>z. \<exists>x[M]. x\<in>A \<and> (\<exists>y[M]. pair(M,x,y,z)))"
   and comp_separation:
      "\<lbrakk>M(r); M(s)\<rbrakk>
       \<Longrightarrow> separation(M, \<lambda>xz. \<exists>x[M]. \<exists>y[M]. \<exists>z[M]. \<exists>xy[M]. \<exists>yz[M].
                   pair(M,x,z,xz) \<and> pair(M,x,y,xy) \<and> pair(M,y,z,yz) \<and>
                   xy\<in>s \<and> yz\<in>r)"
   and pred_separation:
      "\<lbrakk>M(r); M(x)\<rbrakk> \<Longrightarrow> separation(M, \<lambda>y. \<exists>p[M]. p\<in>r \<and> pair(M,y,x,p))"
   and Memrel_separation:
      "separation(M, \<lambda>z. \<exists>x[M]. \<exists>y[M]. pair(M,x,y,z) \<and> x \<in> y)"
   and funspace_succ_replacement:
      "M(n) \<Longrightarrow>
       strong_replacement(M, \<lambda>p z. \<exists>f[M]. \<exists>b[M]. \<exists>nb[M]. \<exists>cnbf[M].
                 pair(M,f,b,p) \<and> pair(M,n,b,nb) \<and> is_cons(M,nb,f,cnbf) \<and>
                 upair(M,cnbf,cnbf,z))"
   and is_recfun_separation:
      \<comment> \<open>for well-founded recursion: used to prove \<open>is_recfun_equal\<close>\<close>
      "\<lbrakk>M(r); M(f); M(g); M(a); M(b)\<rbrakk>
      \<Longrightarrow> separation(M,
             \<lambda>x. \<exists>xa[M]. \<exists>xb[M].
                 pair(M,x,a,xa) \<and> xa \<in> r \<and> pair(M,x,b,xb) \<and> xb \<in> r \<and>
                 (\<exists>fx[M]. \<exists>gx[M]. fun_apply(M,f,x,fx) \<and> fun_apply(M,g,x,gx) \<and>
                                    fx \<noteq> gx))"
      and power_ax:         "power_ax(M)"
 
 lemma (in M_trivial) cartprod_iff_lemma:
      "\<lbrakk>M(C);  \<forall>u[M]. u \<in> C \<longleftrightarrow> (\<exists>x\<in>A. \<exists>y\<in>B. u = {{x}, {x,y}});
          powerset(M, A \<union> B, p1); powerset(M, p1, p2);  M(p2)\<rbrakk>
        \<Longrightarrow> C = {u \<in> p2 . \<exists>x\<in>A. \<exists>y\<in>B. u = {{x}, {x,y}}}"
 apply (simp add: powerset_def)
 apply (rule equalityI, clarify, simp)
  apply (frule transM, assumption)
  apply (frule transM, assumption, simp (no_asm_simp))
  apply blast
 apply clarify
 apply (frule transM, assumption, force)
 done
 
 lemma (in M_basic) cartprod_iff:
      "\<lbrakk>M(A); M(B); M(C)\<rbrakk>
       \<Longrightarrow> cartprod(M,A,B,C) \<longleftrightarrow>
           (\<exists>p1[M]. \<exists>p2[M]. powerset(M,A \<union> B,p1) \<and> powerset(M,p1,p2) \<and>
                    C = {z \<in> p2. \<exists>x\<in>A. \<exists>y\<in>B. z = \<langle>x,y\<rangle>})"
 apply (simp add: Pair_def cartprod_def, safe)
 defer 1
   apply (simp add: powerset_def)
  apply blast
 txt\<open>Final, difficult case: the left-to-right direction of the theorem.\<close>
 apply (insert power_ax, simp add: power_ax_def)
 apply (frule_tac x="A \<union> B" and P="\<lambda>x. rex(M,Q(x))" for Q in rspec)
 apply (blast, clarify)
 apply (drule_tac x=z and P="\<lambda>x. rex(M,Q(x))" for Q in rspec)
 apply assumption
 apply (blast intro: cartprod_iff_lemma)
 done
 
 lemma (in M_basic) cartprod_closed_lemma:
      "\<lbrakk>M(A); M(B)\<rbrakk> \<Longrightarrow> \<exists>C[M]. cartprod(M,A,B,C)"
 apply (simp del: cartprod_abs add: cartprod_iff)
 apply (insert power_ax, simp add: power_ax_def)
 apply (frule_tac x="A \<union> B" and P="\<lambda>x. rex(M,Q(x))" for Q in rspec)
 apply (blast, clarify)
 apply (drule_tac x=z and P="\<lambda>x. rex(M,Q(x))" for Q in rspec, auto)
 apply (intro rexI conjI, simp+)
 apply (insert cartprod_separation [of A B], simp)
 done
 
 text\<open>All the lemmas above are necessary because Powerset is not absolute.
       I should have used Replacement instead!\<close>
 lemma (in M_basic) cartprod_closed [intro,simp]:
      "\<lbrakk>M(A); M(B)\<rbrakk> \<Longrightarrow> M(A*B)"
 by (frule cartprod_closed_lemma, assumption, force)
 
 lemma (in M_basic) sum_closed [intro,simp]:
      "\<lbrakk>M(A); M(B)\<rbrakk> \<Longrightarrow> M(A+B)"
 by (simp add: sum_def)
 
 lemma (in M_basic) sum_abs [simp]:
      "\<lbrakk>M(A); M(B); M(Z)\<rbrakk> \<Longrightarrow> is_sum(M,A,B,Z) \<longleftrightarrow> (Z = A+B)"
 by (simp add: is_sum_def sum_def singleton_0 nat_into_M)
 
 lemma (in M_trivial) Inl_in_M_iff [iff]:
      "M(Inl(a)) \<longleftrightarrow> M(a)"
 by (simp add: Inl_def)
 
 lemma (in M_trivial) Inl_abs [simp]:
      "M(Z) \<Longrightarrow> is_Inl(M,a,Z) \<longleftrightarrow> (Z = Inl(a))"
 by (simp add: is_Inl_def Inl_def)
 
 lemma (in M_trivial) Inr_in_M_iff [iff]:
      "M(Inr(a)) \<longleftrightarrow> M(a)"
 by (simp add: Inr_def)
 
 lemma (in M_trivial) Inr_abs [simp]:
      "M(Z) \<Longrightarrow> is_Inr(M,a,Z) \<longleftrightarrow> (Z = Inr(a))"
 by (simp add: is_Inr_def Inr_def)
 
 
 subsubsection \<open>converse of a relation\<close>
 
 lemma (in M_basic) M_converse_iff:
      "M(r) \<Longrightarrow>
       converse(r) =
       {z \<in> \<Union>(\<Union>(r)) * \<Union>(\<Union>(r)).
        \<exists>p\<in>r. \<exists>x[M]. \<exists>y[M]. p = \<langle>x,y\<rangle> \<and> z = \<langle>y,x\<rangle>}"
 apply (rule equalityI)
  prefer 2 apply (blast dest: transM, clarify, simp)
 apply (simp add: Pair_def)
 apply (blast dest: transM)
 done
 
 lemma (in M_basic) converse_closed [intro,simp]:
      "M(r) \<Longrightarrow> M(converse(r))"
 apply (simp add: M_converse_iff)
 apply (insert converse_separation [of r], simp)
 done
 
 lemma (in M_basic) converse_abs [simp]:
      "\<lbrakk>M(r); M(z)\<rbrakk> \<Longrightarrow> is_converse(M,r,z) \<longleftrightarrow> z = converse(r)"
 apply (simp add: is_converse_def)
 apply (rule iffI)
  prefer 2 apply blast
 apply (rule M_equalityI)
   apply simp
   apply (blast dest: transM)+
 done
 
 
 subsubsection \<open>image, preimage, domain, range\<close>
 
 lemma (in M_basic) image_closed [intro,simp]:
      "\<lbrakk>M(A); M(r)\<rbrakk> \<Longrightarrow> M(r``A)"
 apply (simp add: image_iff_Collect)
 apply (insert image_separation [of A r], simp)
 done
 
 lemma (in M_basic) vimage_abs [simp]:
      "\<lbrakk>M(r); M(A); M(z)\<rbrakk> \<Longrightarrow> pre_image(M,r,A,z) \<longleftrightarrow> z = r-``A"
 apply (simp add: pre_image_def)
 apply (rule iffI)
  apply (blast intro!: equalityI dest: transM, blast)
 done
 
 lemma (in M_basic) vimage_closed [intro,simp]:
      "\<lbrakk>M(A); M(r)\<rbrakk> \<Longrightarrow> M(r-``A)"
 by (simp add: vimage_def)
 
 
 subsubsection\<open>Domain, range and field\<close>
 
 lemma (in M_trans) domain_abs [simp]:
      "\<lbrakk>M(r); M(z)\<rbrakk> \<Longrightarrow> is_domain(M,r,z) \<longleftrightarrow> z = domain(r)"
 apply (simp add: is_domain_def)
 apply (blast intro!: equalityI dest: transM)
 done
 
 lemma (in M_basic) domain_closed [intro,simp]:
      "M(r) \<Longrightarrow> M(domain(r))"
 apply (simp add: domain_eq_vimage)
 done
 
 lemma (in M_trans) range_abs [simp]:
      "\<lbrakk>M(r); M(z)\<rbrakk> \<Longrightarrow> is_range(M,r,z) \<longleftrightarrow> z = range(r)"
 apply (simp add: is_range_def)
 apply (blast intro!: equalityI dest: transM)
 done
 
 lemma (in M_basic) range_closed [intro,simp]:
      "M(r) \<Longrightarrow> M(range(r))"
 apply (simp add: range_eq_image)
 done
 
 lemma (in M_basic) field_abs [simp]:
      "\<lbrakk>M(r); M(z)\<rbrakk> \<Longrightarrow> is_field(M,r,z) \<longleftrightarrow> z = field(r)"
 by (simp add: is_field_def field_def)
 
 lemma (in M_basic) field_closed [intro,simp]:
      "M(r) \<Longrightarrow> M(field(r))"
 by (simp add: field_def)
 
 
 subsubsection\<open>Relations, functions and application\<close>
 
 lemma (in M_trans) relation_abs [simp]:
      "M(r) \<Longrightarrow> is_relation(M,r) \<longleftrightarrow> relation(r)"
 apply (simp add: is_relation_def relation_def)
 apply (blast dest!: bspec dest: pair_components_in_M)+
 done
 
 lemma (in M_trivial) function_abs [simp]:
      "M(r) \<Longrightarrow> is_function(M,r) \<longleftrightarrow> function(r)"
 apply (simp add: is_function_def function_def, safe)
    apply (frule transM, assumption)
   apply (blast dest: pair_components_in_M)+
 done
 
 lemma (in M_basic) apply_closed [intro,simp]:
      "\<lbrakk>M(f); M(a)\<rbrakk> \<Longrightarrow> M(f`a)"
 by (simp add: apply_def)
 
 lemma (in M_basic) apply_abs [simp]:
      "\<lbrakk>M(f); M(x); M(y)\<rbrakk> \<Longrightarrow> fun_apply(M,f,x,y) \<longleftrightarrow> f`x = y"
 apply (simp add: fun_apply_def apply_def, blast)
 done
 
 lemma (in M_trivial) typed_function_abs [simp]:
      "\<lbrakk>M(A); M(f)\<rbrakk> \<Longrightarrow> typed_function(M,A,B,f) \<longleftrightarrow> f \<in> A -> B"
 apply (auto simp add: typed_function_def relation_def Pi_iff)
 apply (blast dest: pair_components_in_M)+
 done
 
 lemma (in M_basic) injection_abs [simp]:
      "\<lbrakk>M(A); M(f)\<rbrakk> \<Longrightarrow> injection(M,A,B,f) \<longleftrightarrow> f \<in> inj(A,B)"
 apply (simp add: injection_def apply_iff inj_def)
 apply (blast dest: transM [of _ A])
 done
 
 lemma (in M_basic) surjection_abs [simp]:
      "\<lbrakk>M(A); M(B); M(f)\<rbrakk> \<Longrightarrow> surjection(M,A,B,f) \<longleftrightarrow> f \<in> surj(A,B)"
 by (simp add: surjection_def surj_def)
 
 lemma (in M_basic) bijection_abs [simp]:
      "\<lbrakk>M(A); M(B); M(f)\<rbrakk> \<Longrightarrow> bijection(M,A,B,f) \<longleftrightarrow> f \<in> bij(A,B)"
 by (simp add: bijection_def bij_def)
 
 
 subsubsection\<open>Composition of relations\<close>
 
 lemma (in M_basic) M_comp_iff:
      "\<lbrakk>M(r); M(s)\<rbrakk>
       \<Longrightarrow> r O s =
           {xz \<in> domain(s) * range(r).
             \<exists>x[M]. \<exists>y[M]. \<exists>z[M]. xz = \<langle>x,z\<rangle> \<and> \<langle>x,y\<rangle> \<in> s \<and> \<langle>y,z\<rangle> \<in> r}"
 apply (simp add: comp_def)
 apply (rule equalityI)
  apply clarify
  apply simp
  apply  (blast dest:  transM)+
 done
 
 lemma (in M_basic) comp_closed [intro,simp]:
      "\<lbrakk>M(r); M(s)\<rbrakk> \<Longrightarrow> M(r O s)"
 apply (simp add: M_comp_iff)
 apply (insert comp_separation [of r s], simp)
 done
 
 lemma (in M_basic) composition_abs [simp]:
      "\<lbrakk>M(r); M(s); M(t)\<rbrakk> \<Longrightarrow> composition(M,r,s,t) \<longleftrightarrow> t = r O s"
 apply safe
  txt\<open>Proving \<^term>\<open>composition(M, r, s, r O s)\<close>\<close>
  prefer 2
  apply (simp add: composition_def comp_def)
  apply (blast dest: transM)
 txt\<open>Opposite implication\<close>
 apply (rule M_equalityI)
   apply (simp add: composition_def comp_def)
   apply (blast del: allE dest: transM)+
 done
 
 text\<open>no longer needed\<close>
 lemma (in M_basic) restriction_is_function:
      "\<lbrakk>restriction(M,f,A,z); function(f); M(f); M(A); M(z)\<rbrakk>
       \<Longrightarrow> function(z)"
 apply (simp add: restriction_def ball_iff_equiv)
 apply (unfold function_def, blast)
 done
 
 lemma (in M_trans) restriction_abs [simp]:
      "\<lbrakk>M(f); M(A); M(z)\<rbrakk>
       \<Longrightarrow> restriction(M,f,A,z) \<longleftrightarrow> z = restrict(f,A)"
 apply (simp add: ball_iff_equiv restriction_def restrict_def)
 apply (blast intro!: equalityI dest: transM)
 done
 
 
 lemma (in M_trans) M_restrict_iff:
      "M(r) \<Longrightarrow> restrict(r,A) = {z \<in> r . \<exists>x\<in>A. \<exists>y[M]. z = \<langle>x, y\<rangle>}"
 by (simp add: restrict_def, blast dest: transM)
 
 lemma (in M_basic) restrict_closed [intro,simp]:
      "\<lbrakk>M(A); M(r)\<rbrakk> \<Longrightarrow> M(restrict(r,A))"
 apply (simp add: M_restrict_iff)
 apply (insert restrict_separation [of A], simp)
 done
 
 lemma (in M_trans) Inter_abs [simp]:
      "\<lbrakk>M(A); M(z)\<rbrakk> \<Longrightarrow> big_inter(M,A,z) \<longleftrightarrow> z = \<Inter>(A)"
 apply (simp add: big_inter_def Inter_def)
 apply (blast intro!: equalityI dest: transM)
 done
 
 lemma (in M_basic) Inter_closed [intro,simp]:
      "M(A) \<Longrightarrow> M(\<Inter>(A))"
 by (insert Inter_separation, simp add: Inter_def)
 
 lemma (in M_basic) Int_closed [intro,simp]:
      "\<lbrakk>M(A); M(B)\<rbrakk> \<Longrightarrow> M(A \<inter> B)"
 apply (subgoal_tac "M({A,B})")
 apply (frule Inter_closed, force+)
 done
 
 lemma (in M_basic) Diff_closed [intro,simp]:
      "\<lbrakk>M(A); M(B)\<rbrakk> \<Longrightarrow> M(A-B)"
 by (insert Diff_separation, simp add: Diff_def)
 
 subsubsection\<open>Some Facts About Separation Axioms\<close>
 
 lemma (in M_basic) separation_conj:
      "\<lbrakk>separation(M,P); separation(M,Q)\<rbrakk> \<Longrightarrow> separation(M, \<lambda>z. P(z) \<and> Q(z))"
 by (simp del: separation_closed
          add: separation_iff Collect_Int_Collect_eq [symmetric])
 
 (*???equalities*)
 lemma Collect_Un_Collect_eq:
      "Collect(A,P) \<union> Collect(A,Q) = Collect(A, \<lambda>x. P(x) \<or> Q(x))"
 by blast
 
 lemma Diff_Collect_eq:
      "A - Collect(A,P) = Collect(A, \<lambda>x. \<not> P(x))"
 by blast
 
 lemma (in M_trans) Collect_rall_eq:
      "M(Y) \<Longrightarrow> Collect(A, \<lambda>x. \<forall>y[M]. y\<in>Y \<longrightarrow> P(x,y)) =
                (if Y=0 then A else (\<Inter>y \<in> Y. {x \<in> A. P(x,y)}))"
   by (simp,blast dest: transM)
 
 
 lemma (in M_basic) separation_disj:
      "\<lbrakk>separation(M,P); separation(M,Q)\<rbrakk> \<Longrightarrow> separation(M, \<lambda>z. P(z) \<or> Q(z))"
 by (simp del: separation_closed
          add: separation_iff Collect_Un_Collect_eq [symmetric])
 
 lemma (in M_basic) separation_neg:
      "separation(M,P) \<Longrightarrow> separation(M, \<lambda>z. \<not>P(z))"
 by (simp del: separation_closed
          add: separation_iff Diff_Collect_eq [symmetric])
 
 lemma (in M_basic) separation_imp:
      "\<lbrakk>separation(M,P); separation(M,Q)\<rbrakk>
       \<Longrightarrow> separation(M, \<lambda>z. P(z) \<longrightarrow> Q(z))"
 by (simp add: separation_neg separation_disj not_disj_iff_imp [symmetric])
 
 text\<open>This result is a hint of how little can be done without the Reflection
   Theorem.  The quantifier has to be bounded by a set.  We also need another
   instance of Separation!\<close>
 lemma (in M_basic) separation_rall:
      "\<lbrakk>M(Y); \<forall>y[M]. separation(M, \<lambda>x. P(x,y));
         \<forall>z[M]. strong_replacement(M, \<lambda>x y. y = {u \<in> z . P(u,x)})\<rbrakk>
       \<Longrightarrow> separation(M, \<lambda>x. \<forall>y[M]. y\<in>Y \<longrightarrow> P(x,y))"
 apply (simp del: separation_closed rall_abs
          add: separation_iff Collect_rall_eq)
 apply (blast intro!:  RepFun_closed dest: transM)
 done
 
 
 subsubsection\<open>Functions and function space\<close>
 
 text\<open>The assumption \<^term>\<open>M(A->B)\<close> is unusual, but essential: in
 all but trivial cases, A->B cannot be expected to belong to \<^term>\<open>M\<close>.\<close>
 lemma (in M_trivial) is_funspace_abs [simp]:
      "\<lbrakk>M(A); M(B); M(F); M(A->B)\<rbrakk> \<Longrightarrow> is_funspace(M,A,B,F) \<longleftrightarrow> F = A->B"
 apply (simp add: is_funspace_def)
 apply (rule iffI)
  prefer 2 apply blast
 apply (rule M_equalityI)
   apply simp_all
 done
 
 lemma (in M_basic) succ_fun_eq2:
      "\<lbrakk>M(B); M(n->B)\<rbrakk> \<Longrightarrow>
       succ(n) -> B =
       \<Union>{z. p \<in> (n->B)*B, \<exists>f[M]. \<exists>b[M]. p = \<langle>f,b\<rangle> \<and> z = {cons(\<langle>n,b\<rangle>, f)}}"
 apply (simp add: succ_fun_eq)
 apply (blast dest: transM)
 done
 
 lemma (in M_basic) funspace_succ:
      "\<lbrakk>M(n); M(B); M(n->B)\<rbrakk> \<Longrightarrow> M(succ(n) -> B)"
 apply (insert funspace_succ_replacement [of n], simp)
 apply (force simp add: succ_fun_eq2 univalent_def)
 done
 
 text\<open>\<^term>\<open>M\<close> contains all finite function spaces.  Needed to prove the
 absoluteness of transitive closure.  See the definition of
 \<open>rtrancl_alt\<close> in in \<open>WF_absolute.thy\<close>.\<close>
 lemma (in M_basic) finite_funspace_closed [intro,simp]:
      "\<lbrakk>n\<in>nat; M(B)\<rbrakk> \<Longrightarrow> M(n->B)"
 apply (induct_tac n, simp)
 apply (simp add: funspace_succ nat_into_M)
 done
 
 
 subsection\<open>Relativization and Absoluteness for Boolean Operators\<close>
 
 definition
   is_bool_of_o :: "[i\<Rightarrow>o, o, i] \<Rightarrow> o" where
    "is_bool_of_o(M,P,z) \<equiv> (P \<and> number1(M,z)) \<or> (\<not>P \<and> empty(M,z))"
 
 definition
   is_not :: "[i\<Rightarrow>o, i, i] \<Rightarrow> o" where
    "is_not(M,a,z) \<equiv> (number1(M,a)  \<and> empty(M,z)) |
                      (\<not>number1(M,a) \<and> number1(M,z))"
 
 definition
   is_and :: "[i\<Rightarrow>o, i, i, i] \<Rightarrow> o" where
    "is_and(M,a,b,z) \<equiv> (number1(M,a)  \<and> z=b) |
                        (\<not>number1(M,a) \<and> empty(M,z))"
 
 definition
   is_or :: "[i\<Rightarrow>o, i, i, i] \<Rightarrow> o" where
    "is_or(M,a,b,z) \<equiv> (number1(M,a)  \<and> number1(M,z)) |
                       (\<not>number1(M,a) \<and> z=b)"
 
 lemma (in M_trivial) bool_of_o_abs [simp]:
      "M(z) \<Longrightarrow> is_bool_of_o(M,P,z) \<longleftrightarrow> z = bool_of_o(P)"
 by (simp add: is_bool_of_o_def bool_of_o_def)
 
 
 lemma (in M_trivial) not_abs [simp]:
      "\<lbrakk>M(a); M(z)\<rbrakk> \<Longrightarrow> is_not(M,a,z) \<longleftrightarrow> z = not(a)"
 by (simp add: Bool.not_def cond_def is_not_def)
 
 lemma (in M_trivial) and_abs [simp]:
      "\<lbrakk>M(a); M(b); M(z)\<rbrakk> \<Longrightarrow> is_and(M,a,b,z) \<longleftrightarrow> z = a and b"
 by (simp add: Bool.and_def cond_def is_and_def)
 
 lemma (in M_trivial) or_abs [simp]:
      "\<lbrakk>M(a); M(b); M(z)\<rbrakk> \<Longrightarrow> is_or(M,a,b,z) \<longleftrightarrow> z = a or b"
 by (simp add: Bool.or_def cond_def is_or_def)
 
 
 lemma (in M_trivial) bool_of_o_closed [intro,simp]:
      "M(bool_of_o(P))"
 by (simp add: bool_of_o_def)
 
 lemma (in M_trivial) and_closed [intro,simp]:
      "\<lbrakk>M(p); M(q)\<rbrakk> \<Longrightarrow> M(p and q)"
 by (simp add: and_def cond_def)
 
 lemma (in M_trivial) or_closed [intro,simp]:
      "\<lbrakk>M(p); M(q)\<rbrakk> \<Longrightarrow> M(p or q)"
 by (simp add: or_def cond_def)
 
 lemma (in M_trivial) not_closed [intro,simp]:
      "M(p) \<Longrightarrow> M(not(p))"
 by (simp add: Bool.not_def cond_def)
 
 
 subsection\<open>Relativization and Absoluteness for List Operators\<close>
 
 definition
   is_Nil :: "[i\<Rightarrow>o, i] \<Rightarrow> o" where
      \<comment> \<open>because \<^prop>\<open>[] \<equiv> Inl(0)\<close>\<close>
     "is_Nil(M,xs) \<equiv> \<exists>zero[M]. empty(M,zero) \<and> is_Inl(M,zero,xs)"
 
 definition
   is_Cons :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
      \<comment> \<open>because \<^prop>\<open>Cons(a, l) \<equiv> Inr(\<langle>a,l\<rangle>)\<close>\<close>
     "is_Cons(M,a,l,Z) \<equiv> \<exists>p[M]. pair(M,a,l,p) \<and> is_Inr(M,p,Z)"
 
 
 lemma (in M_trivial) Nil_in_M [intro,simp]: "M(Nil)"
 by (simp add: Nil_def)
 
 lemma (in M_trivial) Nil_abs [simp]: "M(Z) \<Longrightarrow> is_Nil(M,Z) \<longleftrightarrow> (Z = Nil)"
 by (simp add: is_Nil_def Nil_def)
 
 lemma (in M_trivial) Cons_in_M_iff [iff]: "M(Cons(a,l)) \<longleftrightarrow> M(a) \<and> M(l)"
 by (simp add: Cons_def)
 
 lemma (in M_trivial) Cons_abs [simp]:
      "\<lbrakk>M(a); M(l); M(Z)\<rbrakk> \<Longrightarrow> is_Cons(M,a,l,Z) \<longleftrightarrow> (Z = Cons(a,l))"
 by (simp add: is_Cons_def Cons_def)
 
 
 definition
   quasilist :: "i \<Rightarrow> o" where
     "quasilist(xs) \<equiv> xs=Nil \<or> (\<exists>x l. xs = Cons(x,l))"
 
 definition
   is_quasilist :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
     "is_quasilist(M,z) \<equiv> is_Nil(M,z) \<or> (\<exists>x[M]. \<exists>l[M]. is_Cons(M,x,l,z))"
 
 definition
   list_case' :: "[i, [i,i]\<Rightarrow>i, i] \<Rightarrow> i" where
     \<comment> \<open>A version of \<^term>\<open>list_case\<close> that's always defined.\<close>
     "list_case'(a,b,xs) \<equiv>
        if quasilist(xs) then list_case(a,b,xs) else 0"
 
 definition
   is_list_case :: "[i\<Rightarrow>o, i, [i,i,i]\<Rightarrow>o, i, i] \<Rightarrow> o" where
     \<comment> \<open>Returns 0 for non-lists\<close>
     "is_list_case(M, a, is_b, xs, z) \<equiv>
        (is_Nil(M,xs) \<longrightarrow> z=a) \<and>
        (\<forall>x[M]. \<forall>l[M]. is_Cons(M,x,l,xs) \<longrightarrow> is_b(x,l,z)) \<and>
        (is_quasilist(M,xs) \<or> empty(M,z))"
 
 definition
   hd' :: "i \<Rightarrow> i" where
     \<comment> \<open>A version of \<^term>\<open>hd\<close> that's always defined.\<close>
     "hd'(xs) \<equiv> if quasilist(xs) then hd(xs) else 0"
 
 definition
   tl' :: "i \<Rightarrow> i" where
     \<comment> \<open>A version of \<^term>\<open>tl\<close> that's always defined.\<close>
     "tl'(xs) \<equiv> if quasilist(xs) then tl(xs) else 0"
 
 definition
   is_hd :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
      \<comment> \<open>\<^term>\<open>hd([]) = 0\<close> no constraints if not a list.
           Avoiding implication prevents the simplifier's looping.\<close>
     "is_hd(M,xs,H) \<equiv>
        (is_Nil(M,xs) \<longrightarrow> empty(M,H)) \<and>
        (\<forall>x[M]. \<forall>l[M]. \<not> is_Cons(M,x,l,xs) \<or> H=x) \<and>
        (is_quasilist(M,xs) \<or> empty(M,H))"
 
 definition
   is_tl :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
      \<comment> \<open>\<^term>\<open>tl([]) = []\<close>; see comments about \<^term>\<open>is_hd\<close>\<close>
     "is_tl(M,xs,T) \<equiv>
        (is_Nil(M,xs) \<longrightarrow> T=xs) \<and>
        (\<forall>x[M]. \<forall>l[M]. \<not> is_Cons(M,x,l,xs) \<or> T=l) \<and>
        (is_quasilist(M,xs) \<or> empty(M,T))"
 
 subsubsection\<open>\<^term>\<open>quasilist\<close>: For Case-Splitting with \<^term>\<open>list_case'\<close>\<close>
 
 lemma [iff]: "quasilist(Nil)"
 by (simp add: quasilist_def)
 
 lemma [iff]: "quasilist(Cons(x,l))"
 by (simp add: quasilist_def)
 
 lemma list_imp_quasilist: "l \<in> list(A) \<Longrightarrow> quasilist(l)"
 by (erule list.cases, simp_all)
 
 subsubsection\<open>\<^term>\<open>list_case'\<close>, the Modified Version of \<^term>\<open>list_case\<close>\<close>
 
 lemma list_case'_Nil [simp]: "list_case'(a,b,Nil) = a"
 by (simp add: list_case'_def quasilist_def)
 
 lemma list_case'_Cons [simp]: "list_case'(a,b,Cons(x,l)) = b(x,l)"
 by (simp add: list_case'_def quasilist_def)
 
 lemma non_list_case: "\<not> quasilist(x) \<Longrightarrow> list_case'(a,b,x) = 0"
 by (simp add: quasilist_def list_case'_def)
 
 lemma list_case'_eq_list_case [simp]:
      "xs \<in> list(A) \<Longrightarrow>list_case'(a,b,xs) = list_case(a,b,xs)"
 by (erule list.cases, simp_all)
 
 lemma (in M_basic) list_case'_closed [intro,simp]:
   "\<lbrakk>M(k); M(a); \<forall>x[M]. \<forall>y[M]. M(b(x,y))\<rbrakk> \<Longrightarrow> M(list_case'(a,b,k))"
 apply (case_tac "quasilist(k)")
  apply (simp add: quasilist_def, force)
 apply (simp add: non_list_case)
 done
 
 lemma (in M_trivial) quasilist_abs [simp]:
      "M(z) \<Longrightarrow> is_quasilist(M,z) \<longleftrightarrow> quasilist(z)"
 by (auto simp add: is_quasilist_def quasilist_def)
 
 lemma (in M_trivial) list_case_abs [simp]:
      "\<lbrakk>relation2(M,is_b,b); M(k); M(z)\<rbrakk>
       \<Longrightarrow> is_list_case(M,a,is_b,k,z) \<longleftrightarrow> z = list_case'(a,b,k)"
 apply (case_tac "quasilist(k)")
  prefer 2
  apply (simp add: is_list_case_def non_list_case)
  apply (force simp add: quasilist_def)
 apply (simp add: quasilist_def is_list_case_def)
 apply (elim disjE exE)
  apply (simp_all add: relation2_def)
 done
 
 
 subsubsection\<open>The Modified Operators \<^term>\<open>hd'\<close> and \<^term>\<open>tl'\<close>\<close>
 
 lemma (in M_trivial) is_hd_Nil: "is_hd(M,[],Z) \<longleftrightarrow> empty(M,Z)"
 by (simp add: is_hd_def)
 
 lemma (in M_trivial) is_hd_Cons:
      "\<lbrakk>M(a); M(l)\<rbrakk> \<Longrightarrow> is_hd(M,Cons(a,l),Z) \<longleftrightarrow> Z = a"
 by (force simp add: is_hd_def)
 
 lemma (in M_trivial) hd_abs [simp]:
      "\<lbrakk>M(x); M(y)\<rbrakk> \<Longrightarrow> is_hd(M,x,y) \<longleftrightarrow> y = hd'(x)"
 apply (simp add: hd'_def)
 apply (intro impI conjI)
  prefer 2 apply (force simp add: is_hd_def)
 apply (simp add: quasilist_def is_hd_def)
 apply (elim disjE exE, auto)
 done
 
 lemma (in M_trivial) is_tl_Nil: "is_tl(M,[],Z) \<longleftrightarrow> Z = []"
 by (simp add: is_tl_def)
 
 lemma (in M_trivial) is_tl_Cons:
      "\<lbrakk>M(a); M(l)\<rbrakk> \<Longrightarrow> is_tl(M,Cons(a,l),Z) \<longleftrightarrow> Z = l"
 by (force simp add: is_tl_def)
 
 lemma (in M_trivial) tl_abs [simp]:
      "\<lbrakk>M(x); M(y)\<rbrakk> \<Longrightarrow> is_tl(M,x,y) \<longleftrightarrow> y = tl'(x)"
 apply (simp add: tl'_def)
 apply (intro impI conjI)
  prefer 2 apply (force simp add: is_tl_def)
 apply (simp add: quasilist_def is_tl_def)
 apply (elim disjE exE, auto)
 done
 
 lemma (in M_trivial) relation1_tl: "relation1(M, is_tl(M), tl')"
 by (simp add: relation1_def)
 
 lemma hd'_Nil: "hd'([]) = 0"
 by (simp add: hd'_def)
 
 lemma hd'_Cons: "hd'(Cons(a,l)) = a"
 by (simp add: hd'_def)
 
 lemma tl'_Nil: "tl'([]) = []"
 by (simp add: tl'_def)
 
 lemma tl'_Cons: "tl'(Cons(a,l)) = l"
 by (simp add: tl'_def)
 
 lemma iterates_tl_Nil: "n \<in> nat \<Longrightarrow> tl'^n ([]) = []"
 apply (induct_tac n)
 apply (simp_all add: tl'_Nil)
 done
 
 lemma (in M_basic) tl'_closed: "M(x) \<Longrightarrow> M(tl'(x))"
 apply (simp add: tl'_def)
 apply (force simp add: quasilist_def)
 done
 
 
 end
diff --git a/src/ZF/Constructible/Satisfies_absolute.thy b/src/ZF/Constructible/Satisfies_absolute.thy
--- a/src/ZF/Constructible/Satisfies_absolute.thy
+++ b/src/ZF/Constructible/Satisfies_absolute.thy
@@ -1,1039 +1,1039 @@
 (*  Title:      ZF/Constructible/Satisfies_absolute.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
 *)
 
 section \<open>Absoluteness for the Satisfies Relation on Formulas\<close>
 
 theory Satisfies_absolute imports Datatype_absolute Rec_Separation begin 
 
 
 subsection \<open>More Internalization\<close>
 
 subsubsection\<open>The Formula \<^term>\<open>is_depth\<close>, Internalized\<close>
 
 (*    "is_depth(M,p,n) \<equiv> 
        \<exists>sn[M]. \<exists>formula_n[M]. \<exists>formula_sn[M]. 
          2          1                0
         is_formula_N(M,n,formula_n) \<and> p \<notin> formula_n \<and>
         successor(M,n,sn) \<and> is_formula_N(M,sn,formula_sn) \<and> p \<in> formula_sn" *)
 definition
   depth_fm :: "[i,i]\<Rightarrow>i" where
   "depth_fm(p,n) \<equiv> 
      Exists(Exists(Exists(
        And(formula_N_fm(n#+3,1),
          And(Neg(Member(p#+3,1)),
           And(succ_fm(n#+3,2),
            And(formula_N_fm(2,0), Member(p#+3,0))))))))"
 
 lemma depth_fm_type [TC]:
  "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> depth_fm(x,y) \<in> formula"
 by (simp add: depth_fm_def)
 
 lemma sats_depth_fm [simp]:
    "\<lbrakk>x \<in> nat; y < length(env); env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, depth_fm(x,y), env) \<longleftrightarrow>
         is_depth(##A, nth(x,env), nth(y,env))"
 apply (frule_tac x=y in lt_length_in_nat, assumption)  
 apply (simp add: depth_fm_def is_depth_def) 
 done
 
 lemma depth_iff_sats:
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y; 
           i \<in> nat; j < length(env); env \<in> list(A)\<rbrakk>
        \<Longrightarrow> is_depth(##A, x, y) \<longleftrightarrow> sats(A, depth_fm(i,j), env)"
 by (simp)
 
 theorem depth_reflection:
      "REFLECTS[\<lambda>x. is_depth(L, f(x), g(x)),  
                \<lambda>i x. is_depth(##Lset(i), f(x), g(x))]"
 apply (simp only: is_depth_def)
 apply (intro FOL_reflections function_reflections formula_N_reflection) 
 done
 
 
 
 subsubsection\<open>The Operator \<^term>\<open>is_formula_case\<close>\<close>
 
 text\<open>The arguments of \<^term>\<open>is_a\<close> are always 2, 1, 0, and the formula
       will be enclosed by three quantifiers.\<close>
 
 (* is_formula_case :: 
     "[i\<Rightarrow>o, [i,i,i]\<Rightarrow>o, [i,i,i]\<Rightarrow>o, [i,i,i]\<Rightarrow>o, [i,i]\<Rightarrow>o, i, i] \<Rightarrow> o"
   "is_formula_case(M, is_a, is_b, is_c, is_d, v, z) \<equiv> 
       (\<forall>x[M]. \<forall>y[M]. x\<in>nat \<longrightarrow> y\<in>nat \<longrightarrow> is_Member(M,x,y,v) \<longrightarrow> is_a(x,y,z)) \<and>
       (\<forall>x[M]. \<forall>y[M]. x\<in>nat \<longrightarrow> y\<in>nat \<longrightarrow> is_Equal(M,x,y,v) \<longrightarrow> is_b(x,y,z)) \<and>
       (\<forall>x[M]. \<forall>y[M]. x\<in>formula \<longrightarrow> y\<in>formula \<longrightarrow> 
                      is_Nand(M,x,y,v) \<longrightarrow> is_c(x,y,z)) \<and>
       (\<forall>x[M]. x\<in>formula \<longrightarrow> is_Forall(M,x,v) \<longrightarrow> is_d(x,z))" *)
 
 definition
   formula_case_fm :: "[i, i, i, i, i, i]\<Rightarrow>i" where
   "formula_case_fm(is_a, is_b, is_c, is_d, v, z) \<equiv> 
         And(Forall(Forall(Implies(finite_ordinal_fm(1), 
                            Implies(finite_ordinal_fm(0), 
                             Implies(Member_fm(1,0,v#+2), 
                              Forall(Implies(Equal(0,z#+3), is_a))))))),
         And(Forall(Forall(Implies(finite_ordinal_fm(1), 
                            Implies(finite_ordinal_fm(0), 
                             Implies(Equal_fm(1,0,v#+2), 
                              Forall(Implies(Equal(0,z#+3), is_b))))))),
         And(Forall(Forall(Implies(mem_formula_fm(1), 
                            Implies(mem_formula_fm(0), 
                             Implies(Nand_fm(1,0,v#+2), 
                              Forall(Implies(Equal(0,z#+3), is_c))))))),
         Forall(Implies(mem_formula_fm(0), 
                        Implies(Forall_fm(0,succ(v)), 
                              Forall(Implies(Equal(0,z#+2), is_d))))))))"
 
 
 lemma is_formula_case_type [TC]:
      "\<lbrakk>is_a \<in> formula;  is_b \<in> formula;  is_c \<in> formula;  is_d \<in> formula;  
          x \<in> nat; y \<in> nat\<rbrakk> 
       \<Longrightarrow> formula_case_fm(is_a, is_b, is_c, is_d, x, y) \<in> formula"
 by (simp add: formula_case_fm_def)
 
 lemma sats_formula_case_fm:
   assumes is_a_iff_sats: 
       "\<And>a0 a1 a2. 
         \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A\<rbrakk>  
         \<Longrightarrow> ISA(a2, a1, a0) \<longleftrightarrow> sats(A, is_a, Cons(a0,Cons(a1,Cons(a2,env))))"
   and is_b_iff_sats: 
       "\<And>a0 a1 a2. 
         \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A\<rbrakk>  
         \<Longrightarrow> ISB(a2, a1, a0) \<longleftrightarrow> sats(A, is_b, Cons(a0,Cons(a1,Cons(a2,env))))"
   and is_c_iff_sats: 
       "\<And>a0 a1 a2. 
         \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A\<rbrakk>  
         \<Longrightarrow> ISC(a2, a1, a0) \<longleftrightarrow> sats(A, is_c, Cons(a0,Cons(a1,Cons(a2,env))))"
   and is_d_iff_sats: 
       "\<And>a0 a1. 
         \<lbrakk>a0\<in>A; a1\<in>A\<rbrakk>  
         \<Longrightarrow> ISD(a1, a0) \<longleftrightarrow> sats(A, is_d, Cons(a0,Cons(a1,env)))"
   shows 
       "\<lbrakk>x \<in> nat; y < length(env); env \<in> list(A)\<rbrakk>
        \<Longrightarrow> sats(A, formula_case_fm(is_a,is_b,is_c,is_d,x,y), env) \<longleftrightarrow>
            is_formula_case(##A, ISA, ISB, ISC, ISD, nth(x,env), nth(y,env))"
 apply (frule_tac x=y in lt_length_in_nat, assumption)  
 apply (simp add: formula_case_fm_def is_formula_case_def 
                  is_a_iff_sats [THEN iff_sym] is_b_iff_sats [THEN iff_sym]
                  is_c_iff_sats [THEN iff_sym] is_d_iff_sats [THEN iff_sym])
 done
 
 lemma formula_case_iff_sats:
   assumes is_a_iff_sats: 
       "\<And>a0 a1 a2. 
         \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A\<rbrakk>  
         \<Longrightarrow> ISA(a2, a1, a0) \<longleftrightarrow> sats(A, is_a, Cons(a0,Cons(a1,Cons(a2,env))))"
   and is_b_iff_sats: 
       "\<And>a0 a1 a2. 
         \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A\<rbrakk>  
         \<Longrightarrow> ISB(a2, a1, a0) \<longleftrightarrow> sats(A, is_b, Cons(a0,Cons(a1,Cons(a2,env))))"
   and is_c_iff_sats: 
       "\<And>a0 a1 a2. 
         \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A\<rbrakk>  
         \<Longrightarrow> ISC(a2, a1, a0) \<longleftrightarrow> sats(A, is_c, Cons(a0,Cons(a1,Cons(a2,env))))"
   and is_d_iff_sats: 
       "\<And>a0 a1. 
         \<lbrakk>a0\<in>A; a1\<in>A\<rbrakk>  
         \<Longrightarrow> ISD(a1, a0) \<longleftrightarrow> sats(A, is_d, Cons(a0,Cons(a1,env)))"
   shows 
       "\<lbrakk>nth(i,env) = x; nth(j,env) = y; 
       i \<in> nat; j < length(env); env \<in> list(A)\<rbrakk>
        \<Longrightarrow> is_formula_case(##A, ISA, ISB, ISC, ISD, x, y) \<longleftrightarrow>
            sats(A, formula_case_fm(is_a,is_b,is_c,is_d,i,j), env)"
 by (simp add: sats_formula_case_fm [OF is_a_iff_sats is_b_iff_sats 
                                        is_c_iff_sats is_d_iff_sats])
 
 
 text\<open>The second argument of \<^term>\<open>is_a\<close> gives it direct access to \<^term>\<open>x\<close>,
   which is essential for handling free variable references.  Treatment is
   based on that of \<open>is_nat_case_reflection\<close>.\<close>
 theorem is_formula_case_reflection:
   assumes is_a_reflection:
     "\<And>h f g g'. REFLECTS[\<lambda>x. is_a(L, h(x), f(x), g(x), g'(x)),
                      \<lambda>i x. is_a(##Lset(i), h(x), f(x), g(x), g'(x))]"
   and is_b_reflection:
     "\<And>h f g g'. REFLECTS[\<lambda>x. is_b(L, h(x), f(x), g(x), g'(x)),
                      \<lambda>i x. is_b(##Lset(i), h(x), f(x), g(x), g'(x))]"
   and is_c_reflection:
     "\<And>h f g g'. REFLECTS[\<lambda>x. is_c(L, h(x), f(x), g(x), g'(x)),
                      \<lambda>i x. is_c(##Lset(i), h(x), f(x), g(x), g'(x))]"
   and is_d_reflection:
     "\<And>h f g g'. REFLECTS[\<lambda>x. is_d(L, h(x), f(x), g(x)),
                      \<lambda>i x. is_d(##Lset(i), h(x), f(x), g(x))]"
   shows "REFLECTS[\<lambda>x. is_formula_case(L, is_a(L,x), is_b(L,x), is_c(L,x), is_d(L,x), g(x), h(x)),
                \<lambda>i x. is_formula_case(##Lset(i), is_a(##Lset(i), x), is_b(##Lset(i), x), is_c(##Lset(i), x), is_d(##Lset(i), x), g(x), h(x))]"
 apply (simp (no_asm_use) only: is_formula_case_def)
 apply (intro FOL_reflections function_reflections finite_ordinal_reflection
          mem_formula_reflection
          Member_reflection Equal_reflection Nand_reflection Forall_reflection
          is_a_reflection is_b_reflection is_c_reflection is_d_reflection)
 done
 
 
 
 subsection \<open>Absoluteness for the Function \<^term>\<open>satisfies\<close>\<close>
 
 definition
   is_depth_apply :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
    \<comment> \<open>Merely a useful abbreviation for the sequel.\<close>
   "is_depth_apply(M,h,p,z) \<equiv>
     \<exists>dp[M]. \<exists>sdp[M]. \<exists>hsdp[M]. 
         finite_ordinal(M,dp) \<and> is_depth(M,p,dp) \<and> successor(M,dp,sdp) \<and>
         fun_apply(M,h,sdp,hsdp) \<and> fun_apply(M,hsdp,p,z)"
 
 lemma (in M_datatypes) is_depth_apply_abs [simp]:
      "\<lbrakk>M(h); p \<in> formula; M(z)\<rbrakk> 
       \<Longrightarrow> is_depth_apply(M,h,p,z) \<longleftrightarrow> z = h ` succ(depth(p)) ` p"
 by (simp add: is_depth_apply_def formula_into_M depth_type eq_commute)
 
 
 
 text\<open>There is at present some redundancy between the relativizations in
  e.g. \<open>satisfies_is_a\<close> and those in e.g. \<open>Member_replacement\<close>.\<close>
 
 text\<open>These constants let us instantiate the parameters \<^term>\<open>a\<close>, \<^term>\<open>b\<close>,
       \<^term>\<open>c\<close>, \<^term>\<open>d\<close>, etc., of the locale \<open>Formula_Rec\<close>.\<close>
 definition
   satisfies_a :: "[i,i,i]\<Rightarrow>i" where
    "satisfies_a(A) \<equiv> 
     \<lambda>x y. \<lambda>env \<in> list(A). bool_of_o (nth(x,env) \<in> nth(y,env))"
 
 definition
   satisfies_is_a :: "[i\<Rightarrow>o,i,i,i,i]\<Rightarrow>o" where
    "satisfies_is_a(M,A) \<equiv> 
     \<lambda>x y zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
              is_lambda(M, lA, 
                 \<lambda>env z. is_bool_of_o(M, 
                       \<exists>nx[M]. \<exists>ny[M]. 
                        is_nth(M,x,env,nx) \<and> is_nth(M,y,env,ny) \<and> nx \<in> ny, z),
                 zz)"
 
 definition
   satisfies_b :: "[i,i,i]\<Rightarrow>i" where
    "satisfies_b(A) \<equiv>
     \<lambda>x y. \<lambda>env \<in> list(A). bool_of_o (nth(x,env) = nth(y,env))"
 
 definition
   satisfies_is_b :: "[i\<Rightarrow>o,i,i,i,i]\<Rightarrow>o" where
    \<comment> \<open>We simplify the formula to have just \<^term>\<open>nx\<close> rather than 
        introducing \<^term>\<open>ny\<close> with  \<^term>\<open>nx=ny\<close>\<close>
   "satisfies_is_b(M,A) \<equiv> 
     \<lambda>x y zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
              is_lambda(M, lA, 
                 \<lambda>env z. is_bool_of_o(M, 
                       \<exists>nx[M]. is_nth(M,x,env,nx) \<and> is_nth(M,y,env,nx), z),
                 zz)"
 
 definition 
   satisfies_c :: "[i,i,i,i,i]\<Rightarrow>i" where
    "satisfies_c(A) \<equiv> \<lambda>p q rp rq. \<lambda>env \<in> list(A). not(rp ` env and rq ` env)"
 
 definition
   satisfies_is_c :: "[i\<Rightarrow>o,i,i,i,i,i]\<Rightarrow>o" where
    "satisfies_is_c(M,A,h) \<equiv> 
     \<lambda>p q zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
              is_lambda(M, lA, \<lambda>env z. \<exists>hp[M]. \<exists>hq[M]. 
                  (\<exists>rp[M]. is_depth_apply(M,h,p,rp) \<and> fun_apply(M,rp,env,hp)) \<and> 
                  (\<exists>rq[M]. is_depth_apply(M,h,q,rq) \<and> fun_apply(M,rq,env,hq)) \<and> 
                  (\<exists>pq[M]. is_and(M,hp,hq,pq) \<and> is_not(M,pq,z)),
                 zz)"
 
 definition
   satisfies_d :: "[i,i,i]\<Rightarrow>i" where
    "satisfies_d(A) 
     \<equiv> \<lambda>p rp. \<lambda>env \<in> list(A). bool_of_o (\<forall>x\<in>A. rp ` (Cons(x,env)) = 1)"
 
 definition
   satisfies_is_d :: "[i\<Rightarrow>o,i,i,i,i]\<Rightarrow>o" where
    "satisfies_is_d(M,A,h) \<equiv> 
     \<lambda>p zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
              is_lambda(M, lA, 
                 \<lambda>env z. \<exists>rp[M]. is_depth_apply(M,h,p,rp) \<and> 
                     is_bool_of_o(M, 
                            \<forall>x[M]. \<forall>xenv[M]. \<forall>hp[M]. 
                               x\<in>A \<longrightarrow> is_Cons(M,x,env,xenv) \<longrightarrow> 
                               fun_apply(M,rp,xenv,hp) \<longrightarrow> number1(M,hp),
                   z),
                zz)"
 
 definition
   satisfies_MH :: "[i\<Rightarrow>o,i,i,i,i]\<Rightarrow>o" where
     \<comment> \<open>The variable \<^term>\<open>u\<close> is unused, but gives \<^term>\<open>satisfies_MH\<close> 
         the correct arity.\<close>
   "satisfies_MH \<equiv> 
     \<lambda>M A u f z. 
          \<forall>fml[M]. is_formula(M,fml) \<longrightarrow>
              is_lambda (M, fml, 
                is_formula_case (M, satisfies_is_a(M,A), 
                                 satisfies_is_b(M,A), 
                                 satisfies_is_c(M,A,f), satisfies_is_d(M,A,f)),
                z)"
 
 definition
   is_satisfies :: "[i\<Rightarrow>o,i,i,i]\<Rightarrow>o" where
   "is_satisfies(M,A) \<equiv> is_formula_rec (M, satisfies_MH(M,A))"
 
 
 text\<open>This lemma relates the fragments defined above to the original primitive
       recursion in \<^term>\<open>satisfies\<close>.
       Induction is not required: the definitions are directly equal!\<close>
 lemma satisfies_eq:
   "satisfies(A,p) = 
    formula_rec (satisfies_a(A), satisfies_b(A), 
                 satisfies_c(A), satisfies_d(A), p)"
 by (simp add: satisfies_formula_def satisfies_a_def satisfies_b_def 
               satisfies_c_def satisfies_d_def) 
 
 text\<open>Further constraints on the class \<^term>\<open>M\<close> in order to prove
       absoluteness for the constants defined above.  The ultimate goal
       is the absoluteness of the function \<^term>\<open>satisfies\<close>.\<close>
 locale M_satisfies = M_eclose +
  assumes 
    Member_replacement:
     "\<lbrakk>M(A); x \<in> nat; y \<in> nat\<rbrakk>
      \<Longrightarrow> strong_replacement
          (M, \<lambda>env z. \<exists>bo[M]. \<exists>nx[M]. \<exists>ny[M]. 
               env \<in> list(A) \<and> is_nth(M,x,env,nx) \<and> is_nth(M,y,env,ny) \<and> 
               is_bool_of_o(M, nx \<in> ny, bo) \<and>
               pair(M, env, bo, z))"
  and
    Equal_replacement:
     "\<lbrakk>M(A); x \<in> nat; y \<in> nat\<rbrakk>
      \<Longrightarrow> strong_replacement
          (M, \<lambda>env z. \<exists>bo[M]. \<exists>nx[M]. \<exists>ny[M]. 
               env \<in> list(A) \<and> is_nth(M,x,env,nx) \<and> is_nth(M,y,env,ny) \<and> 
               is_bool_of_o(M, nx = ny, bo) \<and>
               pair(M, env, bo, z))"
  and
    Nand_replacement:
     "\<lbrakk>M(A); M(rp); M(rq)\<rbrakk>
      \<Longrightarrow> strong_replacement
          (M, \<lambda>env z. \<exists>rpe[M]. \<exists>rqe[M]. \<exists>andpq[M]. \<exists>notpq[M]. 
                fun_apply(M,rp,env,rpe) \<and> fun_apply(M,rq,env,rqe) \<and> 
                is_and(M,rpe,rqe,andpq) \<and> is_not(M,andpq,notpq) \<and> 
                env \<in> list(A) \<and> pair(M, env, notpq, z))"
  and
   Forall_replacement:
    "\<lbrakk>M(A); M(rp)\<rbrakk>
     \<Longrightarrow> strong_replacement
         (M, \<lambda>env z. \<exists>bo[M]. 
               env \<in> list(A) \<and> 
               is_bool_of_o (M, 
                             \<forall>a[M]. \<forall>co[M]. \<forall>rpco[M]. 
                                a\<in>A \<longrightarrow> is_Cons(M,a,env,co) \<longrightarrow>
                                fun_apply(M,rp,co,rpco) \<longrightarrow> number1(M, rpco), 
                             bo) \<and>
               pair(M,env,bo,z))"
  and
   formula_rec_replacement: 
       \<comment> \<open>For the \<^term>\<open>transrec\<close>\<close>
    "\<lbrakk>n \<in> nat; M(A)\<rbrakk> \<Longrightarrow> transrec_replacement(M, satisfies_MH(M,A), n)"
  and
   formula_rec_lambda_replacement:  
       \<comment> \<open>For the \<open>\<lambda>-abstraction\<close> in the \<^term>\<open>transrec\<close> body\<close>
    "\<lbrakk>M(g); M(A)\<rbrakk> \<Longrightarrow>
     strong_replacement (M, 
        \<lambda>x y. mem_formula(M,x) \<and>
              (\<exists>c[M]. is_formula_case(M, satisfies_is_a(M,A),
                                   satisfies_is_b(M,A),
                                   satisfies_is_c(M,A,g),
                                   satisfies_is_d(M,A,g), x, c) \<and>
              pair(M, x, c, y)))"
 
 
 lemma (in M_satisfies) Member_replacement':
     "\<lbrakk>M(A); x \<in> nat; y \<in> nat\<rbrakk>
      \<Longrightarrow> strong_replacement
          (M, \<lambda>env z. env \<in> list(A) \<and>
                      z = \<langle>env, bool_of_o(nth(x, env) \<in> nth(y, env))\<rangle>)"
 by (insert Member_replacement, simp) 
 
 lemma (in M_satisfies) Equal_replacement':
     "\<lbrakk>M(A); x \<in> nat; y \<in> nat\<rbrakk>
      \<Longrightarrow> strong_replacement
          (M, \<lambda>env z. env \<in> list(A) \<and>
                      z = \<langle>env, bool_of_o(nth(x, env) = nth(y, env))\<rangle>)"
 by (insert Equal_replacement, simp) 
 
 lemma (in M_satisfies) Nand_replacement':
     "\<lbrakk>M(A); M(rp); M(rq)\<rbrakk>
      \<Longrightarrow> strong_replacement
          (M, \<lambda>env z. env \<in> list(A) \<and> z = \<langle>env, not(rp`env and rq`env)\<rangle>)"
 by (insert Nand_replacement, simp) 
 
 lemma (in M_satisfies) Forall_replacement':
    "\<lbrakk>M(A); M(rp)\<rbrakk>
     \<Longrightarrow> strong_replacement
         (M, \<lambda>env z.
                env \<in> list(A) \<and>
                z = \<langle>env, bool_of_o (\<forall>a\<in>A. rp ` Cons(a,env) = 1)\<rangle>)"
 by (insert Forall_replacement, simp) 
 
 lemma (in M_satisfies) a_closed:
      "\<lbrakk>M(A); x\<in>nat; y\<in>nat\<rbrakk> \<Longrightarrow> M(satisfies_a(A,x,y))"
 apply (simp add: satisfies_a_def) 
 apply (blast intro: lam_closed2 Member_replacement') 
 done
 
 lemma (in M_satisfies) a_rel:
      "M(A) \<Longrightarrow> Relation2(M, nat, nat, satisfies_is_a(M,A), satisfies_a(A))"
 apply (simp add: Relation2_def satisfies_is_a_def satisfies_a_def)
 apply (auto del: iffI intro!: lambda_abs2 simp add: Relation1_def) 
 done
 
 lemma (in M_satisfies) b_closed:
      "\<lbrakk>M(A); x\<in>nat; y\<in>nat\<rbrakk> \<Longrightarrow> M(satisfies_b(A,x,y))"
 apply (simp add: satisfies_b_def) 
 apply (blast intro: lam_closed2 Equal_replacement') 
 done
 
 lemma (in M_satisfies) b_rel:
      "M(A) \<Longrightarrow> Relation2(M, nat, nat, satisfies_is_b(M,A), satisfies_b(A))"
 apply (simp add: Relation2_def satisfies_is_b_def satisfies_b_def)
 apply (auto del: iffI intro!: lambda_abs2 simp add: Relation1_def) 
 done
 
 lemma (in M_satisfies) c_closed:
      "\<lbrakk>M(A); x \<in> formula; y \<in> formula; M(rx); M(ry)\<rbrakk> 
       \<Longrightarrow> M(satisfies_c(A,x,y,rx,ry))"
 apply (simp add: satisfies_c_def) 
 apply (rule lam_closed2) 
 apply (rule Nand_replacement') 
 apply (simp_all add: formula_into_M list_into_M [of _ A])
 done
 
 lemma (in M_satisfies) c_rel:
  "\<lbrakk>M(A); M(f)\<rbrakk> \<Longrightarrow> 
   Relation2 (M, formula, formula, 
                satisfies_is_c(M,A,f),
                \<lambda>u v. satisfies_c(A, u, v, f ` succ(depth(u)) ` u, 
                                           f ` succ(depth(v)) ` v))"
 apply (simp add: Relation2_def satisfies_is_c_def satisfies_c_def)
 apply (auto del: iffI intro!: lambda_abs2 
             simp add: Relation1_def formula_into_M) 
 done
 
 lemma (in M_satisfies) d_closed:
      "\<lbrakk>M(A); x \<in> formula; M(rx)\<rbrakk> \<Longrightarrow> M(satisfies_d(A,x,rx))"
 apply (simp add: satisfies_d_def) 
 apply (rule lam_closed2) 
 apply (rule Forall_replacement') 
 apply (simp_all add: formula_into_M list_into_M [of _ A])
 done
 
 lemma (in M_satisfies) d_rel:
  "\<lbrakk>M(A); M(f)\<rbrakk> \<Longrightarrow> 
   Relation1(M, formula, satisfies_is_d(M,A,f), 
      \<lambda>u. satisfies_d(A, u, f ` succ(depth(u)) ` u))"
 apply (simp del: rall_abs 
             add: Relation1_def satisfies_is_d_def satisfies_d_def)
 apply (auto del: iffI intro!: lambda_abs2 simp add: Relation1_def) 
 done
 
 
 lemma (in M_satisfies) fr_replace:
       "\<lbrakk>n \<in> nat; M(A)\<rbrakk> \<Longrightarrow> transrec_replacement(M,satisfies_MH(M,A),n)" 
 by (blast intro: formula_rec_replacement) 
 
 lemma (in M_satisfies) formula_case_satisfies_closed:
  "\<lbrakk>M(g); M(A); x \<in> formula\<rbrakk> \<Longrightarrow>
   M(formula_case (satisfies_a(A), satisfies_b(A),
        \<lambda>u v. satisfies_c(A, u, v, 
                          g ` succ(depth(u)) ` u, g ` succ(depth(v)) ` v),
        \<lambda>u. satisfies_d (A, u, g ` succ(depth(u)) ` u),
        x))"
 by (blast intro: a_closed b_closed c_closed d_closed) 
 
 lemma (in M_satisfies) fr_lam_replace:
    "\<lbrakk>M(g); M(A)\<rbrakk> \<Longrightarrow>
     strong_replacement (M, \<lambda>x y. x \<in> formula \<and>
             y = \<langle>x, 
                  formula_rec_case(satisfies_a(A),
                                   satisfies_b(A),
                                   satisfies_c(A),
                                   satisfies_d(A), g, x)\<rangle>)"
 apply (insert formula_rec_lambda_replacement) 
 apply (simp add: formula_rec_case_def formula_case_satisfies_closed
                  formula_case_abs [OF a_rel b_rel c_rel d_rel]) 
 done
 
 
 
 text\<open>Instantiate locale \<open>Formula_Rec\<close> for the 
       Function \<^term>\<open>satisfies\<close>\<close>
 
 lemma (in M_satisfies) Formula_Rec_axioms_M:
    "M(A) \<Longrightarrow>
     Formula_Rec_axioms(M, satisfies_a(A), satisfies_is_a(M,A), 
                           satisfies_b(A), satisfies_is_b(M,A), 
                           satisfies_c(A), satisfies_is_c(M,A), 
                           satisfies_d(A), satisfies_is_d(M,A))"
 apply (rule Formula_Rec_axioms.intro)
 apply (assumption | 
        rule a_closed a_rel b_closed b_rel c_closed c_rel d_closed d_rel
        fr_replace [unfolded satisfies_MH_def]
        fr_lam_replace) +
 done
 
 
 theorem (in M_satisfies) Formula_Rec_M: 
     "M(A) \<Longrightarrow>
      Formula_Rec(M, satisfies_a(A), satisfies_is_a(M,A), 
                          satisfies_b(A), satisfies_is_b(M,A), 
                          satisfies_c(A), satisfies_is_c(M,A), 
                          satisfies_d(A), satisfies_is_d(M,A))"
   apply (rule Formula_Rec.intro)
    apply (rule M_satisfies.axioms, rule M_satisfies_axioms)
   apply (erule Formula_Rec_axioms_M) 
   done
 
 lemmas (in M_satisfies) 
     satisfies_closed' = Formula_Rec.formula_rec_closed [OF Formula_Rec_M]
 and satisfies_abs'    = Formula_Rec.formula_rec_abs [OF Formula_Rec_M]
 
 
 lemma (in M_satisfies) satisfies_closed:
   "\<lbrakk>M(A); p \<in> formula\<rbrakk> \<Longrightarrow> M(satisfies(A,p))"
 by (simp add: Formula_Rec.formula_rec_closed [OF Formula_Rec_M]  
               satisfies_eq) 
 
 lemma (in M_satisfies) satisfies_abs:
   "\<lbrakk>M(A); M(z); p \<in> formula\<rbrakk> 
    \<Longrightarrow> is_satisfies(M,A,p,z) \<longleftrightarrow> z = satisfies(A,p)"
 by (simp only: Formula_Rec.formula_rec_abs [OF Formula_Rec_M]  
                satisfies_eq is_satisfies_def satisfies_MH_def)
 
 
 subsection\<open>Internalizations Needed to Instantiate \<open>M_satisfies\<close>\<close>
 
 subsubsection\<open>The Operator \<^term>\<open>is_depth_apply\<close>, Internalized\<close>
 
 (* is_depth_apply(M,h,p,z) \<equiv>
     \<exists>dp[M]. \<exists>sdp[M]. \<exists>hsdp[M]. 
       2        1         0
         finite_ordinal(M,dp) \<and> is_depth(M,p,dp) \<and> successor(M,dp,sdp) \<and>
         fun_apply(M,h,sdp,hsdp) \<and> fun_apply(M,hsdp,p,z) *)
 definition
   depth_apply_fm :: "[i,i,i]\<Rightarrow>i" where
     "depth_apply_fm(h,p,z) \<equiv>
        Exists(Exists(Exists(
         And(finite_ordinal_fm(2),
          And(depth_fm(p#+3,2),
           And(succ_fm(2,1),
            And(fun_apply_fm(h#+3,1,0), fun_apply_fm(0,p#+3,z#+3))))))))"
 
 lemma depth_apply_type [TC]:
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> depth_apply_fm(x,y,z) \<in> formula"
 by (simp add: depth_apply_fm_def)
 
 lemma sats_depth_apply_fm [simp]:
    "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, depth_apply_fm(x,y,z), env) \<longleftrightarrow>
         is_depth_apply(##A, nth(x,env), nth(y,env), nth(z,env))"
 by (simp add: depth_apply_fm_def is_depth_apply_def)
 
 lemma depth_apply_iff_sats:
     "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
         i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
      \<Longrightarrow> is_depth_apply(##A, x, y, z) \<longleftrightarrow> sats(A, depth_apply_fm(i,j,k), env)"
 by simp
 
 lemma depth_apply_reflection:
      "REFLECTS[\<lambda>x. is_depth_apply(L,f(x),g(x),h(x)),
                \<lambda>i x. is_depth_apply(##Lset(i),f(x),g(x),h(x))]"
 apply (simp only: is_depth_apply_def)
 apply (intro FOL_reflections function_reflections depth_reflection 
              finite_ordinal_reflection)
 done
 
 
 subsubsection\<open>The Operator \<^term>\<open>satisfies_is_a\<close>, Internalized\<close>
 
 (* satisfies_is_a(M,A) \<equiv> 
     \<lambda>x y zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
              is_lambda(M, lA, 
                 \<lambda>env z. is_bool_of_o(M, 
                       \<exists>nx[M]. \<exists>ny[M]. 
                        is_nth(M,x,env,nx) \<and> is_nth(M,y,env,ny) \<and> nx \<in> ny, z),
                 zz)  *)
 
 definition
   satisfies_is_a_fm :: "[i,i,i,i]\<Rightarrow>i" where
   "satisfies_is_a_fm(A,x,y,z) \<equiv>
    Forall(
      Implies(is_list_fm(succ(A),0),
        lambda_fm(
          bool_of_o_fm(Exists(
                        Exists(And(nth_fm(x#+6,3,1), 
                                And(nth_fm(y#+6,3,0), 
                                    Member(1,0))))), 0), 
          0, succ(z))))"
 
 lemma satisfies_is_a_type [TC]:
      "\<lbrakk>A \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk>
       \<Longrightarrow> satisfies_is_a_fm(A,x,y,z) \<in> formula"
 by (simp add: satisfies_is_a_fm_def)
 
 lemma sats_satisfies_is_a_fm [simp]:
    "\<lbrakk>u \<in> nat; x < length(env); y < length(env); z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, satisfies_is_a_fm(u,x,y,z), env) \<longleftrightarrow>
         satisfies_is_a(##A, nth(u,env), nth(x,env), nth(y,env), nth(z,env))"
 apply (frule_tac x=x in lt_length_in_nat, assumption)  
 apply (frule_tac x=y in lt_length_in_nat, assumption)  
 apply (simp add: satisfies_is_a_fm_def satisfies_is_a_def sats_lambda_fm 
                  sats_bool_of_o_fm)
 done
 
 lemma satisfies_is_a_iff_sats:
   "\<lbrakk>nth(u,env) = nu; nth(x,env) = nx; nth(y,env) = ny; nth(z,env) = nz;
       u \<in> nat; x < length(env); y < length(env); z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> satisfies_is_a(##A,nu,nx,ny,nz) \<longleftrightarrow>
        sats(A, satisfies_is_a_fm(u,x,y,z), env)"
 by simp
 
 theorem satisfies_is_a_reflection:
      "REFLECTS[\<lambda>x. satisfies_is_a(L,f(x),g(x),h(x),g'(x)),
                \<lambda>i x. satisfies_is_a(##Lset(i),f(x),g(x),h(x),g'(x))]"
   unfolding satisfies_is_a_def 
 apply (intro FOL_reflections is_lambda_reflection bool_of_o_reflection 
              nth_reflection is_list_reflection)
 done
 
 
 subsubsection\<open>The Operator \<^term>\<open>satisfies_is_b\<close>, Internalized\<close>
 
 (* satisfies_is_b(M,A) \<equiv> 
     \<lambda>x y zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
              is_lambda(M, lA, 
                 \<lambda>env z. is_bool_of_o(M, 
                       \<exists>nx[M]. is_nth(M,x,env,nx) \<and> is_nth(M,y,env,nx), z),
                 zz) *)
 
 definition
   satisfies_is_b_fm :: "[i,i,i,i]\<Rightarrow>i" where
  "satisfies_is_b_fm(A,x,y,z) \<equiv>
    Forall(
      Implies(is_list_fm(succ(A),0),
        lambda_fm(
          bool_of_o_fm(Exists(And(nth_fm(x#+5,2,0), nth_fm(y#+5,2,0))), 0), 
          0, succ(z))))"
 
 lemma satisfies_is_b_type [TC]:
      "\<lbrakk>A \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk>
       \<Longrightarrow> satisfies_is_b_fm(A,x,y,z) \<in> formula"
 by (simp add: satisfies_is_b_fm_def)
 
 lemma sats_satisfies_is_b_fm [simp]:
    "\<lbrakk>u \<in> nat; x < length(env); y < length(env); z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, satisfies_is_b_fm(u,x,y,z), env) \<longleftrightarrow>
         satisfies_is_b(##A, nth(u,env), nth(x,env), nth(y,env), nth(z,env))"
 apply (frule_tac x=x in lt_length_in_nat, assumption)  
 apply (frule_tac x=y in lt_length_in_nat, assumption)  
 apply (simp add: satisfies_is_b_fm_def satisfies_is_b_def sats_lambda_fm 
                  sats_bool_of_o_fm)
 done
 
 lemma satisfies_is_b_iff_sats:
   "\<lbrakk>nth(u,env) = nu; nth(x,env) = nx; nth(y,env) = ny; nth(z,env) = nz;
       u \<in> nat; x < length(env); y < length(env); z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> satisfies_is_b(##A,nu,nx,ny,nz) \<longleftrightarrow>
        sats(A, satisfies_is_b_fm(u,x,y,z), env)"
 by simp
 
 theorem satisfies_is_b_reflection:
      "REFLECTS[\<lambda>x. satisfies_is_b(L,f(x),g(x),h(x),g'(x)),
                \<lambda>i x. satisfies_is_b(##Lset(i),f(x),g(x),h(x),g'(x))]"
   unfolding satisfies_is_b_def 
 apply (intro FOL_reflections is_lambda_reflection bool_of_o_reflection 
              nth_reflection is_list_reflection)
 done
 
 
 subsubsection\<open>The Operator \<^term>\<open>satisfies_is_c\<close>, Internalized\<close>
 
 (* satisfies_is_c(M,A,h) \<equiv> 
     \<lambda>p q zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
              is_lambda(M, lA, \<lambda>env z. \<exists>hp[M]. \<exists>hq[M]. 
                  (\<exists>rp[M]. is_depth_apply(M,h,p,rp) \<and> fun_apply(M,rp,env,hp)) \<and> 
                  (\<exists>rq[M]. is_depth_apply(M,h,q,rq) \<and> fun_apply(M,rq,env,hq)) \<and> 
                  (\<exists>pq[M]. is_and(M,hp,hq,pq) \<and> is_not(M,pq,z)),
                 zz) *)
 
 definition
   satisfies_is_c_fm :: "[i,i,i,i,i]\<Rightarrow>i" where
  "satisfies_is_c_fm(A,h,p,q,zz) \<equiv>
    Forall(
      Implies(is_list_fm(succ(A),0),
        lambda_fm(
          Exists(Exists(
           And(Exists(And(depth_apply_fm(h#+7,p#+7,0), fun_apply_fm(0,4,2))),
           And(Exists(And(depth_apply_fm(h#+7,q#+7,0), fun_apply_fm(0,4,1))),
               Exists(And(and_fm(2,1,0), not_fm(0,3))))))),
          0, succ(zz))))"
 
 lemma satisfies_is_c_type [TC]:
      "\<lbrakk>A \<in> nat; h \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk>
       \<Longrightarrow> satisfies_is_c_fm(A,h,x,y,z) \<in> formula"
 by (simp add: satisfies_is_c_fm_def)
 
 lemma sats_satisfies_is_c_fm [simp]:
    "\<lbrakk>u \<in> nat; v \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, satisfies_is_c_fm(u,v,x,y,z), env) \<longleftrightarrow>
         satisfies_is_c(##A, nth(u,env), nth(v,env), nth(x,env), 
                             nth(y,env), nth(z,env))"  
 by (simp add: satisfies_is_c_fm_def satisfies_is_c_def sats_lambda_fm)
 
 lemma satisfies_is_c_iff_sats:
   "\<lbrakk>nth(u,env) = nu; nth(v,env) = nv; nth(x,env) = nx; nth(y,env) = ny; 
       nth(z,env) = nz;
       u \<in> nat; v \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> satisfies_is_c(##A,nu,nv,nx,ny,nz) \<longleftrightarrow>
        sats(A, satisfies_is_c_fm(u,v,x,y,z), env)"
 by simp
 
 theorem satisfies_is_c_reflection:
      "REFLECTS[\<lambda>x. satisfies_is_c(L,f(x),g(x),h(x),g'(x),h'(x)),
                \<lambda>i x. satisfies_is_c(##Lset(i),f(x),g(x),h(x),g'(x),h'(x))]"
   unfolding satisfies_is_c_def 
 apply (intro FOL_reflections function_reflections is_lambda_reflection
              extra_reflections nth_reflection depth_apply_reflection 
              is_list_reflection)
 done
 
 subsubsection\<open>The Operator \<^term>\<open>satisfies_is_d\<close>, Internalized\<close>
 
 (* satisfies_is_d(M,A,h) \<equiv> 
     \<lambda>p zz. \<forall>lA[M]. is_list(M,A,lA) \<longrightarrow>
              is_lambda(M, lA, 
                 \<lambda>env z. \<exists>rp[M]. is_depth_apply(M,h,p,rp) \<and> 
                     is_bool_of_o(M, 
                            \<forall>x[M]. \<forall>xenv[M]. \<forall>hp[M]. 
                               x\<in>A \<longrightarrow> is_Cons(M,x,env,xenv) \<longrightarrow> 
                               fun_apply(M,rp,xenv,hp) \<longrightarrow> number1(M,hp),
                   z),
                zz) *)
 
 definition
   satisfies_is_d_fm :: "[i,i,i,i]\<Rightarrow>i" where
  "satisfies_is_d_fm(A,h,p,zz) \<equiv>
    Forall(
      Implies(is_list_fm(succ(A),0),
        lambda_fm(
          Exists(
            And(depth_apply_fm(h#+5,p#+5,0),
                bool_of_o_fm(
                 Forall(Forall(Forall(
                  Implies(Member(2,A#+8),
                   Implies(Cons_fm(2,5,1),
                    Implies(fun_apply_fm(3,1,0), number1_fm(0))))))), 1))),
          0, succ(zz))))"
 
 lemma satisfies_is_d_type [TC]:
      "\<lbrakk>A \<in> nat; h \<in> nat; x \<in> nat; z \<in> nat\<rbrakk>
       \<Longrightarrow> satisfies_is_d_fm(A,h,x,z) \<in> formula"
 by (simp add: satisfies_is_d_fm_def)
 
 lemma sats_satisfies_is_d_fm [simp]:
    "\<lbrakk>u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, satisfies_is_d_fm(u,x,y,z), env) \<longleftrightarrow>
         satisfies_is_d(##A, nth(u,env), nth(x,env), nth(y,env), nth(z,env))"  
 by (simp add: satisfies_is_d_fm_def satisfies_is_d_def sats_lambda_fm
               sats_bool_of_o_fm)
 
 lemma satisfies_is_d_iff_sats:
   "\<lbrakk>nth(u,env) = nu; nth(x,env) = nx; nth(y,env) = ny; nth(z,env) = nz;
       u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> satisfies_is_d(##A,nu,nx,ny,nz) \<longleftrightarrow>
        sats(A, satisfies_is_d_fm(u,x,y,z), env)"
 by simp
 
 theorem satisfies_is_d_reflection:
      "REFLECTS[\<lambda>x. satisfies_is_d(L,f(x),g(x),h(x),g'(x)),
                \<lambda>i x. satisfies_is_d(##Lset(i),f(x),g(x),h(x),g'(x))]"
   unfolding satisfies_is_d_def 
 apply (intro FOL_reflections function_reflections is_lambda_reflection
              extra_reflections nth_reflection depth_apply_reflection 
              is_list_reflection)
 done
 
 
 subsubsection\<open>The Operator \<^term>\<open>satisfies_MH\<close>, Internalized\<close>
 
 (* satisfies_MH \<equiv> 
     \<lambda>M A u f zz. 
          \<forall>fml[M]. is_formula(M,fml) \<longrightarrow>
              is_lambda (M, fml, 
                is_formula_case (M, satisfies_is_a(M,A), 
                                 satisfies_is_b(M,A), 
                                 satisfies_is_c(M,A,f), satisfies_is_d(M,A,f)),
                zz) *)
 
 definition
   satisfies_MH_fm :: "[i,i,i,i]\<Rightarrow>i" where
  "satisfies_MH_fm(A,u,f,zz) \<equiv>
    Forall(
      Implies(is_formula_fm(0),
        lambda_fm(
          formula_case_fm(satisfies_is_a_fm(A#+7,2,1,0), 
                          satisfies_is_b_fm(A#+7,2,1,0), 
                          satisfies_is_c_fm(A#+7,f#+7,2,1,0), 
                          satisfies_is_d_fm(A#+6,f#+6,1,0), 
                          1, 0),
          0, succ(zz))))"
 
 lemma satisfies_MH_type [TC]:
      "\<lbrakk>A \<in> nat; u \<in> nat; x \<in> nat; z \<in> nat\<rbrakk>
       \<Longrightarrow> satisfies_MH_fm(A,u,x,z) \<in> formula"
 by (simp add: satisfies_MH_fm_def)
 
 lemma sats_satisfies_MH_fm [simp]:
    "\<lbrakk>u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
     \<Longrightarrow> sats(A, satisfies_MH_fm(u,x,y,z), env) \<longleftrightarrow>
         satisfies_MH(##A, nth(u,env), nth(x,env), nth(y,env), nth(z,env))"  
 by (simp add: satisfies_MH_fm_def satisfies_MH_def sats_lambda_fm
               sats_formula_case_fm)
 
 lemma satisfies_MH_iff_sats:
   "\<lbrakk>nth(u,env) = nu; nth(x,env) = nx; nth(y,env) = ny; nth(z,env) = nz;
       u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> satisfies_MH(##A,nu,nx,ny,nz) \<longleftrightarrow>
        sats(A, satisfies_MH_fm(u,x,y,z), env)"
 by simp 
 
 lemmas satisfies_reflections =
        is_lambda_reflection is_formula_reflection 
        is_formula_case_reflection
        satisfies_is_a_reflection satisfies_is_b_reflection 
        satisfies_is_c_reflection satisfies_is_d_reflection
 
 theorem satisfies_MH_reflection:
      "REFLECTS[\<lambda>x. satisfies_MH(L,f(x),g(x),h(x),g'(x)),
                \<lambda>i x. satisfies_MH(##Lset(i),f(x),g(x),h(x),g'(x))]"
   unfolding satisfies_MH_def 
 apply (intro FOL_reflections satisfies_reflections)
 done
 
 
 subsection\<open>Lemmas for Instantiating the Locale \<open>M_satisfies\<close>\<close>
 
 
 subsubsection\<open>The \<^term>\<open>Member\<close> Case\<close>
 
 lemma Member_Reflects:
  "REFLECTS[\<lambda>u. \<exists>v[L]. v \<in> B \<and> (\<exists>bo[L]. \<exists>nx[L]. \<exists>ny[L].
           v \<in> lstA \<and> is_nth(L,x,v,nx) \<and> is_nth(L,y,v,ny) \<and>
           is_bool_of_o(L, nx \<in> ny, bo) \<and> pair(L,v,bo,u)),
    \<lambda>i u. \<exists>v \<in> Lset(i). v \<in> B \<and> (\<exists>bo \<in> Lset(i). \<exists>nx \<in> Lset(i). \<exists>ny \<in> Lset(i).
              v \<in> lstA \<and> is_nth(##Lset(i), x, v, nx) \<and> 
              is_nth(##Lset(i), y, v, ny) \<and>
           is_bool_of_o(##Lset(i), nx \<in> ny, bo) \<and> pair(##Lset(i), v, bo, u))]"
 by (intro FOL_reflections function_reflections nth_reflection 
           bool_of_o_reflection)
 
 
 lemma Member_replacement:
     "\<lbrakk>L(A); x \<in> nat; y \<in> nat\<rbrakk>
      \<Longrightarrow> strong_replacement
          (L, \<lambda>env z. \<exists>bo[L]. \<exists>nx[L]. \<exists>ny[L]. 
               env \<in> list(A) \<and> is_nth(L,x,env,nx) \<and> is_nth(L,y,env,ny) \<and> 
               is_bool_of_o(L, nx \<in> ny, bo) \<and>
               pair(L, env, bo, z))"
 apply (rule strong_replacementI)
 apply (rule_tac u="{list(A),B,x,y}" 
          in gen_separation_multi [OF Member_Reflects], 
        auto)
 apply (rule_tac env="[list(A),B,x,y]" in DPow_LsetI)
 apply (rule sep_rules nth_iff_sats is_bool_of_o_iff_sats | simp)+
 done
 
 
 subsubsection\<open>The \<^term>\<open>Equal\<close> Case\<close>
 
 lemma Equal_Reflects:
  "REFLECTS[\<lambda>u. \<exists>v[L]. v \<in> B \<and> (\<exists>bo[L]. \<exists>nx[L]. \<exists>ny[L].
           v \<in> lstA \<and> is_nth(L, x, v, nx) \<and> is_nth(L, y, v, ny) \<and>
           is_bool_of_o(L, nx = ny, bo) \<and> pair(L, v, bo, u)),
    \<lambda>i u. \<exists>v \<in> Lset(i). v \<in> B \<and> (\<exists>bo \<in> Lset(i). \<exists>nx \<in> Lset(i). \<exists>ny \<in> Lset(i).
              v \<in> lstA \<and> is_nth(##Lset(i), x, v, nx) \<and> 
              is_nth(##Lset(i), y, v, ny) \<and>
           is_bool_of_o(##Lset(i), nx = ny, bo) \<and> pair(##Lset(i), v, bo, u))]"
 by (intro FOL_reflections function_reflections nth_reflection 
           bool_of_o_reflection)
 
 
 lemma Equal_replacement:
     "\<lbrakk>L(A); x \<in> nat; y \<in> nat\<rbrakk>
      \<Longrightarrow> strong_replacement
          (L, \<lambda>env z. \<exists>bo[L]. \<exists>nx[L]. \<exists>ny[L]. 
               env \<in> list(A) \<and> is_nth(L,x,env,nx) \<and> is_nth(L,y,env,ny) \<and> 
               is_bool_of_o(L, nx = ny, bo) \<and>
               pair(L, env, bo, z))"
 apply (rule strong_replacementI)
 apply (rule_tac u="{list(A),B,x,y}" 
          in gen_separation_multi [OF Equal_Reflects], 
        auto)
 apply (rule_tac env="[list(A),B,x,y]" in DPow_LsetI)
 apply (rule sep_rules nth_iff_sats is_bool_of_o_iff_sats | simp)+
 done
 
 subsubsection\<open>The \<^term>\<open>Nand\<close> Case\<close>
 
 lemma Nand_Reflects:
     "REFLECTS [\<lambda>x. \<exists>u[L]. u \<in> B \<and>
                (\<exists>rpe[L]. \<exists>rqe[L]. \<exists>andpq[L]. \<exists>notpq[L].
                  fun_apply(L, rp, u, rpe) \<and> fun_apply(L, rq, u, rqe) \<and>
                  is_and(L, rpe, rqe, andpq) \<and> is_not(L, andpq, notpq) \<and>
                  u \<in> list(A) \<and> pair(L, u, notpq, x)),
     \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B \<and>
      (\<exists>rpe \<in> Lset(i). \<exists>rqe \<in> Lset(i). \<exists>andpq \<in> Lset(i). \<exists>notpq \<in> Lset(i).
        fun_apply(##Lset(i), rp, u, rpe) \<and> fun_apply(##Lset(i), rq, u, rqe) \<and>
        is_and(##Lset(i), rpe, rqe, andpq) \<and> is_not(##Lset(i), andpq, notpq) \<and>
        u \<in> list(A) \<and> pair(##Lset(i), u, notpq, x))]"
-apply (unfold is_and_def is_not_def) 
+  unfolding is_and_def is_not_def 
 apply (intro FOL_reflections function_reflections)
 done
 
 lemma Nand_replacement:
     "\<lbrakk>L(A); L(rp); L(rq)\<rbrakk>
      \<Longrightarrow> strong_replacement
          (L, \<lambda>env z. \<exists>rpe[L]. \<exists>rqe[L]. \<exists>andpq[L]. \<exists>notpq[L]. 
                fun_apply(L,rp,env,rpe) \<and> fun_apply(L,rq,env,rqe) \<and> 
                is_and(L,rpe,rqe,andpq) \<and> is_not(L,andpq,notpq) \<and> 
                env \<in> list(A) \<and> pair(L, env, notpq, z))"
 apply (rule strong_replacementI)
 apply (rule_tac u="{list(A),B,rp,rq}" 
          in gen_separation_multi [OF Nand_Reflects],
        auto)
 apply (rule_tac env="[list(A),B,rp,rq]" in DPow_LsetI)
 apply (rule sep_rules is_and_iff_sats is_not_iff_sats | simp)+
 done
 
 
 subsubsection\<open>The \<^term>\<open>Forall\<close> Case\<close>
 
 lemma Forall_Reflects:
  "REFLECTS [\<lambda>x. \<exists>u[L]. u \<in> B \<and> (\<exists>bo[L]. u \<in> list(A) \<and>
                  is_bool_of_o (L,
      \<forall>a[L]. \<forall>co[L]. \<forall>rpco[L]. a \<in> A \<longrightarrow>
                 is_Cons(L,a,u,co) \<longrightarrow> fun_apply(L,rp,co,rpco) \<longrightarrow> 
                 number1(L,rpco),
                            bo) \<and> pair(L,u,bo,x)),
  \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B \<and> (\<exists>bo \<in> Lset(i). u \<in> list(A) \<and>
         is_bool_of_o (##Lset(i),
  \<forall>a \<in> Lset(i). \<forall>co \<in> Lset(i). \<forall>rpco \<in> Lset(i). a \<in> A \<longrightarrow>
             is_Cons(##Lset(i),a,u,co) \<longrightarrow> fun_apply(##Lset(i),rp,co,rpco) \<longrightarrow> 
             number1(##Lset(i),rpco),
                        bo) \<and> pair(##Lset(i),u,bo,x))]"
   unfolding is_bool_of_o_def 
 apply (intro FOL_reflections function_reflections Cons_reflection)
 done
 
 lemma Forall_replacement:
    "\<lbrakk>L(A); L(rp)\<rbrakk>
     \<Longrightarrow> strong_replacement
         (L, \<lambda>env z. \<exists>bo[L]. 
               env \<in> list(A) \<and> 
               is_bool_of_o (L, 
                             \<forall>a[L]. \<forall>co[L]. \<forall>rpco[L]. 
                                a\<in>A \<longrightarrow> is_Cons(L,a,env,co) \<longrightarrow>
                                fun_apply(L,rp,co,rpco) \<longrightarrow> number1(L, rpco), 
                             bo) \<and>
               pair(L,env,bo,z))"
 apply (rule strong_replacementI)
 apply (rule_tac u="{A,list(A),B,rp}" 
          in gen_separation_multi [OF Forall_Reflects],
        auto)
 apply (rule_tac env="[A,list(A),B,rp]" in DPow_LsetI)
 apply (rule sep_rules is_bool_of_o_iff_sats Cons_iff_sats | simp)+
 done
 
 subsubsection\<open>The \<^term>\<open>transrec_replacement\<close> Case\<close>
 
 lemma formula_rec_replacement_Reflects:
  "REFLECTS [\<lambda>x. \<exists>u[L]. u \<in> B \<and> (\<exists>y[L]. pair(L, u, y, x) \<and>
              is_wfrec (L, satisfies_MH(L,A), mesa, u, y)),
     \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B \<and> (\<exists>y \<in> Lset(i). pair(##Lset(i), u, y, x) \<and>
              is_wfrec (##Lset(i), satisfies_MH(##Lset(i),A), mesa, u, y))]"
 by (intro FOL_reflections function_reflections satisfies_MH_reflection 
           is_wfrec_reflection) 
 
 lemma formula_rec_replacement: 
       \<comment> \<open>For the \<^term>\<open>transrec\<close>\<close>
    "\<lbrakk>n \<in> nat; L(A)\<rbrakk> \<Longrightarrow> transrec_replacement(L, satisfies_MH(L,A), n)"
 apply (rule L.transrec_replacementI, simp add: L.nat_into_M)
 apply (rule strong_replacementI)
 apply (rule_tac u="{B,A,n,Memrel(eclose({n}))}"
          in gen_separation_multi [OF formula_rec_replacement_Reflects],
        auto simp add: L.nat_into_M)
 apply (rule_tac env="[B,A,n,Memrel(eclose({n}))]" in DPow_LsetI)
 apply (rule sep_rules satisfies_MH_iff_sats is_wfrec_iff_sats | simp)+
 done
 
 
 subsubsection\<open>The Lambda Replacement Case\<close>
 
 lemma formula_rec_lambda_replacement_Reflects:
  "REFLECTS [\<lambda>x. \<exists>u[L]. u \<in> B \<and>
      mem_formula(L,u) \<and>
      (\<exists>c[L].
          is_formula_case
           (L, satisfies_is_a(L,A), satisfies_is_b(L,A),
            satisfies_is_c(L,A,g), satisfies_is_d(L,A,g),
            u, c) \<and>
          pair(L,u,c,x)),
   \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B \<and> mem_formula(##Lset(i),u) \<and>
      (\<exists>c \<in> Lset(i).
          is_formula_case
           (##Lset(i), satisfies_is_a(##Lset(i),A), satisfies_is_b(##Lset(i),A),
            satisfies_is_c(##Lset(i),A,g), satisfies_is_d(##Lset(i),A,g),
            u, c) \<and>
          pair(##Lset(i),u,c,x))]"
 by (intro FOL_reflections function_reflections mem_formula_reflection
           is_formula_case_reflection satisfies_is_a_reflection
           satisfies_is_b_reflection satisfies_is_c_reflection
           satisfies_is_d_reflection)  
 
 lemma formula_rec_lambda_replacement: 
       \<comment> \<open>For the \<^term>\<open>transrec\<close>\<close>
    "\<lbrakk>L(g); L(A)\<rbrakk> \<Longrightarrow>
     strong_replacement (L, 
        \<lambda>x y. mem_formula(L,x) \<and>
              (\<exists>c[L]. is_formula_case(L, satisfies_is_a(L,A),
                                   satisfies_is_b(L,A),
                                   satisfies_is_c(L,A,g),
                                   satisfies_is_d(L,A,g), x, c) \<and>
              pair(L, x, c, y)))" 
 apply (rule strong_replacementI)
 apply (rule_tac u="{B,A,g}"
          in gen_separation_multi [OF formula_rec_lambda_replacement_Reflects], 
        auto)
 apply (rule_tac env="[A,g,B]" in DPow_LsetI)
 apply (rule sep_rules mem_formula_iff_sats
           formula_case_iff_sats satisfies_is_a_iff_sats
           satisfies_is_b_iff_sats satisfies_is_c_iff_sats
           satisfies_is_d_iff_sats | simp)+
 done
 
 
 subsection\<open>Instantiating \<open>M_satisfies\<close>\<close>
 
 lemma M_satisfies_axioms_L: "M_satisfies_axioms(L)"
   apply (rule M_satisfies_axioms.intro)
        apply (assumption | rule
          Member_replacement Equal_replacement 
          Nand_replacement Forall_replacement
          formula_rec_replacement formula_rec_lambda_replacement)+
   done
 
 theorem M_satisfies_L: "M_satisfies(L)"
   apply (rule M_satisfies.intro)
    apply (rule M_eclose_L)
   apply (rule M_satisfies_axioms_L)
   done
 
 text\<open>Finally: the point of the whole theory!\<close>
 lemmas satisfies_closed = M_satisfies.satisfies_closed [OF M_satisfies_L]
    and satisfies_abs = M_satisfies.satisfies_abs [OF M_satisfies_L]
 
 end
diff --git a/src/ZF/Epsilon.thy b/src/ZF/Epsilon.thy
--- a/src/ZF/Epsilon.thy
+++ b/src/ZF/Epsilon.thy
@@ -1,399 +1,399 @@
 (*  Title:      ZF/Epsilon.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1993  University of Cambridge
 *)
 
 section\<open>Epsilon Induction and Recursion\<close>
 
 theory Epsilon imports Nat begin
 
 definition
   eclose    :: "i\<Rightarrow>i"  where
     "eclose(A) \<equiv> \<Union>n\<in>nat. nat_rec(n, A, \<lambda>m r. \<Union>(r))"
 
 definition
   transrec  :: "[i, [i,i]\<Rightarrow>i] \<Rightarrow>i"  where
     "transrec(a,H) \<equiv> wfrec(Memrel(eclose({a})), a, H)"
 
 definition
   rank      :: "i\<Rightarrow>i"  where
     "rank(a) \<equiv> transrec(a, \<lambda>x f. \<Union>y\<in>x. succ(f`y))"
 
 definition
   transrec2 :: "[i, i, [i,i]\<Rightarrow>i] \<Rightarrow>i"  where
     "transrec2(k, a, b) \<equiv>
        transrec(k,
                 \<lambda>i r. if(i=0, a,
                         if(\<exists>j. i=succ(j),
                            b(THE j. i=succ(j), r`(THE j. i=succ(j))),
                            \<Union>j<i. r`j)))"
 
 definition
   recursor  :: "[i, [i,i]\<Rightarrow>i, i]\<Rightarrow>i"  where
     "recursor(a,b,k) \<equiv>  transrec(k, \<lambda>n f. nat_case(a, \<lambda>m. b(m, f`m), n))"
 
 definition
   rec  :: "[i, i, [i,i]\<Rightarrow>i]\<Rightarrow>i"  where
     "rec(k,a,b) \<equiv> recursor(a,b,k)"
 
 
 subsection\<open>Basic Closure Properties\<close>
 
 lemma arg_subset_eclose: "A \<subseteq> eclose(A)"
   unfolding eclose_def
 apply (rule nat_rec_0 [THEN equalityD2, THEN subset_trans])
 apply (rule nat_0I [THEN UN_upper])
 done
 
 lemmas arg_into_eclose = arg_subset_eclose [THEN subsetD]
 
 lemma Transset_eclose: "Transset(eclose(A))"
-apply (unfold eclose_def Transset_def)
+  unfolding eclose_def Transset_def
 apply (rule subsetI [THEN ballI])
 apply (erule UN_E)
 apply (rule nat_succI [THEN UN_I], assumption)
 apply (erule nat_rec_succ [THEN ssubst])
 apply (erule UnionI, assumption)
 done
 
 (* @{term"x \<in> eclose(A) \<Longrightarrow> x \<subseteq> eclose(A)"} *)
 lemmas eclose_subset =
        Transset_eclose [unfolded Transset_def, THEN bspec]
 
 (* @{term"\<lbrakk>A \<in> eclose(B); c \<in> A\<rbrakk> \<Longrightarrow> c \<in> eclose(B)"} *)
 lemmas ecloseD = eclose_subset [THEN subsetD]
 
 lemmas arg_in_eclose_sing = arg_subset_eclose [THEN singleton_subsetD]
 lemmas arg_into_eclose_sing = arg_in_eclose_sing [THEN ecloseD]
 
 (* This is epsilon-induction for eclose(A); see also eclose_induct_down...
    \<lbrakk>a \<in> eclose(A);  \<And>x. \<lbrakk>x \<in> eclose(A); \<forall>y\<in>x. P(y)\<rbrakk> \<Longrightarrow> P(x)
 \<rbrakk> \<Longrightarrow> P(a)
 *)
 lemmas eclose_induct =
      Transset_induct [OF _ Transset_eclose, induct set: eclose]
 
 
 (*Epsilon induction*)
 lemma eps_induct:
     "\<lbrakk>\<And>x. \<forall>y\<in>x. P(y) \<Longrightarrow> P(x)\<rbrakk>  \<Longrightarrow>  P(a)"
 by (rule arg_in_eclose_sing [THEN eclose_induct], blast)
 
 
 subsection\<open>Leastness of \<^term>\<open>eclose\<close>\<close>
 
 (** eclose(A) is the least transitive set including A as a subset. **)
 
 lemma eclose_least_lemma:
     "\<lbrakk>Transset(X);  A<=X;  n \<in> nat\<rbrakk> \<Longrightarrow> nat_rec(n, A, \<lambda>m r. \<Union>(r)) \<subseteq> X"
   unfolding Transset_def
 apply (erule nat_induct)
 apply (simp add: nat_rec_0)
 apply (simp add: nat_rec_succ, blast)
 done
 
 lemma eclose_least:
      "\<lbrakk>Transset(X);  A<=X\<rbrakk> \<Longrightarrow> eclose(A) \<subseteq> X"
   unfolding eclose_def
 apply (rule eclose_least_lemma [THEN UN_least], assumption+)
 done
 
 (*COMPLETELY DIFFERENT induction principle from eclose_induct\<And>*)
 lemma eclose_induct_down [consumes 1]:
     "\<lbrakk>a \<in> eclose(b);
         \<And>y.   \<lbrakk>y \<in> b\<rbrakk> \<Longrightarrow> P(y);
         \<And>y z. \<lbrakk>y \<in> eclose(b);  P(y);  z \<in> y\<rbrakk> \<Longrightarrow> P(z)
 \<rbrakk> \<Longrightarrow> P(a)"
 apply (rule eclose_least [THEN subsetD, THEN CollectD2, of "eclose(b)"])
   prefer 3 apply assumption
    unfolding Transset_def
  apply (blast intro: ecloseD)
 apply (blast intro: arg_subset_eclose [THEN subsetD])
 done
 
 lemma Transset_eclose_eq_arg: "Transset(X) \<Longrightarrow> eclose(X) = X"
 apply (erule equalityI [OF eclose_least arg_subset_eclose])
 apply (rule subset_refl)
 done
 
 text\<open>A transitive set either is empty or contains the empty set.\<close>
 lemma Transset_0_lemma [rule_format]: "Transset(A) \<Longrightarrow> x\<in>A \<longrightarrow> 0\<in>A"
 apply (simp add: Transset_def)
 apply (rule_tac a=x in eps_induct, clarify)
 apply (drule bspec, assumption)
 apply (case_tac "x=0", auto)
 done
 
 lemma Transset_0_disj: "Transset(A) \<Longrightarrow> A=0 | 0\<in>A"
 by (blast dest: Transset_0_lemma)
 
 
 subsection\<open>Epsilon Recursion\<close>
 
 (*Unused...*)
 lemma mem_eclose_trans: "\<lbrakk>A \<in> eclose(B);  B \<in> eclose(C)\<rbrakk> \<Longrightarrow> A \<in> eclose(C)"
 by (rule eclose_least [OF Transset_eclose eclose_subset, THEN subsetD],
     assumption+)
 
 (*Variant of the previous lemma in a useable form for the sequel*)
 lemma mem_eclose_sing_trans:
      "\<lbrakk>A \<in> eclose({B});  B \<in> eclose({C})\<rbrakk> \<Longrightarrow> A \<in> eclose({C})"
 by (rule eclose_least [OF Transset_eclose singleton_subsetI, THEN subsetD],
     assumption+)
 
 lemma under_Memrel: "\<lbrakk>Transset(i);  j \<in> i\<rbrakk> \<Longrightarrow> Memrel(i)-``{j} = j"
 by (unfold Transset_def, blast)
 
 lemma lt_Memrel: "j < i \<Longrightarrow> Memrel(i) -`` {j} = j"
 by (simp add: lt_def Ord_def under_Memrel)
 
 (* @{term"j \<in> eclose(A) \<Longrightarrow> Memrel(eclose(A)) -`` j = j"} *)
 lemmas under_Memrel_eclose = Transset_eclose [THEN under_Memrel]
 
 lemmas wfrec_ssubst = wf_Memrel [THEN wfrec, THEN ssubst]
 
 lemma wfrec_eclose_eq:
     "\<lbrakk>k \<in> eclose({j});  j \<in> eclose({i})\<rbrakk> \<Longrightarrow>
      wfrec(Memrel(eclose({i})), k, H) = wfrec(Memrel(eclose({j})), k, H)"
 apply (erule eclose_induct)
 apply (rule wfrec_ssubst)
 apply (rule wfrec_ssubst)
 apply (simp add: under_Memrel_eclose mem_eclose_sing_trans [of _ j i])
 done
 
 lemma wfrec_eclose_eq2:
     "k \<in> i \<Longrightarrow> wfrec(Memrel(eclose({i})),k,H) = wfrec(Memrel(eclose({k})),k,H)"
 apply (rule arg_in_eclose_sing [THEN wfrec_eclose_eq])
 apply (erule arg_into_eclose_sing)
 done
 
 lemma transrec: "transrec(a,H) = H(a, \<lambda>x\<in>a. transrec(x,H))"
   unfolding transrec_def
 apply (rule wfrec_ssubst)
 apply (simp add: wfrec_eclose_eq2 arg_in_eclose_sing under_Memrel_eclose)
 done
 
 (*Avoids explosions in proofs; resolve it with a meta-level definition.*)
 lemma def_transrec:
     "\<lbrakk>\<And>x. f(x)\<equiv>transrec(x,H)\<rbrakk> \<Longrightarrow> f(a) = H(a, \<lambda>x\<in>a. f(x))"
 apply simp
 apply (rule transrec)
 done
 
 lemma transrec_type:
     "\<lbrakk>\<And>x u. \<lbrakk>x \<in> eclose({a});  u \<in> Pi(x,B)\<rbrakk> \<Longrightarrow> H(x,u) \<in> B(x)\<rbrakk>
      \<Longrightarrow> transrec(a,H) \<in> B(a)"
 apply (rule_tac i = a in arg_in_eclose_sing [THEN eclose_induct])
 apply (subst transrec)
 apply (simp add: lam_type)
 done
 
 lemma eclose_sing_Ord: "Ord(i) \<Longrightarrow> eclose({i}) \<subseteq> succ(i)"
 apply (erule Ord_is_Transset [THEN Transset_succ, THEN eclose_least])
 apply (rule succI1 [THEN singleton_subsetI])
 done
 
 lemma succ_subset_eclose_sing: "succ(i) \<subseteq> eclose({i})"
 apply (insert arg_subset_eclose [of "{i}"], simp)
 apply (frule eclose_subset, blast)
 done
 
 lemma eclose_sing_Ord_eq: "Ord(i) \<Longrightarrow> eclose({i}) = succ(i)"
 apply (rule equalityI)
 apply (erule eclose_sing_Ord)
 apply (rule succ_subset_eclose_sing)
 done
 
 lemma Ord_transrec_type:
   assumes jini: "j \<in> i"
       and ordi: "Ord(i)"
       and minor: " \<And>x u. \<lbrakk>x \<in> i;  u \<in> Pi(x,B)\<rbrakk> \<Longrightarrow> H(x,u) \<in> B(x)"
   shows "transrec(j,H) \<in> B(j)"
 apply (rule transrec_type)
 apply (insert jini ordi)
 apply (blast intro!: minor
              intro: Ord_trans
              dest: Ord_in_Ord [THEN eclose_sing_Ord, THEN subsetD])
 done
 
 subsection\<open>Rank\<close>
 
 (*NOT SUITABLE FOR REWRITING -- RECURSIVE!*)
 lemma rank: "rank(a) = (\<Union>y\<in>a. succ(rank(y)))"
 by (subst rank_def [THEN def_transrec], simp)
 
 lemma Ord_rank [simp]: "Ord(rank(a))"
 apply (rule_tac a=a in eps_induct)
 apply (subst rank)
 apply (rule Ord_succ [THEN Ord_UN])
 apply (erule bspec, assumption)
 done
 
 lemma rank_of_Ord: "Ord(i) \<Longrightarrow> rank(i) = i"
 apply (erule trans_induct)
 apply (subst rank)
 apply (simp add: Ord_equality)
 done
 
 lemma rank_lt: "a \<in> b \<Longrightarrow> rank(a) < rank(b)"
 apply (rule_tac a1 = b in rank [THEN ssubst])
 apply (erule UN_I [THEN ltI])
 apply (rule_tac [2] Ord_UN, auto)
 done
 
 lemma eclose_rank_lt: "a \<in> eclose(b) \<Longrightarrow> rank(a) < rank(b)"
 apply (erule eclose_induct_down)
 apply (erule rank_lt)
 apply (erule rank_lt [THEN lt_trans], assumption)
 done
 
 lemma rank_mono: "a<=b \<Longrightarrow> rank(a) \<le> rank(b)"
 apply (rule subset_imp_le)
 apply (auto simp add: rank [of a] rank [of b])
 done
 
 lemma rank_Pow: "rank(Pow(a)) = succ(rank(a))"
 apply (rule rank [THEN trans])
 apply (rule le_anti_sym)
 apply (rule_tac [2] UN_upper_le)
 apply (rule UN_least_le)
 apply (auto intro: rank_mono simp add: Ord_UN)
 done
 
 lemma rank_0 [simp]: "rank(0) = 0"
 by (rule rank [THEN trans], blast)
 
 lemma rank_succ [simp]: "rank(succ(x)) = succ(rank(x))"
 apply (rule rank [THEN trans])
 apply (rule equalityI [OF UN_least succI1 [THEN UN_upper]])
 apply (erule succE, blast)
 apply (erule rank_lt [THEN leI, THEN succ_leI, THEN le_imp_subset])
 done
 
 lemma rank_Union: "rank(\<Union>(A)) = (\<Union>x\<in>A. rank(x))"
 apply (rule equalityI)
 apply (rule_tac [2] rank_mono [THEN le_imp_subset, THEN UN_least])
 apply (erule_tac [2] Union_upper)
 apply (subst rank)
 apply (rule UN_least)
 apply (erule UnionE)
 apply (rule subset_trans)
 apply (erule_tac [2] RepFunI [THEN Union_upper])
 apply (erule rank_lt [THEN succ_leI, THEN le_imp_subset])
 done
 
 lemma rank_eclose: "rank(eclose(a)) = rank(a)"
 apply (rule le_anti_sym)
 apply (rule_tac [2] arg_subset_eclose [THEN rank_mono])
 apply (rule_tac a1 = "eclose (a) " in rank [THEN ssubst])
 apply (rule Ord_rank [THEN UN_least_le])
 apply (erule eclose_rank_lt [THEN succ_leI])
 done
 
 lemma rank_pair1: "rank(a) < rank(\<langle>a,b\<rangle>)"
   unfolding Pair_def
 apply (rule consI1 [THEN rank_lt, THEN lt_trans])
 apply (rule consI1 [THEN consI2, THEN rank_lt])
 done
 
 lemma rank_pair2: "rank(b) < rank(\<langle>a,b\<rangle>)"
   unfolding Pair_def
 apply (rule consI1 [THEN consI2, THEN rank_lt, THEN lt_trans])
 apply (rule consI1 [THEN consI2, THEN rank_lt])
 done
 
 (*Not clear how to remove the P(a) condition, since the "then" part
   must refer to "a"*)
 lemma the_equality_if:
      "P(a) \<Longrightarrow> (THE x. P(x)) = (if (\<exists>!x. P(x)) then a else 0)"
 by (simp add: the_0 the_equality2)
 
 (*The first premise not only fixs i but ensures @{term"f\<noteq>0"}.
   The second premise is now essential.  Consider otherwise the relation
   r = {\<langle>0,0\<rangle>,\<langle>0,1\<rangle>,\<langle>0,2\<rangle>,...}.  Then f`0 = \<Union>(f``{0}) = \<Union>(nat) = nat,
   whose rank equals that of r.*)
 lemma rank_apply: "\<lbrakk>i \<in> domain(f); function(f)\<rbrakk> \<Longrightarrow> rank(f`i) < rank(f)"
 apply clarify
 apply (simp add: function_apply_equality)
 apply (blast intro: lt_trans rank_lt rank_pair2)
 done
 
 
 subsection\<open>Corollaries of Leastness\<close>
 
 lemma mem_eclose_subset: "A \<in> B \<Longrightarrow> eclose(A)<=eclose(B)"
 apply (rule Transset_eclose [THEN eclose_least])
 apply (erule arg_into_eclose [THEN eclose_subset])
 done
 
 lemma eclose_mono: "A<=B \<Longrightarrow> eclose(A) \<subseteq> eclose(B)"
 apply (rule Transset_eclose [THEN eclose_least])
 apply (erule subset_trans)
 apply (rule arg_subset_eclose)
 done
 
 (** Idempotence of eclose **)
 
 lemma eclose_idem: "eclose(eclose(A)) = eclose(A)"
 apply (rule equalityI)
 apply (rule eclose_least [OF Transset_eclose subset_refl])
 apply (rule arg_subset_eclose)
 done
 
 (** Transfinite recursion for definitions based on the
     three cases of ordinals **)
 
 lemma transrec2_0 [simp]: "transrec2(0,a,b) = a"
 by (rule transrec2_def [THEN def_transrec, THEN trans], simp)
 
 lemma transrec2_succ [simp]: "transrec2(succ(i),a,b) = b(i, transrec2(i,a,b))"
 apply (rule transrec2_def [THEN def_transrec, THEN trans])
 apply (simp add: the_equality if_P)
 done
 
 lemma transrec2_Limit:
      "Limit(i) \<Longrightarrow> transrec2(i,a,b) = (\<Union>j<i. transrec2(j,a,b))"
 apply (rule transrec2_def [THEN def_transrec, THEN trans])
 apply (auto simp add: OUnion_def)
 done
 
 lemma def_transrec2:
      "(\<And>x. f(x)\<equiv>transrec2(x,a,b))
       \<Longrightarrow> f(0) = a \<and>
           f(succ(i)) = b(i, f(i)) \<and>
           (Limit(K) \<longrightarrow> f(K) = (\<Union>j<K. f(j)))"
 by (simp add: transrec2_Limit)
 
 
 (** recursor -- better than nat_rec; the succ case has no type requirement! **)
 
 (*NOT suitable for rewriting*)
 lemmas recursor_lemma = recursor_def [THEN def_transrec, THEN trans]
 
 lemma recursor_0: "recursor(a,b,0) = a"
 by (rule nat_case_0 [THEN recursor_lemma])
 
 lemma recursor_succ: "recursor(a,b,succ(m)) = b(m, recursor(a,b,m))"
 by (rule recursor_lemma, simp)
 
 
 (** rec: old version for compatibility **)
 
 lemma rec_0 [simp]: "rec(0,a,b) = a"
   unfolding rec_def
 apply (rule recursor_0)
 done
 
 lemma rec_succ [simp]: "rec(succ(m),a,b) = b(m, rec(m,a,b))"
   unfolding rec_def
 apply (rule recursor_succ)
 done
 
 lemma rec_type:
     "\<lbrakk>n \<in> nat;
         a \<in> C(0);
         \<And>m z. \<lbrakk>m \<in> nat;  z \<in> C(m)\<rbrakk> \<Longrightarrow> b(m,z): C(succ(m))\<rbrakk>
      \<Longrightarrow> rec(n,a,b) \<in> C(n)"
 by (erule nat_induct, auto)
 
 end
diff --git a/src/ZF/EquivClass.thy b/src/ZF/EquivClass.thy
--- a/src/ZF/EquivClass.thy
+++ b/src/ZF/EquivClass.thy
@@ -1,233 +1,233 @@
 (*  Title:      ZF/EquivClass.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section\<open>Equivalence Relations\<close>
 
 theory EquivClass imports Trancl Perm begin
 
 definition
   quotient   :: "[i,i]\<Rightarrow>i"    (infixl \<open>'/'/\<close> 90)  (*set of equiv classes*)  where
       "A//r \<equiv> {r``{x} . x \<in> A}"
 
 definition
   congruent  :: "[i,i\<Rightarrow>i]\<Rightarrow>o"  where
       "congruent(r,b) \<equiv> \<forall>y z. \<langle>y,z\<rangle>:r \<longrightarrow> b(y)=b(z)"
 
 definition
   congruent2 :: "[i,i,[i,i]\<Rightarrow>i]\<Rightarrow>o"  where
       "congruent2(r1,r2,b) \<equiv> \<forall>y1 z1 y2 z2.
            \<langle>y1,z1\<rangle>:r1 \<longrightarrow> \<langle>y2,z2\<rangle>:r2 \<longrightarrow> b(y1,y2) = b(z1,z2)"
 
 abbreviation
   RESPECTS ::"[i\<Rightarrow>i, i] \<Rightarrow> o"  (infixr \<open>respects\<close> 80) where
   "f respects r \<equiv> congruent(r,f)"
 
 abbreviation
   RESPECTS2 ::"[i\<Rightarrow>i\<Rightarrow>i, i] \<Rightarrow> o"  (infixr \<open>respects2 \<close> 80) where
   "f respects2 r \<equiv> congruent2(r,r,f)"
     \<comment> \<open>Abbreviation for the common case where the relations are identical\<close>
 
 
 subsection\<open>Suppes, Theorem 70:
     \<^term>\<open>r\<close> is an equiv relation iff \<^term>\<open>converse(r) O r = r\<close>\<close>
 
 (** first half: equiv(A,r) \<Longrightarrow> converse(r) O r = r **)
 
 lemma sym_trans_comp_subset:
     "\<lbrakk>sym(r); trans(r)\<rbrakk> \<Longrightarrow> converse(r) O r \<subseteq> r"
 by (unfold trans_def sym_def, blast)
 
 lemma refl_comp_subset:
     "\<lbrakk>refl(A,r); r \<subseteq> A*A\<rbrakk> \<Longrightarrow> r \<subseteq> converse(r) O r"
 by (unfold refl_def, blast)
 
 lemma equiv_comp_eq:
     "equiv(A,r) \<Longrightarrow> converse(r) O r = r"
   unfolding equiv_def
 apply (blast del: subsetI intro!: sym_trans_comp_subset refl_comp_subset)
 done
 
 (*second half*)
 lemma comp_equivI:
     "\<lbrakk>converse(r) O r = r;  domain(r) = A\<rbrakk> \<Longrightarrow> equiv(A,r)"
-apply (unfold equiv_def refl_def sym_def trans_def)
+  unfolding equiv_def refl_def sym_def trans_def
 apply (erule equalityE)
 apply (subgoal_tac "\<forall>x y. \<langle>x,y\<rangle> \<in> r \<longrightarrow> \<langle>y,x\<rangle> \<in> r", blast+)
 done
 
 (** Equivalence classes **)
 
 (*Lemma for the next result*)
 lemma equiv_class_subset:
     "\<lbrakk>sym(r);  trans(r);  \<langle>a,b\<rangle>: r\<rbrakk> \<Longrightarrow> r``{a} \<subseteq> r``{b}"
 by (unfold trans_def sym_def, blast)
 
 lemma equiv_class_eq:
     "\<lbrakk>equiv(A,r);  \<langle>a,b\<rangle>: r\<rbrakk> \<Longrightarrow> r``{a} = r``{b}"
   unfolding equiv_def
 apply (safe del: subsetI intro!: equalityI equiv_class_subset)
 apply (unfold sym_def, blast)
 done
 
 lemma equiv_class_self:
     "\<lbrakk>equiv(A,r);  a \<in> A\<rbrakk> \<Longrightarrow> a \<in> r``{a}"
 by (unfold equiv_def refl_def, blast)
 
 (*Lemma for the next result*)
 lemma subset_equiv_class:
     "\<lbrakk>equiv(A,r);  r``{b} \<subseteq> r``{a};  b \<in> A\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle>: r"
 by (unfold equiv_def refl_def, blast)
 
 lemma eq_equiv_class: "\<lbrakk>r``{a} = r``{b};  equiv(A,r);  b \<in> A\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle>: r"
 by (assumption | rule equalityD2 subset_equiv_class)+
 
 (*thus r``{a} = r``{b} as well*)
 lemma equiv_class_nondisjoint:
     "\<lbrakk>equiv(A,r);  x: (r``{a} \<inter> r``{b})\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle>: r"
 by (unfold equiv_def trans_def sym_def, blast)
 
 lemma equiv_type: "equiv(A,r) \<Longrightarrow> r \<subseteq> A*A"
 by (unfold equiv_def, blast)
 
 lemma equiv_class_eq_iff:
      "equiv(A,r) \<Longrightarrow> \<langle>x,y\<rangle>: r \<longleftrightarrow> r``{x} = r``{y} \<and> x \<in> A \<and> y \<in> A"
 by (blast intro: eq_equiv_class equiv_class_eq dest: equiv_type)
 
 lemma eq_equiv_class_iff:
      "\<lbrakk>equiv(A,r);  x \<in> A;  y \<in> A\<rbrakk> \<Longrightarrow> r``{x} = r``{y} \<longleftrightarrow> \<langle>x,y\<rangle>: r"
 by (blast intro: eq_equiv_class equiv_class_eq dest: equiv_type)
 
 (*** Quotients ***)
 
 (** Introduction/elimination rules -- needed? **)
 
 lemma quotientI [TC]: "x \<in> A \<Longrightarrow> r``{x}: A//r"
   unfolding quotient_def
 apply (erule RepFunI)
 done
 
 lemma quotientE:
     "\<lbrakk>X \<in> A//r;  \<And>x. \<lbrakk>X = r``{x};  x \<in> A\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
 by (unfold quotient_def, blast)
 
 lemma Union_quotient:
     "equiv(A,r) \<Longrightarrow> \<Union>(A//r) = A"
 by (unfold equiv_def refl_def quotient_def, blast)
 
 lemma quotient_disj:
     "\<lbrakk>equiv(A,r);  X \<in> A//r;  Y \<in> A//r\<rbrakk> \<Longrightarrow> X=Y | (X \<inter> Y \<subseteq> 0)"
   unfolding quotient_def
 apply (safe intro!: equiv_class_eq, assumption)
 apply (unfold equiv_def trans_def sym_def, blast)
 done
 
 subsection\<open>Defining Unary Operations upon Equivalence Classes\<close>
 
 (** Could have a locale with the premises equiv(A,r)  and  congruent(r,b)
 **)
 
 (*Conversion rule*)
 lemma UN_equiv_class:
     "\<lbrakk>equiv(A,r);  b respects r;  a \<in> A\<rbrakk> \<Longrightarrow> (\<Union>x\<in>r``{a}. b(x)) = b(a)"
 apply (subgoal_tac "\<forall>x \<in> r``{a}. b(x) = b(a)")
  apply simp
  apply (blast intro: equiv_class_self)
 apply (unfold equiv_def sym_def congruent_def, blast)
 done
 
 (*type checking of  @{term"\<Union>x\<in>r``{a}. b(x)"} *)
 lemma UN_equiv_class_type:
     "\<lbrakk>equiv(A,r);  b respects r;  X \<in> A//r;  \<And>x.  x \<in> A \<Longrightarrow> b(x) \<in> B\<rbrakk>
      \<Longrightarrow> (\<Union>x\<in>X. b(x)) \<in> B"
 apply (unfold quotient_def, safe)
 apply (simp (no_asm_simp) add: UN_equiv_class)
 done
 
 (*Sufficient conditions for injectiveness.  Could weaken premises!
   major premise could be an inclusion; bcong could be \<And>y. y \<in> A \<Longrightarrow> b(y):B
 *)
 lemma UN_equiv_class_inject:
     "\<lbrakk>equiv(A,r);   b respects r;
         (\<Union>x\<in>X. b(x))=(\<Union>y\<in>Y. b(y));  X \<in> A//r;  Y \<in> A//r;
         \<And>x y. \<lbrakk>x \<in> A; y \<in> A; b(x)=b(y)\<rbrakk> \<Longrightarrow> \<langle>x,y\<rangle>:r\<rbrakk>
      \<Longrightarrow> X=Y"
 apply (unfold quotient_def, safe)
 apply (rule equiv_class_eq, assumption)
 apply (simp add: UN_equiv_class [of A r b])
 done
 
 
 subsection\<open>Defining Binary Operations upon Equivalence Classes\<close>
 
 lemma congruent2_implies_congruent:
     "\<lbrakk>equiv(A,r1);  congruent2(r1,r2,b);  a \<in> A\<rbrakk> \<Longrightarrow> congruent(r2,b(a))"
 by (unfold congruent_def congruent2_def equiv_def refl_def, blast)
 
 lemma congruent2_implies_congruent_UN:
     "\<lbrakk>equiv(A1,r1);  equiv(A2,r2);  congruent2(r1,r2,b);  a \<in> A2\<rbrakk> \<Longrightarrow>
      congruent(r1, \<lambda>x1. \<Union>x2 \<in> r2``{a}. b(x1,x2))"
 apply (unfold congruent_def, safe)
 apply (frule equiv_type [THEN subsetD], assumption)
 apply clarify
 apply (simp add: UN_equiv_class congruent2_implies_congruent)
 apply (unfold congruent2_def equiv_def refl_def, blast)
 done
 
 lemma UN_equiv_class2:
     "\<lbrakk>equiv(A1,r1);  equiv(A2,r2);  congruent2(r1,r2,b);  a1: A1;  a2: A2\<rbrakk>
      \<Longrightarrow> (\<Union>x1 \<in> r1``{a1}. \<Union>x2 \<in> r2``{a2}. b(x1,x2)) = b(a1,a2)"
 by (simp add: UN_equiv_class congruent2_implies_congruent
               congruent2_implies_congruent_UN)
 
 (*type checking*)
 lemma UN_equiv_class_type2:
     "\<lbrakk>equiv(A,r);  b respects2 r;
         X1: A//r;  X2: A//r;
         \<And>x1 x2.  \<lbrakk>x1: A; x2: A\<rbrakk> \<Longrightarrow> b(x1,x2) \<in> B
 \<rbrakk> \<Longrightarrow> (\<Union>x1\<in>X1. \<Union>x2\<in>X2. b(x1,x2)) \<in> B"
 apply (unfold quotient_def, safe)
 apply (blast intro: UN_equiv_class_type congruent2_implies_congruent_UN
                     congruent2_implies_congruent quotientI)
 done
 
 
 (*Suggested by John Harrison -- the two subproofs may be MUCH simpler
   than the direct proof*)
 lemma congruent2I:
     "\<lbrakk>equiv(A1,r1);  equiv(A2,r2);
         \<And>y z w. \<lbrakk>w \<in> A2;  \<langle>y,z\<rangle> \<in> r1\<rbrakk> \<Longrightarrow> b(y,w) = b(z,w);
         \<And>y z w. \<lbrakk>w \<in> A1;  \<langle>y,z\<rangle> \<in> r2\<rbrakk> \<Longrightarrow> b(w,y) = b(w,z)
 \<rbrakk> \<Longrightarrow> congruent2(r1,r2,b)"
 apply (unfold congruent2_def equiv_def refl_def, safe)
 apply (blast intro: trans)
 done
 
 lemma congruent2_commuteI:
  assumes equivA: "equiv(A,r)"
      and commute: "\<And>y z. \<lbrakk>y \<in> A;  z \<in> A\<rbrakk> \<Longrightarrow> b(y,z) = b(z,y)"
      and congt:   "\<And>y z w. \<lbrakk>w \<in> A;  \<langle>y,z\<rangle>: r\<rbrakk> \<Longrightarrow> b(w,y) = b(w,z)"
  shows "b respects2 r"
 apply (insert equivA [THEN equiv_type, THEN subsetD])
 apply (rule congruent2I [OF equivA equivA])
 apply (rule commute [THEN trans])
 apply (rule_tac [3] commute [THEN trans, symmetric])
 apply (rule_tac [5] sym)
 apply (blast intro: congt)+
 done
 
 (*Obsolete?*)
 lemma congruent_commuteI:
     "\<lbrakk>equiv(A,r);  Z \<in> A//r;
         \<And>w. \<lbrakk>w \<in> A\<rbrakk> \<Longrightarrow> congruent(r, \<lambda>z. b(w,z));
         \<And>x y. \<lbrakk>x \<in> A;  y \<in> A\<rbrakk> \<Longrightarrow> b(y,x) = b(x,y)
 \<rbrakk> \<Longrightarrow> congruent(r, \<lambda>w. \<Union>z\<in>Z. b(w,z))"
 apply (simp (no_asm) add: congruent_def)
 apply (safe elim!: quotientE)
 apply (frule equiv_type [THEN subsetD], assumption)
 apply (simp add: UN_equiv_class [of A r])
 apply (simp add: congruent_def)
 done
 
 end
diff --git a/src/ZF/Finite.thy b/src/ZF/Finite.thy
--- a/src/ZF/Finite.thy
+++ b/src/ZF/Finite.thy
@@ -1,209 +1,209 @@
 (*  Title:      ZF/Finite.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 
 prove:  b \<in> Fin(A) \<Longrightarrow> inj(b,b) \<subseteq> surj(b,b)
 *)
 
 section\<open>Finite Powerset Operator and Finite Function Space\<close>
 
 theory Finite imports Inductive Epsilon Nat begin
 
 (*The natural numbers as a datatype*)
 rep_datatype
   elimination    natE
   induction      nat_induct
   case_eqns      nat_case_0 nat_case_succ
   recursor_eqns  recursor_0 recursor_succ
 
 
 consts
   Fin       :: "i\<Rightarrow>i"
   FiniteFun :: "[i,i]\<Rightarrow>i"         (\<open>(_ -||>/ _)\<close> [61, 60] 60)
 
 inductive
   domains   "Fin(A)" \<subseteq> "Pow(A)"
   intros
     emptyI:  "0 \<in> Fin(A)"
     consI:   "\<lbrakk>a \<in> A;  b \<in> Fin(A)\<rbrakk> \<Longrightarrow> cons(a,b) \<in> Fin(A)"
   type_intros  empty_subsetI cons_subsetI PowI
   type_elims   PowD [elim_format]
 
 inductive
   domains   "FiniteFun(A,B)" \<subseteq> "Fin(A*B)"
   intros
     emptyI:  "0 \<in> A -||> B"
     consI:   "\<lbrakk>a \<in> A;  b \<in> B;  h \<in> A -||> B;  a \<notin> domain(h)\<rbrakk>
               \<Longrightarrow> cons(\<langle>a,b\<rangle>,h) \<in> A -||> B"
   type_intros Fin.intros
 
 
 subsection \<open>Finite Powerset Operator\<close>
 
 lemma Fin_mono: "A<=B \<Longrightarrow> Fin(A) \<subseteq> Fin(B)"
-apply (unfold Fin.defs)
+  unfolding Fin.defs
 apply (rule lfp_mono)
 apply (rule Fin.bnd_mono)+
 apply blast
 done
 
 (* @{term"A \<in> Fin(B) \<Longrightarrow> A \<subseteq> B"} *)
 lemmas FinD = Fin.dom_subset [THEN subsetD, THEN PowD]
 
 (** Induction on finite sets **)
 
 (*Discharging @{term"x\<notin>y"} entails extra work*)
 lemma Fin_induct [case_names 0 cons, induct set: Fin]:
     "\<lbrakk>b \<in> Fin(A);
         P(0);
         \<And>x y. \<lbrakk>x \<in> A;  y \<in> Fin(A);  x\<notin>y;  P(y)\<rbrakk> \<Longrightarrow> P(cons(x,y))
 \<rbrakk> \<Longrightarrow> P(b)"
 apply (erule Fin.induct, simp)
 apply (case_tac "a \<in> b")
  apply (erule cons_absorb [THEN ssubst], assumption) (*backtracking!*)
 apply simp
 done
 
 
 (** Simplification for Fin **)
 declare Fin.intros [simp]
 
 lemma Fin_0: "Fin(0) = {0}"
 by (blast intro: Fin.emptyI dest: FinD)
 
 (*The union of two finite sets is finite.*)
 lemma Fin_UnI [simp]: "\<lbrakk>b \<in> Fin(A);  c \<in> Fin(A)\<rbrakk> \<Longrightarrow> b \<union> c \<in> Fin(A)"
 apply (erule Fin_induct)
 apply (simp_all add: Un_cons)
 done
 
 
 (*The union of a set of finite sets is finite.*)
 lemma Fin_UnionI: "C \<in> Fin(Fin(A)) \<Longrightarrow> \<Union>(C) \<in> Fin(A)"
 by (erule Fin_induct, simp_all)
 
 (*Every subset of a finite set is finite.*)
 lemma Fin_subset_lemma [rule_format]: "b \<in> Fin(A) \<Longrightarrow> \<forall>z. z<=b \<longrightarrow> z \<in> Fin(A)"
 apply (erule Fin_induct)
 apply (simp add: subset_empty_iff)
 apply (simp add: subset_cons_iff distrib_simps, safe)
 apply (erule_tac b = z in cons_Diff [THEN subst], simp)
 done
 
 lemma Fin_subset: "\<lbrakk>c<=b;  b \<in> Fin(A)\<rbrakk> \<Longrightarrow> c \<in> Fin(A)"
 by (blast intro: Fin_subset_lemma)
 
 lemma Fin_IntI1 [intro,simp]: "b \<in> Fin(A) \<Longrightarrow> b \<inter> c \<in> Fin(A)"
 by (blast intro: Fin_subset)
 
 lemma Fin_IntI2 [intro,simp]: "c \<in> Fin(A) \<Longrightarrow> b \<inter> c \<in> Fin(A)"
 by (blast intro: Fin_subset)
 
 lemma Fin_0_induct_lemma [rule_format]:
     "\<lbrakk>c \<in> Fin(A);  b \<in> Fin(A); P(b);
         \<And>x y. \<lbrakk>x \<in> A;  y \<in> Fin(A);  x \<in> y;  P(y)\<rbrakk> \<Longrightarrow> P(y-{x})
 \<rbrakk> \<Longrightarrow> c<=b \<longrightarrow> P(b-c)"
 apply (erule Fin_induct, simp)
 apply (subst Diff_cons)
 apply (simp add: cons_subset_iff Diff_subset [THEN Fin_subset])
 done
 
 lemma Fin_0_induct:
     "\<lbrakk>b \<in> Fin(A);
         P(b);
         \<And>x y. \<lbrakk>x \<in> A;  y \<in> Fin(A);  x \<in> y;  P(y)\<rbrakk> \<Longrightarrow> P(y-{x})
 \<rbrakk> \<Longrightarrow> P(0)"
 apply (rule Diff_cancel [THEN subst])
 apply (blast intro: Fin_0_induct_lemma)
 done
 
 (*Functions from a finite ordinal*)
 lemma nat_fun_subset_Fin: "n \<in> nat \<Longrightarrow> n->A \<subseteq> Fin(nat*A)"
 apply (induct_tac "n")
 apply (simp add: subset_iff)
 apply (simp add: succ_def mem_not_refl [THEN cons_fun_eq])
 apply (fast intro!: Fin.consI)
 done
 
 
 subsection\<open>Finite Function Space\<close>
 
 lemma FiniteFun_mono:
     "\<lbrakk>A<=C;  B<=D\<rbrakk> \<Longrightarrow> A -||> B  \<subseteq>  C -||> D"
-apply (unfold FiniteFun.defs)
+  unfolding FiniteFun.defs
 apply (rule lfp_mono)
 apply (rule FiniteFun.bnd_mono)+
 apply (intro Fin_mono Sigma_mono basic_monos, assumption+)
 done
 
 lemma FiniteFun_mono1: "A<=B \<Longrightarrow> A -||> A  \<subseteq>  B -||> B"
 by (blast dest: FiniteFun_mono)
 
 lemma FiniteFun_is_fun: "h \<in> A -||>B \<Longrightarrow> h \<in> domain(h) -> B"
 apply (erule FiniteFun.induct, simp)
 apply (simp add: fun_extend3)
 done
 
 lemma FiniteFun_domain_Fin: "h \<in> A -||>B \<Longrightarrow> domain(h) \<in> Fin(A)"
 by (erule FiniteFun.induct, simp, simp)
 
 lemmas FiniteFun_apply_type = FiniteFun_is_fun [THEN apply_type]
 
 (*Every subset of a finite function is a finite function.*)
 lemma FiniteFun_subset_lemma [rule_format]:
      "b \<in> A-||>B \<Longrightarrow> \<forall>z. z<=b \<longrightarrow> z \<in> A-||>B"
 apply (erule FiniteFun.induct)
 apply (simp add: subset_empty_iff FiniteFun.intros)
 apply (simp add: subset_cons_iff distrib_simps, safe)
 apply (erule_tac b = z in cons_Diff [THEN subst])
 apply (drule spec [THEN mp], assumption)
 apply (fast intro!: FiniteFun.intros)
 done
 
 lemma FiniteFun_subset: "\<lbrakk>c<=b;  b \<in> A-||>B\<rbrakk> \<Longrightarrow> c \<in> A-||>B"
 by (blast intro: FiniteFun_subset_lemma)
 
 (** Some further results by Sidi O. Ehmety **)
 
 lemma fun_FiniteFunI [rule_format]: "A \<in> Fin(X) \<Longrightarrow> \<forall>f. f \<in> A->B \<longrightarrow> f \<in> A-||>B"
 apply (erule Fin.induct)
  apply (simp add: FiniteFun.intros, clarify)
 apply (case_tac "a \<in> b")
  apply (simp add: cons_absorb)
 apply (subgoal_tac "restrict (f,b) \<in> b -||> B")
  prefer 2 apply (blast intro: restrict_type2)
 apply (subst fun_cons_restrict_eq, assumption)
 apply (simp add: restrict_def lam_def)
 apply (blast intro: apply_funtype FiniteFun.intros
                     FiniteFun_mono [THEN [2] rev_subsetD])
 done
 
 lemma lam_FiniteFun: "A \<in> Fin(X) \<Longrightarrow> (\<lambda>x\<in>A. b(x)) \<in> A -||> {b(x). x \<in> A}"
 by (blast intro: fun_FiniteFunI lam_funtype)
 
 lemma FiniteFun_Collect_iff:
      "f \<in> FiniteFun(A, {y \<in> B. P(y)})
       \<longleftrightarrow> f \<in> FiniteFun(A,B) \<and> (\<forall>x\<in>domain(f). P(f`x))"
 apply auto
 apply (blast intro: FiniteFun_mono [THEN [2] rev_subsetD])
 apply (blast dest: Pair_mem_PiD FiniteFun_is_fun)
 apply (rule_tac A1="domain(f)" in
        subset_refl [THEN [2] FiniteFun_mono, THEN subsetD])
  apply (fast dest: FiniteFun_domain_Fin Fin.dom_subset [THEN subsetD])
 apply (rule fun_FiniteFunI)
 apply (erule FiniteFun_domain_Fin)
 apply (rule_tac B = "range (f) " in fun_weaken_type)
  apply (blast dest: FiniteFun_is_fun range_of_fun range_type apply_equality)+
 done
 
 
 subsection\<open>The Contents of a Singleton Set\<close>
 
 definition
   contents :: "i\<Rightarrow>i"  where
    "contents(X) \<equiv> THE x. X = {x}"
 
 lemma contents_eq [simp]: "contents ({x}) = x"
 by (simp add: contents_def)
 
 end
diff --git a/src/ZF/Induct/Binary_Trees.thy b/src/ZF/Induct/Binary_Trees.thy
--- a/src/ZF/Induct/Binary_Trees.thy
+++ b/src/ZF/Induct/Binary_Trees.thy
@@ -1,138 +1,138 @@
 (*  Title:      ZF/Induct/Binary_Trees.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1992  University of Cambridge
 *)
 
 section \<open>Binary trees\<close>
 
 theory Binary_Trees imports ZF begin
 
 subsection \<open>Datatype definition\<close>
 
 consts
   bt :: "i \<Rightarrow> i"
 
 datatype "bt(A)" =
   Lf | Br ("a \<in> A", "t1 \<in> bt(A)", "t2 \<in> bt(A)")
 
 declare bt.intros [simp]
 
 lemma Br_neq_left: "l \<in> bt(A) \<Longrightarrow> Br(x, l, r) \<noteq> l"
   by (induct arbitrary: x r set: bt) auto
 
 lemma Br_iff: "Br(a, l, r) = Br(a', l', r') \<longleftrightarrow> a = a' \<and> l = l' \<and> r = r'"
   \<comment> \<open>Proving a freeness theorem.\<close>
   by (fast elim!: bt.free_elims)
 
 inductive_cases BrE: "Br(a, l, r) \<in> bt(A)"
   \<comment> \<open>An elimination rule, for type-checking.\<close>
 
 text \<open>
   \medskip Lemmas to justify using \<^term>\<open>bt\<close> in other recursive type
   definitions.
 \<close>
 
 lemma bt_mono: "A \<subseteq> B \<Longrightarrow> bt(A) \<subseteq> bt(B)"
-  apply (unfold bt.defs)
+    unfolding bt.defs
   apply (rule lfp_mono)
     apply (rule bt.bnd_mono)+
   apply (rule univ_mono basic_monos | assumption)+
   done
 
 lemma bt_univ: "bt(univ(A)) \<subseteq> univ(A)"
-  apply (unfold bt.defs bt.con_defs)
+    unfolding bt.defs bt.con_defs
   apply (rule lfp_lowerbound)
    apply (rule_tac [2] A_subset_univ [THEN univ_mono])
   apply (fast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
   done
 
 lemma bt_subset_univ: "A \<subseteq> univ(B) \<Longrightarrow> bt(A) \<subseteq> univ(B)"
   apply (rule subset_trans)
    apply (erule bt_mono)
   apply (rule bt_univ)
   done
 
 lemma bt_rec_type:
   "\<lbrakk>t \<in> bt(A);
     c \<in> C(Lf);
     \<And>x y z r s. \<lbrakk>x \<in> A;  y \<in> bt(A);  z \<in> bt(A);  r \<in> C(y);  s \<in> C(z)\<rbrakk> \<Longrightarrow>
     h(x, y, z, r, s) \<in> C(Br(x, y, z))
 \<rbrakk> \<Longrightarrow> bt_rec(c, h, t) \<in> C(t)"
   \<comment> \<open>Type checking for recursor -- example only; not really needed.\<close>
   apply (induct_tac t)
    apply simp_all
   done
 
 
 subsection \<open>Number of nodes, with an example of tail-recursion\<close>
 
 consts  n_nodes :: "i \<Rightarrow> i"
 primrec
   "n_nodes(Lf) = 0"
   "n_nodes(Br(a, l, r)) = succ(n_nodes(l) #+ n_nodes(r))"
 
 lemma n_nodes_type [simp]: "t \<in> bt(A) \<Longrightarrow> n_nodes(t) \<in> nat"
   by (induct set: bt) auto
 
 consts  n_nodes_aux :: "i \<Rightarrow> i"
 primrec
   "n_nodes_aux(Lf) = (\<lambda>k \<in> nat. k)"
   "n_nodes_aux(Br(a, l, r)) =
       (\<lambda>k \<in> nat. n_nodes_aux(r) `  (n_nodes_aux(l) ` succ(k)))"
 
 lemma n_nodes_aux_eq:
     "t \<in> bt(A) \<Longrightarrow> k \<in> nat \<Longrightarrow> n_nodes_aux(t)`k = n_nodes(t) #+ k"
   apply (induct arbitrary: k set: bt)
    apply simp
   apply (atomize, simp)
   done
 
 definition
   n_nodes_tail :: "i \<Rightarrow> i"  where
   "n_nodes_tail(t) \<equiv> n_nodes_aux(t) ` 0"
 
 lemma "t \<in> bt(A) \<Longrightarrow> n_nodes_tail(t) = n_nodes(t)"
   by (simp add: n_nodes_tail_def n_nodes_aux_eq)
 
 
 subsection \<open>Number of leaves\<close>
 
 consts
   n_leaves :: "i \<Rightarrow> i"
 primrec
   "n_leaves(Lf) = 1"
   "n_leaves(Br(a, l, r)) = n_leaves(l) #+ n_leaves(r)"
 
 lemma n_leaves_type [simp]: "t \<in> bt(A) \<Longrightarrow> n_leaves(t) \<in> nat"
   by (induct set: bt) auto
 
 
 subsection \<open>Reflecting trees\<close>
 
 consts
   bt_reflect :: "i \<Rightarrow> i"
 primrec
   "bt_reflect(Lf) = Lf"
   "bt_reflect(Br(a, l, r)) = Br(a, bt_reflect(r), bt_reflect(l))"
 
 lemma bt_reflect_type [simp]: "t \<in> bt(A) \<Longrightarrow> bt_reflect(t) \<in> bt(A)"
   by (induct set: bt) auto
 
 text \<open>
   \medskip Theorems about \<^term>\<open>n_leaves\<close>.
 \<close>
 
 lemma n_leaves_reflect: "t \<in> bt(A) \<Longrightarrow> n_leaves(bt_reflect(t)) = n_leaves(t)"
   by (induct set: bt) (simp_all add: add_commute)
 
 lemma n_leaves_nodes: "t \<in> bt(A) \<Longrightarrow> n_leaves(t) = succ(n_nodes(t))"
   by (induct set: bt) simp_all
 
 text \<open>
   Theorems about \<^term>\<open>bt_reflect\<close>.
 \<close>
 
 lemma bt_reflect_bt_reflect_ident: "t \<in> bt(A) \<Longrightarrow> bt_reflect(bt_reflect(t)) = t"
   by (induct set: bt) simp_all
 
 end
diff --git a/src/ZF/Induct/Datatypes.thy b/src/ZF/Induct/Datatypes.thy
--- a/src/ZF/Induct/Datatypes.thy
+++ b/src/ZF/Induct/Datatypes.thy
@@ -1,71 +1,71 @@
 (*  Title:      ZF/Induct/Datatypes.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section \<open>Sample datatype definitions\<close>
 
 theory Datatypes imports ZF begin
 
 subsection \<open>A type with four constructors\<close>
 
 text \<open>
   It has four contructors, of arities 0--3, and two parameters \<open>A\<close> and \<open>B\<close>.
 \<close>
 
 consts
   data :: "[i, i] \<Rightarrow> i"
 
 datatype "data(A, B)" =
     Con0
   | Con1 ("a \<in> A")
   | Con2 ("a \<in> A", "b \<in> B")
   | Con3 ("a \<in> A", "b \<in> B", "d \<in> data(A, B)")
 
 lemma data_unfold: "data(A, B) = ({0} + A) + (A \<times> B + A \<times> B \<times> data(A, B))"
   by (fast intro!: data.intros [unfolded data.con_defs]
     elim: data.cases [unfolded data.con_defs])
 
 text \<open>
   \medskip Lemmas to justify using \<^term>\<open>data\<close> in other recursive
   type definitions.
 \<close>
 
 lemma data_mono: "\<lbrakk>A \<subseteq> C; B \<subseteq> D\<rbrakk> \<Longrightarrow> data(A, B) \<subseteq> data(C, D)"
-  apply (unfold data.defs)
+    unfolding data.defs
   apply (rule lfp_mono)
    apply (rule data.bnd_mono)+
   apply (rule univ_mono Un_mono basic_monos | assumption)+
   done
 
 lemma data_univ: "data(univ(A), univ(A)) \<subseteq> univ(A)"
-  apply (unfold data.defs data.con_defs)
+    unfolding data.defs data.con_defs
   apply (rule lfp_lowerbound)
    apply (rule_tac [2] subset_trans [OF A_subset_univ Un_upper1, THEN univ_mono])
   apply (fast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
   done
 
 lemma data_subset_univ:
     "\<lbrakk>A \<subseteq> univ(C); B \<subseteq> univ(C)\<rbrakk> \<Longrightarrow> data(A, B) \<subseteq> univ(C)"
   by (rule subset_trans [OF data_mono data_univ])
 
 
 subsection \<open>Example of a big enumeration type\<close>
 
 text \<open>
   Can go up to at least 100 constructors, but it takes nearly 7
   minutes \dots\ (back in 1994 that is).
 \<close>
 
 consts
   enum :: i
 
 datatype enum =
     C00 | C01 | C02 | C03 | C04 | C05 | C06 | C07 | C08 | C09
   | C10 | C11 | C12 | C13 | C14 | C15 | C16 | C17 | C18 | C19
   | C20 | C21 | C22 | C23 | C24 | C25 | C26 | C27 | C28 | C29
   | C30 | C31 | C32 | C33 | C34 | C35 | C36 | C37 | C38 | C39
   | C40 | C41 | C42 | C43 | C44 | C45 | C46 | C47 | C48 | C49
   | C50 | C51 | C52 | C53 | C54 | C55 | C56 | C57 | C58 | C59
 
 end
diff --git a/src/ZF/Induct/ListN.thy b/src/ZF/Induct/ListN.thy
--- a/src/ZF/Induct/ListN.thy
+++ b/src/ZF/Induct/ListN.thy
@@ -1,61 +1,61 @@
 (*  Title:      ZF/Induct/ListN.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section \<open>Lists of n elements\<close>
 
 theory ListN imports ZF begin
 
 text \<open>
   Inductive definition of lists of \<open>n\<close> elements; see
   @{cite "paulin-tlca"}.
 \<close>
 
 consts listn :: "i\<Rightarrow>i"
 inductive
   domains "listn(A)" \<subseteq> "nat \<times> list(A)"
   intros
     NilI: "\<langle>0,Nil\<rangle> \<in> listn(A)"
     ConsI: "\<lbrakk>a \<in> A; \<langle>n,l\<rangle> \<in> listn(A)\<rbrakk> \<Longrightarrow> <succ(n), Cons(a,l)> \<in> listn(A)"
   type_intros nat_typechecks list.intros
 
 
 lemma list_into_listn: "l \<in> list(A) \<Longrightarrow> <length(l),l> \<in> listn(A)"
   by (induct set: list) (simp_all add: listn.intros)
 
 lemma listn_iff: "\<langle>n,l\<rangle> \<in> listn(A) \<longleftrightarrow> l \<in> list(A) \<and> length(l)=n"
   apply (rule iffI)
    apply (erule listn.induct)
     apply auto
   apply (blast intro: list_into_listn)
   done
 
 lemma listn_image_eq: "listn(A)``{n} = {l \<in> list(A). length(l)=n}"
   apply (rule equality_iffI)
   apply (simp add: listn_iff separation image_singleton_iff)
   done
 
 lemma listn_mono: "A \<subseteq> B \<Longrightarrow> listn(A) \<subseteq> listn(B)"
-  apply (unfold listn.defs)
+    unfolding listn.defs
   apply (rule lfp_mono)
     apply (rule listn.bnd_mono)+
   apply (assumption | rule univ_mono Sigma_mono list_mono basic_monos)+
   done
 
 lemma listn_append:
     "\<lbrakk>\<langle>n,l\<rangle> \<in> listn(A); <n',l'> \<in> listn(A)\<rbrakk> \<Longrightarrow> <n#+n', l@l'> \<in> listn(A)"
   apply (erule listn.induct)
    apply (frule listn.dom_subset [THEN subsetD])
    apply (simp_all add: listn.intros)
   done
 
 inductive_cases
       Nil_listn_case: "\<langle>i,Nil\<rangle> \<in> listn(A)"
   and Cons_listn_case: "<i,Cons(x,l)> \<in> listn(A)"
 
 inductive_cases
       zero_listn_case: "\<langle>0,l\<rangle> \<in> listn(A)"
   and succ_listn_case: "<succ(i),l> \<in> listn(A)"
 
 end
diff --git a/src/ZF/Induct/Multiset.thy b/src/ZF/Induct/Multiset.thy
--- a/src/ZF/Induct/Multiset.thy
+++ b/src/ZF/Induct/Multiset.thy
@@ -1,1294 +1,1294 @@
 (*  Title:      ZF/Induct/Multiset.thy
     Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
 
 A definitional theory of multisets,
 including a wellfoundedness proof for the multiset order.
 
 The theory features ordinal multisets and the usual ordering.
 *)
 
 theory Multiset
 imports FoldSet Acc
 begin
 
 abbreviation (input)
   \<comment> \<open>Short cut for multiset space\<close>
   Mult :: "i\<Rightarrow>i" where
   "Mult(A) \<equiv> A -||> nat-{0}"
 
 definition
   (* This is the original "restrict" from ZF.thy.
      Restricts the function f to the domain A
      FIXME: adapt Multiset to the new "restrict". *)
   funrestrict :: "[i,i] \<Rightarrow> i"  where
   "funrestrict(f,A) \<equiv> \<lambda>x \<in> A. f`x"
 
 definition
   (* M is a multiset *)
   multiset :: "i \<Rightarrow> o"  where
   "multiset(M) \<equiv> \<exists>A. M \<in> A -> nat-{0} \<and> Finite(A)"
 
 definition
   mset_of :: "i\<Rightarrow>i"  where
   "mset_of(M) \<equiv> domain(M)"
 
 definition
   munion    :: "[i, i] \<Rightarrow> i" (infixl \<open>+#\<close> 65)  where
   "M +# N \<equiv> \<lambda>x \<in> mset_of(M) \<union> mset_of(N).
      if x \<in> mset_of(M) \<inter> mset_of(N) then  (M`x) #+ (N`x)
      else (if x \<in> mset_of(M) then M`x else N`x)"
 
 definition
   (*convert a function to a multiset by eliminating 0*)
   normalize :: "i \<Rightarrow> i"  where
   "normalize(f) \<equiv>
        if (\<exists>A. f \<in> A -> nat \<and> Finite(A)) then
             funrestrict(f, {x \<in> mset_of(f). 0 < f`x})
        else 0"
 
 definition
   mdiff  :: "[i, i] \<Rightarrow> i" (infixl \<open>-#\<close> 65)  where
   "M -# N \<equiv>  normalize(\<lambda>x \<in> mset_of(M).
                         if x \<in> mset_of(N) then M`x #- N`x else M`x)"
 
 definition
   (* set of elements of a multiset *)
   msingle :: "i \<Rightarrow> i"    (\<open>{#_#}\<close>)  where
   "{#a#} \<equiv> {\<langle>a, 1\<rangle>}"
 
 definition
   MCollect :: "[i, i\<Rightarrow>o] \<Rightarrow> i"  (*comprehension*)  where
   "MCollect(M, P) \<equiv> funrestrict(M, {x \<in> mset_of(M). P(x)})"
 
 definition
   (* Counts the number of occurrences of an element in a multiset *)
   mcount :: "[i, i] \<Rightarrow> i"  where
   "mcount(M, a) \<equiv> if a \<in> mset_of(M) then  M`a else 0"
 
 definition
   msize :: "i \<Rightarrow> i"  where
   "msize(M) \<equiv> setsum(\<lambda>a. $# mcount(M,a), mset_of(M))"
 
 abbreviation
   melem :: "[i,i] \<Rightarrow> o"    (\<open>(_/ :# _)\<close> [50, 51] 50)  where
   "a :# M \<equiv> a \<in> mset_of(M)"
 
 syntax
   "_MColl" :: "[pttrn, i, o] \<Rightarrow> i" (\<open>(1{# _ \<in> _./ _#})\<close>)
 translations
   "{#x \<in> M. P#}" == "CONST MCollect(M, \<lambda>x. P)"
 
   (* multiset orderings *)
 
 definition
    (* multirel1 has to be a set (not a predicate) so that we can form
       its transitive closure and reason about wf(.) and acc(.) *)
   multirel1 :: "[i,i]\<Rightarrow>i"  where
   "multirel1(A, r) \<equiv>
      {\<langle>M, N\<rangle> \<in> Mult(A)*Mult(A).
       \<exists>a \<in> A. \<exists>M0 \<in> Mult(A). \<exists>K \<in> Mult(A).
       N=M0 +# {#a#} \<and> M=M0 +# K \<and> (\<forall>b \<in> mset_of(K). \<langle>b,a\<rangle> \<in> r)}"
 
 definition
   multirel :: "[i, i] \<Rightarrow> i"  where
   "multirel(A, r) \<equiv> multirel1(A, r)^+"
 
   (* ordinal multiset orderings *)
 
 definition
   omultiset :: "i \<Rightarrow> o"  where
   "omultiset(M) \<equiv> \<exists>i. Ord(i) \<and> M \<in> Mult(field(Memrel(i)))"
 
 definition
   mless :: "[i, i] \<Rightarrow> o" (infixl \<open><#\<close> 50)  where
   "M <# N \<equiv>  \<exists>i. Ord(i) \<and> \<langle>M, N\<rangle> \<in> multirel(field(Memrel(i)), Memrel(i))"
 
 definition
   mle  :: "[i, i] \<Rightarrow> o"  (infixl \<open><#=\<close> 50)  where
   "M <#= N \<equiv> (omultiset(M) \<and> M = N) | M <# N"
 
 
 subsection\<open>Properties of the original "restrict" from ZF.thy\<close>
 
 lemma funrestrict_subset: "\<lbrakk>f \<in> Pi(C,B);  A\<subseteq>C\<rbrakk> \<Longrightarrow> funrestrict(f,A) \<subseteq> f"
 by (auto simp add: funrestrict_def lam_def intro: apply_Pair)
 
 lemma funrestrict_type:
     "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> f`x \<in> B(x)\<rbrakk> \<Longrightarrow> funrestrict(f,A) \<in> Pi(A,B)"
 by (simp add: funrestrict_def lam_type)
 
 lemma funrestrict_type2: "\<lbrakk>f \<in> Pi(C,B);  A\<subseteq>C\<rbrakk> \<Longrightarrow> funrestrict(f,A) \<in> Pi(A,B)"
 by (blast intro: apply_type funrestrict_type)
 
 lemma funrestrict [simp]: "a \<in> A \<Longrightarrow> funrestrict(f,A) ` a = f`a"
 by (simp add: funrestrict_def)
 
 lemma funrestrict_empty [simp]: "funrestrict(f,0) = 0"
 by (simp add: funrestrict_def)
 
 lemma domain_funrestrict [simp]: "domain(funrestrict(f,C)) = C"
 by (auto simp add: funrestrict_def lam_def)
 
 lemma fun_cons_funrestrict_eq:
      "f \<in> cons(a, b) -> B \<Longrightarrow> f = cons(<a, f ` a>, funrestrict(f, b))"
 apply (rule equalityI)
 prefer 2 apply (blast intro: apply_Pair funrestrict_subset [THEN subsetD])
 apply (auto dest!: Pi_memberD simp add: funrestrict_def lam_def)
 done
 
 declare domain_of_fun [simp]
 declare domainE [rule del]
 
 
 text\<open>A useful simplification rule\<close>
 lemma multiset_fun_iff:
      "(f \<in> A -> nat-{0}) \<longleftrightarrow> f \<in> A->nat\<and>(\<forall>a \<in> A. f`a \<in> nat \<and> 0 < f`a)"
 apply safe
 apply (rule_tac [4] B1 = "range (f) " in Pi_mono [THEN subsetD])
 apply (auto intro!: Ord_0_lt
             dest: apply_type Diff_subset [THEN Pi_mono, THEN subsetD]
             simp add: range_of_fun apply_iff)
 done
 
 (** The multiset space  **)
 lemma multiset_into_Mult: "\<lbrakk>multiset(M); mset_of(M)\<subseteq>A\<rbrakk> \<Longrightarrow> M \<in> Mult(A)"
 apply (simp add: multiset_def)
 apply (auto simp add: multiset_fun_iff mset_of_def)
 apply (rule_tac B1 = "nat-{0}" in FiniteFun_mono [THEN subsetD], simp_all)
 apply (rule Finite_into_Fin [THEN [2] Fin_mono [THEN subsetD], THEN fun_FiniteFunI])
 apply (simp_all (no_asm_simp) add: multiset_fun_iff)
 done
 
 lemma Mult_into_multiset: "M \<in> Mult(A) \<Longrightarrow> multiset(M) \<and> mset_of(M)\<subseteq>A"
 apply (simp add: multiset_def mset_of_def)
 apply (frule FiniteFun_is_fun)
 apply (drule FiniteFun_domain_Fin)
 apply (frule FinD, clarify)
 apply (rule_tac x = "domain (M) " in exI)
 apply (blast intro: Fin_into_Finite)
 done
 
 lemma Mult_iff_multiset: "M \<in> Mult(A) \<longleftrightarrow> multiset(M) \<and> mset_of(M)\<subseteq>A"
 by (blast dest: Mult_into_multiset intro: multiset_into_Mult)
 
 lemma multiset_iff_Mult_mset_of: "multiset(M) \<longleftrightarrow> M \<in> Mult(mset_of(M))"
 by (auto simp add: Mult_iff_multiset)
 
 
 text\<open>The \<^term>\<open>multiset\<close> operator\<close>
 
 (* the empty multiset is 0 *)
 
 lemma multiset_0 [simp]: "multiset(0)"
 by (auto intro: FiniteFun.intros simp add: multiset_iff_Mult_mset_of)
 
 
 text\<open>The \<^term>\<open>mset_of\<close> operator\<close>
 
 lemma multiset_set_of_Finite [simp]: "multiset(M) \<Longrightarrow> Finite(mset_of(M))"
 by (simp add: multiset_def mset_of_def, auto)
 
 lemma mset_of_0 [iff]: "mset_of(0) = 0"
 by (simp add: mset_of_def)
 
 lemma mset_is_0_iff: "multiset(M) \<Longrightarrow> mset_of(M)=0 \<longleftrightarrow> M=0"
 by (auto simp add: multiset_def mset_of_def)
 
 lemma mset_of_single [iff]: "mset_of({#a#}) = {a}"
 by (simp add: msingle_def mset_of_def)
 
 lemma mset_of_union [iff]: "mset_of(M +# N) = mset_of(M) \<union> mset_of(N)"
 by (simp add: mset_of_def munion_def)
 
 lemma mset_of_diff [simp]: "mset_of(M)\<subseteq>A \<Longrightarrow> mset_of(M -# N) \<subseteq> A"
 by (auto simp add: mdiff_def multiset_def normalize_def mset_of_def)
 
 (* msingle *)
 
 lemma msingle_not_0 [iff]: "{#a#} \<noteq> 0 \<and> 0 \<noteq> {#a#}"
 by (simp add: msingle_def)
 
 lemma msingle_eq_iff [iff]: "({#a#} = {#b#}) \<longleftrightarrow>  (a = b)"
 by (simp add: msingle_def)
 
 lemma msingle_multiset [iff,TC]: "multiset({#a#})"
 apply (simp add: multiset_def msingle_def)
 apply (rule_tac x = "{a}" in exI)
 apply (auto intro: Finite_cons Finite_0 fun_extend3)
 done
 
 (** normalize **)
 
 lemmas Collect_Finite = Collect_subset [THEN subset_Finite]
 
 lemma normalize_idem [simp]: "normalize(normalize(f)) = normalize(f)"
 apply (simp add: normalize_def funrestrict_def mset_of_def)
 apply (case_tac "\<exists>A. f \<in> A -> nat \<and> Finite (A) ")
 apply clarify
 apply (drule_tac x = "{x \<in> domain (f) . 0 < f ` x}" in spec)
 apply auto
 apply (auto  intro!: lam_type simp add: Collect_Finite)
 done
 
 lemma normalize_multiset [simp]: "multiset(M) \<Longrightarrow> normalize(M) = M"
 by (auto simp add: multiset_def normalize_def mset_of_def funrestrict_def multiset_fun_iff)
 
 lemma multiset_normalize [simp]: "multiset(normalize(f))"
 apply (simp add: normalize_def)
 apply (simp add: normalize_def mset_of_def multiset_def, auto)
 apply (rule_tac x = "{x \<in> A . 0<f`x}" in exI)
 apply (auto intro: Collect_subset [THEN subset_Finite] funrestrict_type)
 done
 
 (** Typechecking rules for union and difference of multisets **)
 
 (* union *)
 
 lemma munion_multiset [simp]: "\<lbrakk>multiset(M); multiset(N)\<rbrakk> \<Longrightarrow> multiset(M +# N)"
 apply (unfold multiset_def munion_def mset_of_def, auto)
 apply (rule_tac x = "A \<union> Aa" in exI)
 apply (auto intro!: lam_type intro: Finite_Un simp add: multiset_fun_iff zero_less_add)
 done
 
 (* difference *)
 
 lemma mdiff_multiset [simp]: "multiset(M -# N)"
 by (simp add: mdiff_def)
 
 (** Algebraic properties of multisets **)
 
 (* Union *)
 
 lemma munion_0 [simp]: "multiset(M) \<Longrightarrow> M +# 0 = M \<and> 0 +# M = M"
 apply (simp add: multiset_def)
 apply (auto simp add: munion_def mset_of_def)
 done
 
 lemma munion_commute: "M +# N = N +# M"
 by (auto intro!: lam_cong simp add: munion_def)
 
 lemma munion_assoc: "(M +# N) +# K = M +# (N +# K)"
-apply (unfold munion_def mset_of_def)
+  unfolding munion_def mset_of_def
 apply (rule lam_cong, auto)
 done
 
 lemma munion_lcommute: "M +# (N +# K) = N +# (M +# K)"
-apply (unfold munion_def mset_of_def)
+  unfolding munion_def mset_of_def
 apply (rule lam_cong, auto)
 done
 
 lemmas munion_ac = munion_commute munion_assoc munion_lcommute
 
 (* Difference *)
 
 lemma mdiff_self_eq_0 [simp]: "M -# M = 0"
 by (simp add: mdiff_def normalize_def mset_of_def)
 
 lemma mdiff_0 [simp]: "0 -# M = 0"
 by (simp add: mdiff_def normalize_def)
 
 lemma mdiff_0_right [simp]: "multiset(M) \<Longrightarrow> M -# 0 = M"
 by (auto simp add: multiset_def mdiff_def normalize_def multiset_fun_iff mset_of_def funrestrict_def)
 
 lemma mdiff_union_inverse2 [simp]: "multiset(M) \<Longrightarrow> M +# {#a#} -# {#a#} = M"
-apply (unfold multiset_def munion_def mdiff_def msingle_def normalize_def mset_of_def)
+  unfolding multiset_def munion_def mdiff_def msingle_def normalize_def mset_of_def
 apply (auto cong add: if_cong simp add: ltD multiset_fun_iff funrestrict_def subset_Un_iff2 [THEN iffD1])
 prefer 2 apply (force intro!: lam_type)
 apply (subgoal_tac [2] "{x \<in> A \<union> {a} . x \<noteq> a \<and> x \<in> A} = A")
 apply (rule fun_extension, auto)
 apply (drule_tac x = "A \<union> {a}" in spec)
 apply (simp add: Finite_Un)
 apply (force intro!: lam_type)
 done
 
 (** Count of elements **)
 
 lemma mcount_type [simp,TC]: "multiset(M) \<Longrightarrow> mcount(M, a) \<in> nat"
 by (auto simp add: multiset_def mcount_def mset_of_def multiset_fun_iff)
 
 lemma mcount_0 [simp]: "mcount(0, a) = 0"
 by (simp add: mcount_def)
 
 lemma mcount_single [simp]: "mcount({#b#}, a) = (if a=b then 1 else 0)"
 by (simp add: mcount_def mset_of_def msingle_def)
 
 lemma mcount_union [simp]: "\<lbrakk>multiset(M); multiset(N)\<rbrakk>
                      \<Longrightarrow>  mcount(M +# N, a) = mcount(M, a) #+ mcount (N, a)"
 apply (auto simp add: multiset_def multiset_fun_iff mcount_def munion_def mset_of_def)
 done
 
 lemma mcount_diff [simp]:
      "multiset(M) \<Longrightarrow> mcount(M -# N, a) = mcount(M, a) #- mcount(N, a)"
 apply (simp add: multiset_def)
 apply (auto dest!: not_lt_imp_le
      simp add: mdiff_def multiset_fun_iff mcount_def normalize_def mset_of_def)
 apply (force intro!: lam_type)
 apply (force intro!: lam_type)
 done
 
 lemma mcount_elem: "\<lbrakk>multiset(M); a \<in> mset_of(M)\<rbrakk> \<Longrightarrow> 0 < mcount(M, a)"
 apply (simp add: multiset_def, clarify)
 apply (simp add: mcount_def mset_of_def)
 apply (simp add: multiset_fun_iff)
 done
 
 (** msize **)
 
 lemma msize_0 [simp]: "msize(0) = #0"
 by (simp add: msize_def)
 
 lemma msize_single [simp]: "msize({#a#}) = #1"
 by (simp add: msize_def)
 
 lemma msize_type [simp,TC]: "msize(M) \<in> int"
 by (simp add: msize_def)
 
 lemma msize_zpositive: "multiset(M)\<Longrightarrow> #0 $\<le> msize(M)"
 by (auto simp add: msize_def intro: g_zpos_imp_setsum_zpos)
 
 lemma msize_int_of_nat: "multiset(M) \<Longrightarrow> \<exists>n \<in> nat. msize(M)= $# n"
 apply (rule not_zneg_int_of)
 apply (simp_all (no_asm_simp) add: msize_type [THEN znegative_iff_zless_0] not_zless_iff_zle msize_zpositive)
 done
 
 lemma not_empty_multiset_imp_exist:
      "\<lbrakk>M\<noteq>0; multiset(M)\<rbrakk> \<Longrightarrow> \<exists>a \<in> mset_of(M). 0 < mcount(M, a)"
 apply (simp add: multiset_def)
 apply (erule not_emptyE)
 apply (auto simp add: mset_of_def mcount_def multiset_fun_iff)
 apply (blast dest!: fun_is_rel)
 done
 
 lemma msize_eq_0_iff: "multiset(M) \<Longrightarrow> msize(M)=#0 \<longleftrightarrow> M=0"
 apply (simp add: msize_def, auto)
 apply (rule_tac P = "setsum (u,v) \<noteq> #0" for u v in swap)
 apply blast
 apply (drule not_empty_multiset_imp_exist, assumption, clarify)
 apply (subgoal_tac "Finite (mset_of (M) - {a}) ")
  prefer 2 apply (simp add: Finite_Diff)
 apply (subgoal_tac "setsum (\<lambda>x. $# mcount (M, x), cons (a, mset_of (M) -{a}))=#0")
  prefer 2 apply (simp add: cons_Diff, simp)
 apply (subgoal_tac "#0 $\<le> setsum (\<lambda>x. $# mcount (M, x), mset_of (M) - {a}) ")
 apply (rule_tac [2] g_zpos_imp_setsum_zpos)
 apply (auto simp add: Finite_Diff not_zless_iff_zle [THEN iff_sym] znegative_iff_zless_0 [THEN iff_sym])
 apply (rule not_zneg_int_of [THEN bexE])
 apply (auto simp del: int_of_0 simp add: int_of_add [symmetric] int_of_0 [symmetric])
 done
 
 lemma setsum_mcount_Int:
      "Finite(A) \<Longrightarrow> setsum(\<lambda>a. $# mcount(N, a), A \<inter> mset_of(N))
                   = setsum(\<lambda>a. $# mcount(N, a), A)"
 apply (induct rule: Finite_induct)
  apply auto
 apply (subgoal_tac "Finite (B \<inter> mset_of (N))")
 prefer 2 apply (blast intro: subset_Finite)
 apply (auto simp add: mcount_def Int_cons_left)
 done
 
 lemma msize_union [simp]:
      "\<lbrakk>multiset(M); multiset(N)\<rbrakk> \<Longrightarrow> msize(M +# N) = msize(M) $+ msize(N)"
 apply (simp add: msize_def setsum_Un setsum_addf int_of_add setsum_mcount_Int)
 apply (subst Int_commute)
 apply (simp add: setsum_mcount_Int)
 done
 
 lemma msize_eq_succ_imp_elem: "\<lbrakk>msize(M)= $# succ(n); n \<in> nat\<rbrakk> \<Longrightarrow> \<exists>a. a \<in> mset_of(M)"
   unfolding msize_def
 apply (blast dest: setsum_succD)
 done
 
 (** Equality of multisets **)
 
 lemma equality_lemma:
      "\<lbrakk>multiset(M); multiset(N); \<forall>a. mcount(M, a)=mcount(N, a)\<rbrakk>
       \<Longrightarrow> mset_of(M)=mset_of(N)"
 apply (simp add: multiset_def)
 apply (rule sym, rule equalityI)
 apply (auto simp add: multiset_fun_iff mcount_def mset_of_def)
 apply (drule_tac [!] x=x in spec)
 apply (case_tac [2] "x \<in> Aa", case_tac "x \<in> A", auto)
 done
 
 lemma multiset_equality:
   "\<lbrakk>multiset(M); multiset(N)\<rbrakk>\<Longrightarrow> M=N\<longleftrightarrow>(\<forall>a. mcount(M, a)=mcount(N, a))"
 apply auto
 apply (subgoal_tac "mset_of (M) = mset_of (N) ")
 prefer 2 apply (blast intro: equality_lemma)
 apply (simp add: multiset_def mset_of_def)
 apply (auto simp add: multiset_fun_iff)
 apply (rule fun_extension)
 apply (blast, blast)
 apply (drule_tac x = x in spec)
 apply (auto simp add: mcount_def mset_of_def)
 done
 
 (** More algebraic properties of multisets **)
 
 lemma munion_eq_0_iff [simp]: "\<lbrakk>multiset(M); multiset(N)\<rbrakk>\<Longrightarrow>(M +# N =0) \<longleftrightarrow> (M=0 \<and> N=0)"
 by (auto simp add: multiset_equality)
 
 lemma empty_eq_munion_iff [simp]: "\<lbrakk>multiset(M); multiset(N)\<rbrakk>\<Longrightarrow>(0=M +# N) \<longleftrightarrow> (M=0 \<and> N=0)"
 apply (rule iffI, drule sym)
 apply (simp_all add: multiset_equality)
 done
 
 lemma munion_right_cancel [simp]:
      "\<lbrakk>multiset(M); multiset(N); multiset(K)\<rbrakk>\<Longrightarrow>(M +# K = N +# K)\<longleftrightarrow>(M=N)"
 by (auto simp add: multiset_equality)
 
 lemma munion_left_cancel [simp]:
   "\<lbrakk>multiset(K); multiset(M); multiset(N)\<rbrakk> \<Longrightarrow>(K +# M = K +# N) \<longleftrightarrow> (M = N)"
 by (auto simp add: multiset_equality)
 
 lemma nat_add_eq_1_cases: "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow> (m #+ n = 1) \<longleftrightarrow> (m=1 \<and> n=0) | (m=0 \<and> n=1)"
 by (induct_tac n) auto
 
 lemma munion_is_single:
      "\<lbrakk>multiset(M); multiset(N)\<rbrakk>
       \<Longrightarrow> (M +# N = {#a#}) \<longleftrightarrow>  (M={#a#} \<and> N=0) | (M = 0 \<and> N = {#a#})"
 apply (simp (no_asm_simp) add: multiset_equality)
 apply safe
 apply simp_all
 apply (case_tac "aa=a")
 apply (drule_tac [2] x = aa in spec)
 apply (drule_tac x = a in spec)
 apply (simp add: nat_add_eq_1_cases, simp)
 apply (case_tac "aaa=aa", simp)
 apply (drule_tac x = aa in spec)
 apply (simp add: nat_add_eq_1_cases)
 apply (case_tac "aaa=a")
 apply (drule_tac [4] x = aa in spec)
 apply (drule_tac [3] x = a in spec)
 apply (drule_tac [2] x = aaa in spec)
 apply (drule_tac x = aa in spec)
 apply (simp_all add: nat_add_eq_1_cases)
 done
 
 lemma msingle_is_union: "\<lbrakk>multiset(M); multiset(N)\<rbrakk>
   \<Longrightarrow> ({#a#} = M +# N) \<longleftrightarrow> ({#a#} = M  \<and> N=0 | M = 0 \<and> {#a#} = N)"
 apply (subgoal_tac " ({#a#} = M +# N) \<longleftrightarrow> (M +# N = {#a#}) ")
 apply (simp (no_asm_simp) add: munion_is_single)
 apply blast
 apply (blast dest: sym)
 done
 
 (** Towards induction over multisets **)
 
 lemma setsum_decr:
 "Finite(A)
   \<Longrightarrow>  (\<forall>M. multiset(M) \<longrightarrow>
   (\<forall>a \<in> mset_of(M). setsum(\<lambda>z. $# mcount(M(a:=M`a #- 1), z), A) =
   (if a \<in> A then setsum(\<lambda>z. $# mcount(M, z), A) $- #1
            else setsum(\<lambda>z. $# mcount(M, z), A))))"
   unfolding multiset_def
 apply (erule Finite_induct)
 apply (auto simp add: multiset_fun_iff)
-apply (unfold mset_of_def mcount_def)
+  unfolding mset_of_def mcount_def
 apply (case_tac "x \<in> A", auto)
 apply (subgoal_tac "$# M ` x $+ #-1 = $# M ` x $- $# 1")
 apply (erule ssubst)
 apply (rule int_of_diff, auto)
 done
 
 lemma setsum_decr2:
      "Finite(A)
       \<Longrightarrow> \<forall>M. multiset(M) \<longrightarrow> (\<forall>a \<in> mset_of(M).
            setsum(\<lambda>x. $# mcount(funrestrict(M, mset_of(M)-{a}), x), A) =
            (if a \<in> A then setsum(\<lambda>x. $# mcount(M, x), A) $- $# M`a
             else setsum(\<lambda>x. $# mcount(M, x), A)))"
 apply (simp add: multiset_def)
 apply (erule Finite_induct)
 apply (auto simp add: multiset_fun_iff mcount_def mset_of_def)
 done
 
 lemma setsum_decr3: "\<lbrakk>Finite(A); multiset(M); a \<in> mset_of(M)\<rbrakk>
       \<Longrightarrow> setsum(\<lambda>x. $# mcount(funrestrict(M, mset_of(M)-{a}), x), A - {a}) =
           (if a \<in> A then setsum(\<lambda>x. $# mcount(M, x), A) $- $# M`a
            else setsum(\<lambda>x. $# mcount(M, x), A))"
 apply (subgoal_tac "setsum (\<lambda>x. $# mcount (funrestrict (M, mset_of (M) -{a}),x),A-{a}) = setsum (\<lambda>x. $# mcount (funrestrict (M, mset_of (M) -{a}),x),A) ")
 apply (rule_tac [2] setsum_Diff [symmetric])
 apply (rule sym, rule ssubst, blast)
 apply (rule sym, drule setsum_decr2, auto)
 apply (simp add: mcount_def mset_of_def)
 done
 
 lemma nat_le_1_cases: "n \<in> nat \<Longrightarrow> n \<le> 1 \<longleftrightarrow> (n=0 | n=1)"
 by (auto elim: natE)
 
 lemma succ_pred_eq_self: "\<lbrakk>0<n; n \<in> nat\<rbrakk> \<Longrightarrow> succ(n #- 1) = n"
 apply (subgoal_tac "1 \<le> n")
 apply (drule add_diff_inverse2, auto)
 done
 
 text\<open>Specialized for use in the proof below.\<close>
 lemma multiset_funrestict:
      "\<lbrakk>\<forall>a\<in>A. M ` a \<in> nat \<and> 0 < M ` a; Finite(A)\<rbrakk>
       \<Longrightarrow> multiset(funrestrict(M, A - {a}))"
 apply (simp add: multiset_def multiset_fun_iff)
 apply (rule_tac x="A-{a}" in exI)
 apply (auto intro: Finite_Diff funrestrict_type)
 done
 
 lemma multiset_induct_aux:
   assumes prem1: "\<And>M a. \<lbrakk>multiset(M); a\<notin>mset_of(M); P(M)\<rbrakk> \<Longrightarrow> P(cons(\<langle>a, 1\<rangle>, M))"
       and prem2: "\<And>M b. \<lbrakk>multiset(M); b \<in> mset_of(M); P(M)\<rbrakk> \<Longrightarrow> P(M(b:= M`b #+ 1))"
   shows
   "\<lbrakk>n \<in> nat; P(0)\<rbrakk>
      \<Longrightarrow> (\<forall>M. multiset(M)\<longrightarrow>
   (setsum(\<lambda>x. $# mcount(M, x), {x \<in> mset_of(M). 0 < M`x}) = $# n) \<longrightarrow> P(M))"
 apply (erule nat_induct, clarify)
 apply (frule msize_eq_0_iff)
 apply (auto simp add: mset_of_def multiset_def multiset_fun_iff msize_def)
 apply (subgoal_tac "setsum (\<lambda>x. $# mcount (M, x), A) =$# succ (x) ")
 apply (drule setsum_succD, auto)
 apply (case_tac "1 <M`a")
 apply (drule_tac [2] not_lt_imp_le)
 apply (simp_all add: nat_le_1_cases)
 apply (subgoal_tac "M= (M (a:=M`a #- 1)) (a:= (M (a:=M`a #- 1))`a #+ 1) ")
 apply (rule_tac [2] A = A and B = "\<lambda>x. nat" and D = "\<lambda>x. nat" in fun_extension)
 apply (rule_tac [3] update_type)+
 apply (simp_all (no_asm_simp))
  apply (rule_tac [2] impI)
  apply (rule_tac [2] succ_pred_eq_self [symmetric])
 apply (simp_all (no_asm_simp))
 apply (rule subst, rule sym, blast, rule prem2)
 apply (simp (no_asm) add: multiset_def multiset_fun_iff)
 apply (rule_tac x = A in exI)
 apply (force intro: update_type)
 apply (simp (no_asm_simp) add: mset_of_def mcount_def)
 apply (drule_tac x = "M (a := M ` a #- 1) " in spec)
 apply (drule mp, drule_tac [2] mp, simp_all)
 apply (rule_tac x = A in exI)
 apply (auto intro: update_type)
 apply (subgoal_tac "Finite ({x \<in> cons (a, A) . x\<noteq>a\<longrightarrow>0<M`x}) ")
 prefer 2 apply (blast intro: Collect_subset [THEN subset_Finite] Finite_cons)
 apply (drule_tac A = "{x \<in> cons (a, A) . x\<noteq>a\<longrightarrow>0<M`x}" in setsum_decr)
 apply (drule_tac x = M in spec)
 apply (subgoal_tac "multiset (M) ")
  prefer 2
  apply (simp add: multiset_def multiset_fun_iff)
  apply (rule_tac x = A in exI, force)
 apply (simp_all add: mset_of_def)
 apply (drule_tac psi = "\<forall>x \<in> A. u(x)" for u in asm_rl)
 apply (drule_tac x = a in bspec)
 apply (simp (no_asm_simp))
 apply (subgoal_tac "cons (a, A) = A")
 prefer 2 apply blast
 apply simp
 apply (subgoal_tac "M=cons (<a, M`a>, funrestrict (M, A-{a}))")
  prefer 2
  apply (rule fun_cons_funrestrict_eq)
  apply (subgoal_tac "cons (a, A-{a}) = A")
   apply force
   apply force
 apply (rule_tac a = "cons (\<langle>a, 1\<rangle>, funrestrict (M, A - {a}))" in ssubst)
 apply simp
 apply (frule multiset_funrestict, assumption)
 apply (rule prem1, assumption)
 apply (simp add: mset_of_def)
 apply (drule_tac x = "funrestrict (M, A-{a}) " in spec)
 apply (drule mp)
 apply (rule_tac x = "A-{a}" in exI)
 apply (auto intro: Finite_Diff funrestrict_type simp add: funrestrict)
 apply (frule_tac A = A and M = M and a = a in setsum_decr3)
 apply (simp (no_asm_simp) add: multiset_def multiset_fun_iff)
 apply blast
 apply (simp (no_asm_simp) add: mset_of_def)
 apply (drule_tac b = "if u then v else w" for u v w in sym, simp_all)
 apply (subgoal_tac "{x \<in> A - {a} . 0 < funrestrict (M, A - {x}) ` x} = A - {a}")
 apply (auto intro!: setsum_cong simp add: zdiff_eq_iff zadd_commute multiset_def multiset_fun_iff mset_of_def)
 done
 
 lemma multiset_induct2:
   "\<lbrakk>multiset(M); P(0);
     (\<And>M a. \<lbrakk>multiset(M); a\<notin>mset_of(M); P(M)\<rbrakk> \<Longrightarrow> P(cons(\<langle>a, 1\<rangle>, M)));
     (\<And>M b. \<lbrakk>multiset(M); b \<in> mset_of(M);  P(M)\<rbrakk> \<Longrightarrow> P(M(b:= M`b #+ 1)))\<rbrakk>
      \<Longrightarrow> P(M)"
 apply (subgoal_tac "\<exists>n \<in> nat. setsum (\<lambda>x. $# mcount (M, x), {x \<in> mset_of (M) . 0 < M ` x}) = $# n")
 apply (rule_tac [2] not_zneg_int_of)
 apply (simp_all (no_asm_simp) add: znegative_iff_zless_0 not_zless_iff_zle)
 apply (rule_tac [2] g_zpos_imp_setsum_zpos)
 prefer 2 apply (blast intro:  multiset_set_of_Finite Collect_subset [THEN subset_Finite])
  prefer 2 apply (simp add: multiset_def multiset_fun_iff, clarify)
 apply (rule multiset_induct_aux [rule_format], auto)
 done
 
 lemma munion_single_case1:
      "\<lbrakk>multiset(M); a \<notin>mset_of(M)\<rbrakk> \<Longrightarrow> M +# {#a#} = cons(\<langle>a, 1\<rangle>, M)"
 apply (simp add: multiset_def msingle_def)
 apply (auto simp add: munion_def)
 apply (unfold mset_of_def, simp)
 apply (rule fun_extension, rule lam_type, simp_all)
 apply (auto simp add: multiset_fun_iff fun_extend_apply)
 apply (drule_tac c = a and b = 1 in fun_extend3)
 apply (auto simp add: cons_eq Un_commute [of _ "{a}"])
 done
 
 lemma munion_single_case2:
      "\<lbrakk>multiset(M); a \<in> mset_of(M)\<rbrakk> \<Longrightarrow> M +# {#a#} = M(a:=M`a #+ 1)"
 apply (simp add: multiset_def)
 apply (auto simp add: munion_def multiset_fun_iff msingle_def)
 apply (unfold mset_of_def, simp)
 apply (subgoal_tac "A \<union> {a} = A")
 apply (rule fun_extension)
 apply (auto dest: domain_type intro: lam_type update_type)
 done
 
 (* Induction principle for multisets *)
 
 lemma multiset_induct:
   assumes M: "multiset(M)"
       and P0: "P(0)"
       and step: "\<And>M a. \<lbrakk>multiset(M); P(M)\<rbrakk> \<Longrightarrow> P(M +# {#a#})"
   shows "P(M)"
 apply (rule multiset_induct2 [OF M])
 apply (simp_all add: P0)
 apply (frule_tac [2] a = b in munion_single_case2 [symmetric])
 apply (frule_tac a = a in munion_single_case1 [symmetric])
 apply (auto intro: step)
 done
 
 (** MCollect **)
 
 lemma MCollect_multiset [simp]:
      "multiset(M) \<Longrightarrow> multiset({# x \<in> M. P(x)#})"
 apply (simp add: MCollect_def multiset_def mset_of_def, clarify)
 apply (rule_tac x = "{x \<in> A. P (x) }" in exI)
 apply (auto dest: CollectD1 [THEN [2] apply_type]
             intro: Collect_subset [THEN subset_Finite] funrestrict_type)
 done
 
 lemma mset_of_MCollect [simp]:
      "multiset(M) \<Longrightarrow> mset_of({# x \<in> M. P(x) #}) \<subseteq> mset_of(M)"
 by (auto simp add: mset_of_def MCollect_def multiset_def funrestrict_def)
 
 lemma MCollect_mem_iff [iff]:
      "x \<in> mset_of({#x \<in> M. P(x)#}) \<longleftrightarrow>  x \<in> mset_of(M) \<and> P(x)"
 by (simp add: MCollect_def mset_of_def)
 
 lemma mcount_MCollect [simp]:
      "mcount({# x \<in> M. P(x) #}, a) = (if P(a) then mcount(M,a) else 0)"
 by (simp add: mcount_def MCollect_def mset_of_def)
 
 lemma multiset_partition: "multiset(M) \<Longrightarrow> M = {# x \<in> M. P(x) #} +# {# x \<in> M. \<not> P(x) #}"
 by (simp add: multiset_equality)
 
 lemma natify_elem_is_self [simp]:
      "\<lbrakk>multiset(M); a \<in> mset_of(M)\<rbrakk> \<Longrightarrow> natify(M`a) = M`a"
 by (auto simp add: multiset_def mset_of_def multiset_fun_iff)
 
 (* and more algebraic laws on multisets *)
 
 lemma munion_eq_conv_diff: "\<lbrakk>multiset(M); multiset(N)\<rbrakk>
   \<Longrightarrow>  (M +# {#a#} = N +# {#b#}) \<longleftrightarrow>  (M = N \<and> a = b |
        M = N -# {#a#} +# {#b#} \<and> N = M -# {#b#} +# {#a#})"
 apply (simp del: mcount_single add: multiset_equality)
 apply (rule iffI, erule_tac [2] disjE, erule_tac [3] conjE)
 apply (case_tac "a=b", auto)
 apply (drule_tac x = a in spec)
 apply (drule_tac [2] x = b in spec)
 apply (drule_tac [3] x = aa in spec)
 apply (drule_tac [4] x = a in spec, auto)
 apply (subgoal_tac [!] "mcount (N,a) :nat")
 apply (erule_tac [3] natE, erule natE, auto)
 done
 
 lemma melem_diff_single:
 "multiset(M) \<Longrightarrow>
   k \<in> mset_of(M -# {#a#}) \<longleftrightarrow> (k=a \<and> 1 < mcount(M,a)) | (k\<noteq> a \<and> k \<in> mset_of(M))"
 apply (simp add: multiset_def)
 apply (simp add: normalize_def mset_of_def msingle_def mdiff_def mcount_def)
 apply (auto dest: domain_type intro: zero_less_diff [THEN iffD1]
             simp add: multiset_fun_iff apply_iff)
 apply (force intro!: lam_type)
 apply (force intro!: lam_type)
 apply (force intro!: lam_type)
 done
 
 lemma munion_eq_conv_exist:
 "\<lbrakk>M \<in> Mult(A); N \<in> Mult(A)\<rbrakk>
   \<Longrightarrow> (M +# {#a#} = N +# {#b#}) \<longleftrightarrow>
       (M=N \<and> a=b | (\<exists>K \<in> Mult(A). M= K +# {#b#} \<and> N=K +# {#a#}))"
 by (auto simp add: Mult_iff_multiset melem_diff_single munion_eq_conv_diff)
 
 
 subsection\<open>Multiset Orderings\<close>
 
 (* multiset on a domain A are finite functions from A to nat-{0} *)
 
 
 (* multirel1 type *)
 
 lemma multirel1_type: "multirel1(A, r) \<subseteq> Mult(A)*Mult(A)"
 by (auto simp add: multirel1_def)
 
 lemma multirel1_0 [simp]: "multirel1(0, r) =0"
 by (auto simp add: multirel1_def)
 
 lemma multirel1_iff:
 " \<langle>N, M\<rangle> \<in> multirel1(A, r) \<longleftrightarrow>
   (\<exists>a. a \<in> A \<and>
   (\<exists>M0. M0 \<in> Mult(A) \<and> (\<exists>K. K \<in> Mult(A) \<and>
    M=M0 +# {#a#} \<and> N=M0 +# K \<and> (\<forall>b \<in> mset_of(K). \<langle>b,a\<rangle> \<in> r))))"
 by (auto simp add: multirel1_def Mult_iff_multiset Bex_def)
 
 
 text\<open>Monotonicity of \<^term>\<open>multirel1\<close>\<close>
 
 lemma multirel1_mono1: "A\<subseteq>B \<Longrightarrow> multirel1(A, r)\<subseteq>multirel1(B, r)"
 apply (auto simp add: multirel1_def)
 apply (auto simp add: Un_subset_iff Mult_iff_multiset)
 apply (rule_tac x = a in bexI)
 apply (rule_tac x = M0 in bexI, simp)
 apply (rule_tac x = K in bexI)
 apply (auto simp add: Mult_iff_multiset)
 done
 
 lemma multirel1_mono2: "r\<subseteq>s \<Longrightarrow> multirel1(A,r)\<subseteq>multirel1(A, s)"
 apply (simp add: multirel1_def, auto)
 apply (rule_tac x = a in bexI)
 apply (rule_tac x = M0 in bexI)
 apply (simp_all add: Mult_iff_multiset)
 apply (rule_tac x = K in bexI)
 apply (simp_all add: Mult_iff_multiset, auto)
 done
 
 lemma multirel1_mono:
      "\<lbrakk>A\<subseteq>B; r\<subseteq>s\<rbrakk> \<Longrightarrow> multirel1(A, r) \<subseteq> multirel1(B, s)"
 apply (rule subset_trans)
 apply (rule multirel1_mono1)
 apply (rule_tac [2] multirel1_mono2, auto)
 done
 
 subsection\<open>Toward the proof of well-foundedness of multirel1\<close>
 
 lemma not_less_0 [iff]: "\<langle>M,0\<rangle> \<notin> multirel1(A, r)"
 by (auto simp add: multirel1_def Mult_iff_multiset)
 
 lemma less_munion: "\<lbrakk><N, M0 +# {#a#}> \<in> multirel1(A, r); M0 \<in> Mult(A)\<rbrakk> \<Longrightarrow>
   (\<exists>M. \<langle>M, M0\<rangle> \<in> multirel1(A, r) \<and> N = M +# {#a#}) |
   (\<exists>K. K \<in> Mult(A) \<and> (\<forall>b \<in> mset_of(K). \<langle>b, a\<rangle> \<in> r) \<and> N = M0 +# K)"
 apply (frule multirel1_type [THEN subsetD])
 apply (simp add: multirel1_iff)
 apply (auto simp add: munion_eq_conv_exist)
 apply (rule_tac x="Ka +# K" in exI, auto, simp add: Mult_iff_multiset)
 apply (simp (no_asm_simp) add: munion_left_cancel munion_assoc)
 apply (auto simp add: munion_commute)
 done
 
 lemma multirel1_base: "\<lbrakk>M \<in> Mult(A); a \<in> A\<rbrakk> \<Longrightarrow> <M, M +# {#a#}> \<in> multirel1(A, r)"
 apply (auto simp add: multirel1_iff)
 apply (simp add: Mult_iff_multiset)
 apply (rule_tac x = a in exI, clarify)
 apply (rule_tac x = M in exI, simp)
 apply (rule_tac x = 0 in exI, auto)
 done
 
 lemma acc_0: "acc(0)=0"
 by (auto intro!: equalityI dest: acc.dom_subset [THEN subsetD])
 
 lemma lemma1: "\<lbrakk>\<forall>b \<in> A. \<langle>b,a\<rangle> \<in> r \<longrightarrow>
     (\<forall>M \<in> acc(multirel1(A, r)). M +# {#b#}:acc(multirel1(A, r)));
     M0 \<in> acc(multirel1(A, r)); a \<in> A;
     \<forall>M. \<langle>M,M0\<rangle> \<in> multirel1(A, r) \<longrightarrow> M +# {#a#} \<in> acc(multirel1(A, r))\<rbrakk>
   \<Longrightarrow> M0 +# {#a#} \<in> acc(multirel1(A, r))"
 apply (subgoal_tac "M0 \<in> Mult(A) ")
  prefer 2
  apply (erule acc.cases)
  apply (erule fieldE)
  apply (auto dest: multirel1_type [THEN subsetD])
 apply (rule accI)
 apply (rename_tac "N")
 apply (drule less_munion, blast)
 apply (auto simp add: Mult_iff_multiset)
 apply (erule_tac P = "\<forall>x \<in> mset_of (K) . \<langle>x, a\<rangle> \<in> r" in rev_mp)
 apply (erule_tac P = "mset_of (K) \<subseteq>A" in rev_mp)
 apply (erule_tac M = K in multiset_induct)
 (* three subgoals *)
 (* subgoal 1 \<in> the induction base case *)
 apply (simp (no_asm_simp))
 (* subgoal 2 \<in> the induction general case *)
 apply (simp add: Ball_def Un_subset_iff, clarify)
 apply (drule_tac x = aa in spec, simp)
 apply (subgoal_tac "aa \<in> A")
 prefer 2 apply blast
 apply (drule_tac x = "M0 +# M" and P =
        "\<lambda>x. x \<in> acc(multirel1(A, r)) \<longrightarrow> Q(x)" for Q in spec)
 apply (simp add: munion_assoc [symmetric])
 (* subgoal 3 \<in> additional conditions *)
 apply (auto intro!: multirel1_base [THEN fieldI2] simp add: Mult_iff_multiset)
 done
 
 lemma lemma2: "\<lbrakk>\<forall>b \<in> A. \<langle>b,a\<rangle> \<in> r
    \<longrightarrow> (\<forall>M \<in> acc(multirel1(A, r)). M +# {#b#} :acc(multirel1(A, r)));
         M \<in> acc(multirel1(A, r)); a \<in> A\<rbrakk> \<Longrightarrow> M +# {#a#} \<in> acc(multirel1(A, r))"
 apply (erule acc_induct)
 apply (blast intro: lemma1)
 done
 
 lemma lemma3: "\<lbrakk>wf[A](r); a \<in> A\<rbrakk>
       \<Longrightarrow> \<forall>M \<in> acc(multirel1(A, r)). M +# {#a#} \<in> acc(multirel1(A, r))"
 apply (erule_tac a = a in wf_on_induct, blast)
 apply (blast intro: lemma2)
 done
 
 lemma lemma4: "multiset(M) \<Longrightarrow> mset_of(M)\<subseteq>A \<longrightarrow>
    wf[A](r) \<longrightarrow> M \<in> field(multirel1(A, r)) \<longrightarrow> M \<in> acc(multirel1(A, r))"
 apply (erule multiset_induct)
 (* proving the base case *)
 apply clarify
 apply (rule accI, force)
 apply (simp add: multirel1_def)
 (* Proving the general case *)
 apply clarify
 apply simp
 apply (subgoal_tac "mset_of (M) \<subseteq>A")
 prefer 2 apply blast
 apply clarify
 apply (drule_tac a = a in lemma3, blast)
 apply (subgoal_tac "M \<in> field (multirel1 (A,r))")
 apply blast
 apply (rule multirel1_base [THEN fieldI1])
 apply (auto simp add: Mult_iff_multiset)
 done
 
 lemma all_accessible: "\<lbrakk>wf[A](r); M \<in> Mult(A); A \<noteq> 0\<rbrakk> \<Longrightarrow> M \<in> acc(multirel1(A, r))"
 apply (erule not_emptyE)
 apply  (rule lemma4 [THEN mp, THEN mp, THEN mp])
 apply (rule_tac [4] multirel1_base [THEN fieldI1])
 apply  (auto simp add: Mult_iff_multiset)
 done
 
 lemma wf_on_multirel1: "wf[A](r) \<Longrightarrow> wf[A-||>nat-{0}](multirel1(A, r))"
 apply (case_tac "A=0")
 apply (simp (no_asm_simp))
 apply (rule wf_imp_wf_on)
 apply (rule wf_on_field_imp_wf)
 apply (simp (no_asm_simp) add: wf_on_0)
 apply (rule_tac A = "acc (multirel1 (A,r))" in wf_on_subset_A)
 apply (rule wf_on_acc)
 apply (blast intro: all_accessible)
 done
 
 lemma wf_multirel1: "wf(r) \<Longrightarrow>wf(multirel1(field(r), r))"
 apply (simp (no_asm_use) add: wf_iff_wf_on_field)
 apply (drule wf_on_multirel1)
 apply (rule_tac A = "field (r) -||> nat - {0}" in wf_on_subset_A)
 apply (simp (no_asm_simp))
 apply (rule field_rel_subset)
 apply (rule multirel1_type)
 done
 
 (** multirel **)
 
 lemma multirel_type: "multirel(A, r) \<subseteq> Mult(A)*Mult(A)"
 apply (simp add: multirel_def)
 apply (rule trancl_type [THEN subset_trans])
 apply (auto dest: multirel1_type [THEN subsetD])
 done
 
 (* Monotonicity of multirel *)
 lemma multirel_mono:
      "\<lbrakk>A\<subseteq>B; r\<subseteq>s\<rbrakk> \<Longrightarrow> multirel(A, r)\<subseteq>multirel(B,s)"
 apply (simp add: multirel_def)
 apply (rule trancl_mono)
 apply (rule multirel1_mono, auto)
 done
 
 (* Equivalence of multirel with the usual (closure-free) definition *)
 
 lemma add_diff_eq: "k \<in> nat \<Longrightarrow> 0 < k \<longrightarrow> n #+ k #- 1 = n #+ (k #- 1)"
 by (erule nat_induct, auto)
 
 lemma mdiff_union_single_conv: "\<lbrakk>a \<in> mset_of(J); multiset(I); multiset(J)\<rbrakk>
    \<Longrightarrow> I +# J -# {#a#} = I +# (J-# {#a#})"
 apply (simp (no_asm_simp) add: multiset_equality)
 apply (case_tac "a \<notin> mset_of (I) ")
 apply (auto simp add: mcount_def mset_of_def multiset_def multiset_fun_iff)
 apply (auto dest: domain_type simp add: add_diff_eq)
 done
 
 lemma diff_add_commute: "\<lbrakk>n \<le> m;  m \<in> nat; n \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> m #- n #+ k = m #+ k #- n"
 by (auto simp add: le_iff less_iff_succ_add)
 
 (* One direction *)
 
 lemma multirel_implies_one_step:
 "\<langle>M,N\<rangle> \<in> multirel(A, r) \<Longrightarrow>
      trans[A](r) \<longrightarrow>
      (\<exists>I J K.
          I \<in> Mult(A) \<and> J \<in> Mult(A) \<and>  K \<in> Mult(A) \<and>
          N = I +# J \<and> M = I +# K \<and> J \<noteq> 0 \<and>
         (\<forall>k \<in> mset_of(K). \<exists>j \<in> mset_of(J). \<langle>k,j\<rangle> \<in> r))"
 apply (simp add: multirel_def Ball_def Bex_def)
 apply (erule converse_trancl_induct)
 apply (simp_all add: multirel1_iff Mult_iff_multiset)
 (* Two subgoals remain *)
 (* Subgoal 1 *)
 apply clarify
 apply (rule_tac x = M0 in exI, force)
 (* Subgoal 2 *)
 apply clarify
 apply hypsubst_thin
 apply (case_tac "a \<in> mset_of (Ka) ")
 apply (rule_tac x = I in exI, simp (no_asm_simp))
 apply (rule_tac x = J in exI, simp (no_asm_simp))
 apply (rule_tac x = " (Ka -# {#a#}) +# K" in exI, simp (no_asm_simp))
 apply (simp_all add: Un_subset_iff)
 apply (simp (no_asm_simp) add: munion_assoc [symmetric])
 apply (drule_tac t = "\<lambda>M. M-#{#a#}" in subst_context)
 apply (simp add: mdiff_union_single_conv melem_diff_single, clarify)
 apply (erule disjE, simp)
 apply (erule disjE, simp)
 apply (drule_tac x = a and P = "\<lambda>x. x :# Ka \<longrightarrow> Q(x)" for Q in spec)
 apply clarify
 apply (rule_tac x = xa in exI)
 apply (simp (no_asm_simp))
 apply (blast dest: trans_onD)
 (* new we know that  a\<notin>mset_of(Ka) *)
 apply (subgoal_tac "a :# I")
 apply (rule_tac x = "I-#{#a#}" in exI, simp (no_asm_simp))
 apply (rule_tac x = "J+#{#a#}" in exI)
 apply (simp (no_asm_simp) add: Un_subset_iff)
 apply (rule_tac x = "Ka +# K" in exI)
 apply (simp (no_asm_simp) add: Un_subset_iff)
 apply (rule conjI)
 apply (simp (no_asm_simp) add: multiset_equality mcount_elem [THEN succ_pred_eq_self])
 apply (rule conjI)
 apply (drule_tac t = "\<lambda>M. M-#{#a#}" in subst_context)
 apply (simp add: mdiff_union_inverse2)
 apply (simp_all (no_asm_simp) add: multiset_equality)
 apply (rule diff_add_commute [symmetric])
 apply (auto intro: mcount_elem)
 apply (subgoal_tac "a \<in> mset_of (I +# Ka) ")
 apply (drule_tac [2] sym, auto)
 done
 
 lemma melem_imp_eq_diff_union [simp]: "\<lbrakk>a \<in> mset_of(M); multiset(M)\<rbrakk> \<Longrightarrow> M -# {#a#} +# {#a#} = M"
 by (simp add: multiset_equality mcount_elem [THEN succ_pred_eq_self])
 
 lemma msize_eq_succ_imp_eq_union:
      "\<lbrakk>msize(M)=$# succ(n); M \<in> Mult(A); n \<in> nat\<rbrakk>
       \<Longrightarrow> \<exists>a N. M = N +# {#a#} \<and> N \<in> Mult(A) \<and> a \<in> A"
 apply (drule msize_eq_succ_imp_elem, auto)
 apply (rule_tac x = a in exI)
 apply (rule_tac x = "M -# {#a#}" in exI)
 apply (frule Mult_into_multiset)
 apply (simp (no_asm_simp))
 apply (auto simp add: Mult_iff_multiset)
 done
 
 (* The second direction *)
 
 lemma one_step_implies_multirel_lemma [rule_format (no_asm)]:
 "n \<in> nat \<Longrightarrow>
    (\<forall>I J K.
     I \<in> Mult(A) \<and> J \<in> Mult(A) \<and> K \<in> Mult(A) \<and>
    (msize(J) = $# n \<and> J \<noteq>0 \<and>  (\<forall>k \<in> mset_of(K).  \<exists>j \<in> mset_of(J). \<langle>k, j\<rangle> \<in> r))
     \<longrightarrow> <I +# K, I +# J> \<in> multirel(A, r))"
 apply (simp add: Mult_iff_multiset)
 apply (erule nat_induct, clarify)
 apply (drule_tac M = J in msize_eq_0_iff, auto)
 (* one subgoal remains *)
 apply (subgoal_tac "msize (J) =$# succ (x) ")
  prefer 2 apply simp
 apply (frule_tac A = A in msize_eq_succ_imp_eq_union)
 apply (simp_all add: Mult_iff_multiset, clarify)
 apply (rename_tac "J'", simp)
 apply (case_tac "J' = 0")
 apply (simp add: multirel_def)
 apply (rule r_into_trancl, clarify)
 apply (simp add: multirel1_iff Mult_iff_multiset, force)
 (*Now we know J' \<noteq>  0*)
 apply (drule sym, rotate_tac -1, simp)
 apply (erule_tac V = "$# x = msize (J') " in thin_rl)
 apply (frule_tac M = K and P = "\<lambda>x. \<langle>x,a\<rangle> \<in> r" in multiset_partition)
 apply (erule_tac P = "\<forall>k \<in> mset_of (K) . P(k)" for P in rev_mp)
 apply (erule ssubst)
 apply (simp add: Ball_def, auto)
 apply (subgoal_tac "< (I +# {# x \<in> K. \<langle>x, a\<rangle> \<in> r#}) +# {# x \<in> K. \<langle>x, a\<rangle> \<notin> r#}, (I +# {# x \<in> K. \<langle>x, a\<rangle> \<in> r#}) +# J'> \<in> multirel(A, r) ")
  prefer 2
  apply (drule_tac x = "I +# {# x \<in> K. \<langle>x, a\<rangle> \<in> r#}" in spec)
  apply (rotate_tac -1)
  apply (drule_tac x = "J'" in spec)
  apply (rotate_tac -1)
  apply (drule_tac x = "{# x \<in> K. \<langle>x, a\<rangle> \<notin> r#}" in spec, simp) apply blast
 apply (simp add: munion_assoc [symmetric] multirel_def)
 apply (rule_tac b = "I +# {# x \<in> K. \<langle>x, a\<rangle> \<in> r#} +# J'" in trancl_trans, blast)
 apply (rule r_into_trancl)
 apply (simp add: multirel1_iff Mult_iff_multiset)
 apply (rule_tac x = a in exI)
 apply (simp (no_asm_simp))
 apply (rule_tac x = "I +# J'" in exI)
 apply (auto simp add: munion_ac Un_subset_iff)
 done
 
 lemma one_step_implies_multirel:
      "\<lbrakk>J \<noteq> 0;  \<forall>k \<in> mset_of(K). \<exists>j \<in> mset_of(J). \<langle>k,j\<rangle> \<in> r;
          I \<in> Mult(A); J \<in> Mult(A); K \<in> Mult(A)\<rbrakk>
       \<Longrightarrow> <I+#K, I+#J> \<in> multirel(A, r)"
 apply (subgoal_tac "multiset (J) ")
  prefer 2 apply (simp add: Mult_iff_multiset)
 apply (frule_tac M = J in msize_int_of_nat)
 apply (auto intro: one_step_implies_multirel_lemma)
 done
 
 (** Proving that multisets are partially ordered **)
 
 (*irreflexivity*)
 
 lemma multirel_irrefl_lemma:
      "Finite(A) \<Longrightarrow> part_ord(A, r) \<longrightarrow> (\<forall>x \<in> A. \<exists>y \<in> A. \<langle>x,y\<rangle> \<in> r) \<longrightarrow>A=0"
 apply (erule Finite_induct)
 apply (auto dest: subset_consI [THEN [2] part_ord_subset])
 apply (auto simp add: part_ord_def irrefl_def)
 apply (drule_tac x = xa in bspec)
 apply (drule_tac [2] a = xa and b = x in trans_onD, auto)
 done
 
 lemma irrefl_on_multirel:
      "part_ord(A, r) \<Longrightarrow> irrefl(Mult(A), multirel(A, r))"
 apply (simp add: irrefl_def)
 apply (subgoal_tac "trans[A](r) ")
  prefer 2 apply (simp add: part_ord_def, clarify)
 apply (drule multirel_implies_one_step, clarify)
 apply (simp add: Mult_iff_multiset, clarify)
 apply (subgoal_tac "Finite (mset_of (K))")
 apply (frule_tac r = r in multirel_irrefl_lemma)
 apply (frule_tac B = "mset_of (K) " in part_ord_subset)
 apply simp_all
 apply (auto simp add: multiset_def mset_of_def)
 done
 
 lemma trans_on_multirel: "trans[Mult(A)](multirel(A, r))"
 apply (simp add: multirel_def trans_on_def)
 apply (blast intro: trancl_trans)
 done
 
 lemma multirel_trans:
  "\<lbrakk>\<langle>M, N\<rangle> \<in> multirel(A, r); \<langle>N, K\<rangle> \<in> multirel(A, r)\<rbrakk> \<Longrightarrow>  \<langle>M, K\<rangle> \<in> multirel(A,r)"
 apply (simp add: multirel_def)
 apply (blast intro: trancl_trans)
 done
 
 lemma trans_multirel: "trans(multirel(A,r))"
 apply (simp add: multirel_def)
 apply (rule trans_trancl)
 done
 
 lemma part_ord_multirel: "part_ord(A,r) \<Longrightarrow> part_ord(Mult(A), multirel(A, r))"
 apply (simp (no_asm) add: part_ord_def)
 apply (blast intro: irrefl_on_multirel trans_on_multirel)
 done
 
 (** Monotonicity of multiset union **)
 
 lemma munion_multirel1_mono:
 "\<lbrakk>\<langle>M,N\<rangle> \<in> multirel1(A, r); K \<in> Mult(A)\<rbrakk> \<Longrightarrow> <K +# M, K +# N> \<in> multirel1(A, r)"
 apply (frule multirel1_type [THEN subsetD])
 apply (auto simp add: multirel1_iff Mult_iff_multiset)
 apply (rule_tac x = a in exI)
 apply (simp (no_asm_simp))
 apply (rule_tac x = "K+#M0" in exI)
 apply (simp (no_asm_simp) add: Un_subset_iff)
 apply (rule_tac x = Ka in exI)
 apply (simp (no_asm_simp) add: munion_assoc)
 done
 
 lemma munion_multirel_mono2:
  "\<lbrakk>\<langle>M, N\<rangle> \<in> multirel(A, r); K \<in> Mult(A)\<rbrakk>\<Longrightarrow><K +# M, K +# N> \<in> multirel(A, r)"
 apply (frule multirel_type [THEN subsetD])
 apply (simp (no_asm_use) add: multirel_def)
 apply clarify
 apply (drule_tac psi = "\<langle>M,N\<rangle> \<in> multirel1 (A, r) ^+" in asm_rl)
 apply (erule rev_mp)
 apply (erule rev_mp)
 apply (erule rev_mp)
 apply (erule trancl_induct, clarify)
 apply (blast intro: munion_multirel1_mono r_into_trancl, clarify)
 apply (subgoal_tac "y \<in> Mult(A) ")
  prefer 2
  apply (blast dest: multirel_type [unfolded multirel_def, THEN subsetD])
 apply (subgoal_tac "<K +# y, K +# z> \<in> multirel1 (A, r) ")
 prefer 2 apply (blast intro: munion_multirel1_mono)
 apply (blast intro: r_into_trancl trancl_trans)
 done
 
 lemma munion_multirel_mono1:
      "\<lbrakk>\<langle>M, N\<rangle> \<in> multirel(A, r); K \<in> Mult(A)\<rbrakk> \<Longrightarrow> <M +# K, N +# K> \<in> multirel(A, r)"
 apply (frule multirel_type [THEN subsetD])
 apply (rule_tac P = "\<lambda>x. \<langle>x,u\<rangle> \<in> multirel(A, r)" for u in munion_commute [THEN subst])
 apply (subst munion_commute [of N])
 apply (rule munion_multirel_mono2)
 apply (auto simp add: Mult_iff_multiset)
 done
 
 lemma munion_multirel_mono:
      "\<lbrakk>\<langle>M,K\<rangle> \<in> multirel(A, r); \<langle>N,L\<rangle> \<in> multirel(A, r)\<rbrakk>
       \<Longrightarrow> <M +# N, K +# L> \<in> multirel(A, r)"
 apply (subgoal_tac "M \<in> Mult(A) \<and> N \<in> Mult(A) \<and> K \<in> Mult(A) \<and> L \<in> Mult(A) ")
 prefer 2 apply (blast dest: multirel_type [THEN subsetD])
 apply (blast intro: munion_multirel_mono1 multirel_trans munion_multirel_mono2)
 done
 
 
 subsection\<open>Ordinal Multisets\<close>
 
 (* A \<subseteq> B \<Longrightarrow>  field(Memrel(A)) \<subseteq> field(Memrel(B)) *)
 lemmas field_Memrel_mono = Memrel_mono [THEN field_mono]
 
 (*
 \<lbrakk>Aa \<subseteq> Ba; A \<subseteq> B\<rbrakk> \<Longrightarrow>
 multirel(field(Memrel(Aa)), Memrel(A))\<subseteq> multirel(field(Memrel(Ba)), Memrel(B))
 *)
 
 lemmas multirel_Memrel_mono = multirel_mono [OF field_Memrel_mono Memrel_mono]
 
 lemma omultiset_is_multiset [simp]: "omultiset(M) \<Longrightarrow> multiset(M)"
 apply (simp add: omultiset_def)
 apply (auto simp add: Mult_iff_multiset)
 done
 
 lemma munion_omultiset [simp]: "\<lbrakk>omultiset(M); omultiset(N)\<rbrakk> \<Longrightarrow> omultiset(M +# N)"
 apply (simp add: omultiset_def, clarify)
 apply (rule_tac x = "i \<union> ia" in exI)
 apply (simp add: Mult_iff_multiset Ord_Un Un_subset_iff)
 apply (blast intro: field_Memrel_mono)
 done
 
 lemma mdiff_omultiset [simp]: "omultiset(M) \<Longrightarrow> omultiset(M -# N)"
 apply (simp add: omultiset_def, clarify)
 apply (simp add: Mult_iff_multiset)
 apply (rule_tac x = i in exI)
 apply (simp (no_asm_simp))
 done
 
 (** Proving that Memrel is a partial order **)
 
 lemma irrefl_Memrel: "Ord(i) \<Longrightarrow> irrefl(field(Memrel(i)), Memrel(i))"
 apply (rule irreflI, clarify)
 apply (subgoal_tac "Ord (x) ")
 prefer 2 apply (blast intro: Ord_in_Ord)
 apply (drule_tac i = x in ltI [THEN lt_irrefl], auto)
 done
 
 lemma trans_iff_trans_on: "trans(r) \<longleftrightarrow> trans[field(r)](r)"
 by (simp add: trans_on_def trans_def, auto)
 
 lemma part_ord_Memrel: "Ord(i) \<Longrightarrow>part_ord(field(Memrel(i)), Memrel(i))"
 apply (simp add: part_ord_def)
 apply (simp (no_asm) add: trans_iff_trans_on [THEN iff_sym])
 apply (blast intro: trans_Memrel irrefl_Memrel)
 done
 
 (*
   Ord(i) \<Longrightarrow>
   part_ord(field(Memrel(i))-||>nat-{0}, multirel(field(Memrel(i)), Memrel(i)))
 *)
 
 lemmas part_ord_mless = part_ord_Memrel [THEN part_ord_multirel]
 
 (*irreflexivity*)
 
 lemma mless_not_refl: "\<not>(M <# M)"
 apply (simp add: mless_def, clarify)
 apply (frule multirel_type [THEN subsetD])
 apply (drule part_ord_mless)
 apply (simp add: part_ord_def irrefl_def)
 done
 
 (* N<N \<Longrightarrow> R *)
 lemmas mless_irrefl = mless_not_refl [THEN notE, elim!]
 
 (*transitivity*)
 lemma mless_trans: "\<lbrakk>K <# M; M <# N\<rbrakk> \<Longrightarrow> K <# N"
 apply (simp add: mless_def, clarify)
 apply (rule_tac x = "i \<union> ia" in exI)
 apply (blast dest: multirel_Memrel_mono [OF Un_upper1 Un_upper1, THEN subsetD]
                    multirel_Memrel_mono [OF Un_upper2 Un_upper2, THEN subsetD]
         intro: multirel_trans Ord_Un)
 done
 
 (*asymmetry*)
 lemma mless_not_sym: "M <# N \<Longrightarrow> \<not> N <# M"
 apply clarify
 apply (rule mless_not_refl [THEN notE])
 apply (erule mless_trans, assumption)
 done
 
 lemma mless_asym: "\<lbrakk>M <# N; \<not>P \<Longrightarrow> N <# M\<rbrakk> \<Longrightarrow> P"
 by (blast dest: mless_not_sym)
 
 lemma mle_refl [simp]: "omultiset(M) \<Longrightarrow> M <#= M"
 by (simp add: mle_def)
 
 (*anti-symmetry*)
 lemma mle_antisym:
      "\<lbrakk>M <#= N;  N <#= M\<rbrakk> \<Longrightarrow> M = N"
 apply (simp add: mle_def)
 apply (blast dest: mless_not_sym)
 done
 
 (*transitivity*)
 lemma mle_trans: "\<lbrakk>K <#= M; M <#= N\<rbrakk> \<Longrightarrow> K <#= N"
 apply (simp add: mle_def)
 apply (blast intro: mless_trans)
 done
 
 lemma mless_le_iff: "M <# N \<longleftrightarrow> (M <#= N \<and> M \<noteq> N)"
 by (simp add: mle_def, auto)
 
 (** Monotonicity of mless **)
 
 lemma munion_less_mono2: "\<lbrakk>M <# N; omultiset(K)\<rbrakk> \<Longrightarrow> K +# M <# K +# N"
 apply (simp add: mless_def omultiset_def, clarify)
 apply (rule_tac x = "i \<union> ia" in exI)
 apply (simp add: Mult_iff_multiset Ord_Un Un_subset_iff)
 apply (rule munion_multirel_mono2)
  apply (blast intro: multirel_Memrel_mono [THEN subsetD])
 apply (simp add: Mult_iff_multiset)
 apply (blast intro: field_Memrel_mono [THEN subsetD])
 done
 
 lemma munion_less_mono1: "\<lbrakk>M <# N; omultiset(K)\<rbrakk> \<Longrightarrow> M +# K <# N +# K"
 by (force dest: munion_less_mono2 simp add: munion_commute)
 
 lemma mless_imp_omultiset: "M <# N \<Longrightarrow> omultiset(M) \<and> omultiset(N)"
 by (auto simp add: mless_def omultiset_def dest: multirel_type [THEN subsetD])
 
 lemma munion_less_mono: "\<lbrakk>M <# K; N <# L\<rbrakk> \<Longrightarrow> M +# N <# K +# L"
 apply (frule_tac M = M in mless_imp_omultiset)
 apply (frule_tac M = N in mless_imp_omultiset)
 apply (blast intro: munion_less_mono1 munion_less_mono2 mless_trans)
 done
 
 (* <#= *)
 
 lemma mle_imp_omultiset: "M <#= N \<Longrightarrow> omultiset(M) \<and> omultiset(N)"
 by (auto simp add: mle_def mless_imp_omultiset)
 
 lemma mle_mono: "\<lbrakk>M <#= K;  N <#= L\<rbrakk> \<Longrightarrow> M +# N <#= K +# L"
 apply (frule_tac M = M in mle_imp_omultiset)
 apply (frule_tac M = N in mle_imp_omultiset)
 apply (auto simp add: mle_def intro: munion_less_mono1 munion_less_mono2 munion_less_mono)
 done
 
 lemma omultiset_0 [iff]: "omultiset(0)"
 by (auto simp add: omultiset_def Mult_iff_multiset)
 
 lemma empty_leI [simp]: "omultiset(M) \<Longrightarrow> 0 <#= M"
 apply (simp add: mle_def mless_def)
 apply (subgoal_tac "\<exists>i. Ord (i) \<and> M \<in> Mult(field(Memrel(i))) ")
  prefer 2 apply (simp add: omultiset_def)
 apply (case_tac "M=0", simp_all, clarify)
 apply (subgoal_tac "<0 +# 0, 0 +# M> \<in> multirel(field (Memrel(i)), Memrel(i))")
 apply (rule_tac [2] one_step_implies_multirel)
 apply (auto simp add: Mult_iff_multiset)
 done
 
 lemma munion_upper1: "\<lbrakk>omultiset(M); omultiset(N)\<rbrakk> \<Longrightarrow> M <#= M +# N"
 apply (subgoal_tac "M +# 0 <#= M +# N")
 apply (rule_tac [2] mle_mono, auto)
 done
 
 end
diff --git a/src/ZF/Induct/Ntree.thy b/src/ZF/Induct/Ntree.thy
--- a/src/ZF/Induct/Ntree.thy
+++ b/src/ZF/Induct/Ntree.thy
@@ -1,174 +1,174 @@
 (*  Title:      ZF/Induct/Ntree.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section \<open>Datatype definition n-ary branching trees\<close>
 
 theory Ntree imports ZF begin
 
 text \<open>
   Demonstrates a simple use of function space in a datatype
   definition.  Based upon theory \<open>Term\<close>.
 \<close>
 
 consts
   ntree :: "i \<Rightarrow> i"
   maptree :: "i \<Rightarrow> i"
   maptree2 :: "[i, i] \<Rightarrow> i"
 
 datatype "ntree(A)" = Branch ("a \<in> A", "h \<in> (\<Union>n \<in> nat. n -> ntree(A))")
   monos UN_mono [OF subset_refl Pi_mono]  \<comment> \<open>MUST have this form\<close>
   type_intros nat_fun_univ [THEN subsetD]
   type_elims UN_E
 
 datatype "maptree(A)" = Sons ("a \<in> A", "h \<in> maptree(A) -||> maptree(A)")
   monos FiniteFun_mono1  \<comment> \<open>Use monotonicity in BOTH args\<close>
   type_intros FiniteFun_univ1 [THEN subsetD]
 
 datatype "maptree2(A, B)" = Sons2 ("a \<in> A", "h \<in> B -||> maptree2(A, B)")
   monos FiniteFun_mono [OF subset_refl]
   type_intros FiniteFun_in_univ'
 
 definition
   ntree_rec :: "[[i, i, i] \<Rightarrow> i, i] \<Rightarrow> i"  where
   "ntree_rec(b) \<equiv>
     Vrecursor(\<lambda>pr. ntree_case(\<lambda>x h. b(x, h, \<lambda>i \<in> domain(h). pr`(h`i))))"
 
 definition
   ntree_copy :: "i \<Rightarrow> i"  where
   "ntree_copy(z) \<equiv> ntree_rec(\<lambda>x h r. Branch(x,r), z)"
 
 
 text \<open>
   \medskip \<open>ntree\<close>
 \<close>
 
 lemma ntree_unfold: "ntree(A) = A \<times> (\<Union>n \<in> nat. n -> ntree(A))"
   by (blast intro: ntree.intros [unfolded ntree.con_defs]
     elim: ntree.cases [unfolded ntree.con_defs])
 
 lemma ntree_induct [consumes 1, case_names Branch, induct set: ntree]:
   assumes t: "t \<in> ntree(A)"
     and step: "\<And>x n h. \<lbrakk>x \<in> A;  n \<in> nat;  h \<in> n -> ntree(A);  \<forall>i \<in> n. P(h`i)
 \<rbrakk> \<Longrightarrow> P(Branch(x,h))"
   shows "P(t)"
   \<comment> \<open>A nicer induction rule than the standard one.\<close>
   using t
   apply induct
   apply (erule UN_E)
   apply (assumption | rule step)+
    apply (fast elim: fun_weaken_type)
   apply (fast dest: apply_type)
   done
 
 lemma ntree_induct_eqn [consumes 1]:
   assumes t: "t \<in> ntree(A)"
     and f: "f \<in> ntree(A)->B"
     and g: "g \<in> ntree(A)->B"
     and step: "\<And>x n h. \<lbrakk>x \<in> A;  n \<in> nat;  h \<in> n -> ntree(A);  f O h = g O h\<rbrakk> \<Longrightarrow>
       f ` Branch(x,h) = g ` Branch(x,h)"
   shows "f`t=g`t"
   \<comment> \<open>Induction on \<^term>\<open>ntree(A)\<close> to prove an equation\<close>
   using t
   apply induct
   apply (assumption | rule step)+
   apply (insert f g)
   apply (rule fun_extension)
   apply (assumption | rule comp_fun)+
   apply (simp add: comp_fun_apply)
   done
 
 text \<open>
   \medskip Lemmas to justify using \<open>Ntree\<close> in other recursive
   type definitions.
 \<close>
 
 lemma ntree_mono: "A \<subseteq> B \<Longrightarrow> ntree(A) \<subseteq> ntree(B)"
-  apply (unfold ntree.defs)
+    unfolding ntree.defs
   apply (rule lfp_mono)
     apply (rule ntree.bnd_mono)+
   apply (assumption | rule univ_mono basic_monos)+
   done
 
 lemma ntree_univ: "ntree(univ(A)) \<subseteq> univ(A)"
   \<comment> \<open>Easily provable by induction also\<close>
-  apply (unfold ntree.defs ntree.con_defs)
+    unfolding ntree.defs ntree.con_defs
   apply (rule lfp_lowerbound)
    apply (rule_tac [2] A_subset_univ [THEN univ_mono])
   apply (blast intro: Pair_in_univ nat_fun_univ [THEN subsetD])
   done
 
 lemma ntree_subset_univ: "A \<subseteq> univ(B) \<Longrightarrow> ntree(A) \<subseteq> univ(B)"
   by (rule subset_trans [OF ntree_mono ntree_univ])
 
 
 text \<open>
   \medskip \<open>ntree\<close> recursion.
 \<close>
 
 lemma ntree_rec_Branch:
     "function(h) \<Longrightarrow>
      ntree_rec(b, Branch(x,h)) = b(x, h, \<lambda>i \<in> domain(h). ntree_rec(b, h`i))"
   apply (rule ntree_rec_def [THEN def_Vrecursor, THEN trans])
   apply (simp add: ntree.con_defs rank_pair2 [THEN [2] lt_trans] rank_apply)
   done
 
 lemma ntree_copy_Branch [simp]:
     "function(h) \<Longrightarrow>
      ntree_copy (Branch(x, h)) = Branch(x, \<lambda>i \<in> domain(h). ntree_copy (h`i))"
   by (simp add: ntree_copy_def ntree_rec_Branch)
 
 lemma ntree_copy_is_ident: "z \<in> ntree(A) \<Longrightarrow> ntree_copy(z) = z"
   by (induct z set: ntree)
     (auto simp add: domain_of_fun Pi_Collect_iff fun_is_function)
 
 
 text \<open>
   \medskip \<open>maptree\<close>
 \<close>
 
 lemma maptree_unfold: "maptree(A) = A \<times> (maptree(A) -||> maptree(A))"
   by (fast intro!: maptree.intros [unfolded maptree.con_defs]
     elim: maptree.cases [unfolded maptree.con_defs])
 
 lemma maptree_induct [consumes 1, induct set: maptree]:
   assumes t: "t \<in> maptree(A)"
     and step: "\<And>x n h. \<lbrakk>x \<in> A;  h \<in> maptree(A) -||> maptree(A);
                   \<forall>y \<in> field(h). P(y)
 \<rbrakk> \<Longrightarrow> P(Sons(x,h))"
   shows "P(t)"
   \<comment> \<open>A nicer induction rule than the standard one.\<close>
   using t
   apply induct
   apply (assumption | rule step)+
   apply (erule Collect_subset [THEN FiniteFun_mono1, THEN subsetD])
   apply (drule FiniteFun.dom_subset [THEN subsetD])
   apply (drule Fin.dom_subset [THEN subsetD])
   apply fast
   done
 
 
 text \<open>
   \medskip \<open>maptree2\<close>
 \<close>
 
 lemma maptree2_unfold: "maptree2(A, B) = A \<times> (B -||> maptree2(A, B))"
   by (fast intro!: maptree2.intros [unfolded maptree2.con_defs]
     elim: maptree2.cases [unfolded maptree2.con_defs])
 
 lemma maptree2_induct [consumes 1, induct set: maptree2]:
   assumes t: "t \<in> maptree2(A, B)"
     and step: "\<And>x n h. \<lbrakk>x \<in> A;  h \<in> B -||> maptree2(A,B);  \<forall>y \<in> range(h). P(y)
 \<rbrakk> \<Longrightarrow> P(Sons2(x,h))"
   shows "P(t)"
   using t
   apply induct
   apply (assumption | rule step)+
    apply (erule FiniteFun_mono [OF subset_refl Collect_subset, THEN subsetD])
    apply (drule FiniteFun.dom_subset [THEN subsetD])
    apply (drule Fin.dom_subset [THEN subsetD])
    apply fast
    done
 
 end
diff --git a/src/ZF/Induct/PropLog.thy b/src/ZF/Induct/PropLog.thy
--- a/src/ZF/Induct/PropLog.thy
+++ b/src/ZF/Induct/PropLog.thy
@@ -1,340 +1,340 @@
 (*  Title:      ZF/Induct/PropLog.thy
     Author:     Tobias Nipkow \<and> Lawrence C Paulson
     Copyright   1993  University of Cambridge
 *)
 
 section \<open>Meta-theory of propositional logic\<close>
 
 theory PropLog imports ZF begin
 
 text \<open>
   Datatype definition of propositional logic formulae and inductive
   definition of the propositional tautologies.
 
   Inductive definition of propositional logic.  Soundness and
   completeness w.r.t.\ truth-tables.
 
   Prove: If \<open>H |= p\<close> then \<open>G |= p\<close> where \<open>G \<in>
   Fin(H)\<close>
 \<close>
 
 
 subsection \<open>The datatype of propositions\<close>
 
 consts
   propn :: i
 
 datatype propn =
     Fls
   | Var ("n \<in> nat")    (\<open>#_\<close> [100] 100)
   | Imp ("p \<in> propn", "q \<in> propn")    (infixr \<open>\<Rightarrow>\<close> 90)
 
 
 subsection \<open>The proof system\<close>
 
 consts thms     :: "i \<Rightarrow> i"
 
 abbreviation
   thms_syntax :: "[i,i] \<Rightarrow> o"    (infixl \<open>|-\<close> 50)
   where "H |- p \<equiv> p \<in> thms(H)"
 
 inductive
   domains "thms(H)" \<subseteq> "propn"
   intros
     H:  "\<lbrakk>p \<in> H;  p \<in> propn\<rbrakk> \<Longrightarrow> H |- p"
     K:  "\<lbrakk>p \<in> propn;  q \<in> propn\<rbrakk> \<Longrightarrow> H |- p\<Rightarrow>q\<Rightarrow>p"
     S:  "\<lbrakk>p \<in> propn;  q \<in> propn;  r \<in> propn\<rbrakk>
          \<Longrightarrow> H |- (p\<Rightarrow>q\<Rightarrow>r) \<Rightarrow> (p\<Rightarrow>q) \<Rightarrow> p\<Rightarrow>r"
     DN: "p \<in> propn \<Longrightarrow> H |- ((p\<Rightarrow>Fls) \<Rightarrow> Fls) \<Rightarrow> p"
     MP: "\<lbrakk>H |- p\<Rightarrow>q;  H |- p;  p \<in> propn;  q \<in> propn\<rbrakk> \<Longrightarrow> H |- q"
   type_intros "propn.intros"
 
 declare propn.intros [simp]
 
 
 subsection \<open>The semantics\<close>
 
 subsubsection \<open>Semantics of propositional logic.\<close>
 
 consts
   is_true_fun :: "[i,i] \<Rightarrow> i"
 primrec
   "is_true_fun(Fls, t) = 0"
   "is_true_fun(Var(v), t) = (if v \<in> t then 1 else 0)"
   "is_true_fun(p\<Rightarrow>q, t) = (if is_true_fun(p,t) = 1 then is_true_fun(q,t) else 1)"
 
 definition
   is_true :: "[i,i] \<Rightarrow> o"  where
   "is_true(p,t) \<equiv> is_true_fun(p,t) = 1"
   \<comment> \<open>this definition is required since predicates can't be recursive\<close>
 
 lemma is_true_Fls [simp]: "is_true(Fls,t) \<longleftrightarrow> False"
   by (simp add: is_true_def)
 
 lemma is_true_Var [simp]: "is_true(#v,t) \<longleftrightarrow> v \<in> t"
   by (simp add: is_true_def)
 
 lemma is_true_Imp [simp]: "is_true(p\<Rightarrow>q,t) \<longleftrightarrow> (is_true(p,t)\<longrightarrow>is_true(q,t))"
   by (simp add: is_true_def)
 
 
 subsubsection \<open>Logical consequence\<close>
 
 text \<open>
   For every valuation, if all elements of \<open>H\<close> are true then so
   is \<open>p\<close>.
 \<close>
 
 definition
   logcon :: "[i,i] \<Rightarrow> o"    (infixl \<open>|=\<close> 50)  where
   "H |= p \<equiv> \<forall>t. (\<forall>q \<in> H. is_true(q,t)) \<longrightarrow> is_true(p,t)"
 
 
 text \<open>
   A finite set of hypotheses from \<open>t\<close> and the \<open>Var\<close>s in
   \<open>p\<close>.
 \<close>
 
 consts
   hyps :: "[i,i] \<Rightarrow> i"
 primrec
   "hyps(Fls, t) = 0"
   "hyps(Var(v), t) = (if v \<in> t then {#v} else {#v\<Rightarrow>Fls})"
   "hyps(p\<Rightarrow>q, t) = hyps(p,t) \<union> hyps(q,t)"
 
 
 
 subsection \<open>Proof theory of propositional logic\<close>
 
 lemma thms_mono: "G \<subseteq> H \<Longrightarrow> thms(G) \<subseteq> thms(H)"
-  apply (unfold thms.defs)
+    unfolding thms.defs
   apply (rule lfp_mono)
     apply (rule thms.bnd_mono)+
   apply (assumption | rule univ_mono basic_monos)+
   done
 
 lemmas thms_in_pl = thms.dom_subset [THEN subsetD]
 
 inductive_cases ImpE: "p\<Rightarrow>q \<in> propn"
 
 lemma thms_MP: "\<lbrakk>H |- p\<Rightarrow>q;  H |- p\<rbrakk> \<Longrightarrow> H |- q"
   \<comment> \<open>Stronger Modus Ponens rule: no typechecking!\<close>
   apply (rule thms.MP)
      apply (erule asm_rl thms_in_pl thms_in_pl [THEN ImpE])+
   done
 
 lemma thms_I: "p \<in> propn \<Longrightarrow> H |- p\<Rightarrow>p"
   \<comment> \<open>Rule is called \<open>I\<close> for Identity Combinator, not for Introduction.\<close>
   apply (rule thms.S [THEN thms_MP, THEN thms_MP])
       apply (rule_tac [5] thms.K)
        apply (rule_tac [4] thms.K)
          apply simp_all
   done
 
 
 subsubsection \<open>Weakening, left and right\<close>
 
 lemma weaken_left: "\<lbrakk>G \<subseteq> H;  G|-p\<rbrakk> \<Longrightarrow> H|-p"
   \<comment> \<open>Order of premises is convenient with \<open>THEN\<close>\<close>
   by (erule thms_mono [THEN subsetD])
 
 lemma weaken_left_cons: "H |- p \<Longrightarrow> cons(a,H) |- p"
   by (erule subset_consI [THEN weaken_left])
 
 lemmas weaken_left_Un1  = Un_upper1 [THEN weaken_left]
 lemmas weaken_left_Un2  = Un_upper2 [THEN weaken_left]
 
 lemma weaken_right: "\<lbrakk>H |- q;  p \<in> propn\<rbrakk> \<Longrightarrow> H |- p\<Rightarrow>q"
   by (simp_all add: thms.K [THEN thms_MP] thms_in_pl)
 
 
 subsubsection \<open>The deduction theorem\<close>
 
 theorem deduction: "\<lbrakk>cons(p,H) |- q;  p \<in> propn\<rbrakk> \<Longrightarrow>  H |- p\<Rightarrow>q"
   apply (erule thms.induct)
       apply (blast intro: thms_I thms.H [THEN weaken_right])
      apply (blast intro: thms.K [THEN weaken_right])
     apply (blast intro: thms.S [THEN weaken_right])
    apply (blast intro: thms.DN [THEN weaken_right])
   apply (blast intro: thms.S [THEN thms_MP [THEN thms_MP]])
   done
 
 
 subsubsection \<open>The cut rule\<close>
 
 lemma cut: "\<lbrakk>H|-p;  cons(p,H) |- q\<rbrakk> \<Longrightarrow>  H |- q"
   apply (rule deduction [THEN thms_MP])
     apply (simp_all add: thms_in_pl)
   done
 
 lemma thms_FlsE: "\<lbrakk>H |- Fls; p \<in> propn\<rbrakk> \<Longrightarrow> H |- p"
   apply (rule thms.DN [THEN thms_MP])
    apply (rule_tac [2] weaken_right)
     apply (simp_all add: propn.intros)
   done
 
 lemma thms_notE: "\<lbrakk>H |- p\<Rightarrow>Fls;  H |- p;  q \<in> propn\<rbrakk> \<Longrightarrow> H |- q"
   by (erule thms_MP [THEN thms_FlsE])
 
 
 subsubsection \<open>Soundness of the rules wrt truth-table semantics\<close>
 
 theorem soundness: "H |- p \<Longrightarrow> H |= p"
     unfolding logcon_def
   apply (induct set: thms)
       apply auto
   done
 
 
 subsection \<open>Completeness\<close>
 
 subsubsection \<open>Towards the completeness proof\<close>
 
 lemma Fls_Imp: "\<lbrakk>H |- p\<Rightarrow>Fls; q \<in> propn\<rbrakk> \<Longrightarrow> H |- p\<Rightarrow>q"
   apply (frule thms_in_pl)
   apply (rule deduction)
    apply (rule weaken_left_cons [THEN thms_notE])
      apply (blast intro: thms.H elim: ImpE)+
   done
 
 lemma Imp_Fls: "\<lbrakk>H |- p;  H |- q\<Rightarrow>Fls\<rbrakk> \<Longrightarrow> H |- (p\<Rightarrow>q)\<Rightarrow>Fls"
   apply (frule thms_in_pl)
   apply (frule thms_in_pl [of concl: "q\<Rightarrow>Fls"])
   apply (rule deduction)
    apply (erule weaken_left_cons [THEN thms_MP])
    apply (rule consI1 [THEN thms.H, THEN thms_MP])
     apply (blast intro: weaken_left_cons elim: ImpE)+
   done
 
 lemma hyps_thms_if:
     "p \<in> propn \<Longrightarrow> hyps(p,t) |- (if is_true(p,t) then p else p\<Rightarrow>Fls)"
   \<comment> \<open>Typical example of strengthening the induction statement.\<close>
   apply simp
   apply (induct_tac p)
     apply (simp_all add: thms_I thms.H)
   apply (safe elim!: Fls_Imp [THEN weaken_left_Un1] Fls_Imp [THEN weaken_left_Un2])
   apply (blast intro: weaken_left_Un1 weaken_left_Un2 weaken_right Imp_Fls)+
   done
 
 lemma logcon_thms_p: "\<lbrakk>p \<in> propn;  0 |= p\<rbrakk> \<Longrightarrow> hyps(p,t) |- p"
   \<comment> \<open>Key lemma for completeness; yields a set of assumptions satisfying \<open>p\<close>\<close>
   apply (drule hyps_thms_if)
   apply (simp add: logcon_def)
   done
 
 text \<open>
   For proving certain theorems in our new propositional logic.
 \<close>
 
 lemmas propn_SIs = propn.intros deduction
   and propn_Is = thms_in_pl thms.H thms.H [THEN thms_MP]
 
 text \<open>
   The excluded middle in the form of an elimination rule.
 \<close>
 
 lemma thms_excluded_middle:
     "\<lbrakk>p \<in> propn;  q \<in> propn\<rbrakk> \<Longrightarrow> H |- (p\<Rightarrow>q) \<Rightarrow> ((p\<Rightarrow>Fls)\<Rightarrow>q) \<Rightarrow> q"
   apply (rule deduction [THEN deduction])
     apply (rule thms.DN [THEN thms_MP])
      apply (best intro!: propn_SIs intro: propn_Is)+
   done
 
 lemma thms_excluded_middle_rule:
   "\<lbrakk>cons(p,H) |- q;  cons(p\<Rightarrow>Fls,H) |- q;  p \<in> propn\<rbrakk> \<Longrightarrow> H |- q"
   \<comment> \<open>Hard to prove directly because it requires cuts\<close>
   apply (rule thms_excluded_middle [THEN thms_MP, THEN thms_MP])
      apply (blast intro!: propn_SIs intro: propn_Is)+
   done
 
 
 subsubsection \<open>Completeness -- lemmas for reducing the set of assumptions\<close>
 
 text \<open>
   For the case \<^prop>\<open>hyps(p,t)-cons(#v,Y) |- p\<close> we also have \<^prop>\<open>hyps(p,t)-{#v} \<subseteq> hyps(p, t-{v})\<close>.
 \<close>
 
 lemma hyps_Diff:
     "p \<in> propn \<Longrightarrow> hyps(p, t-{v}) \<subseteq> cons(#v\<Rightarrow>Fls, hyps(p,t)-{#v})"
   by (induct set: propn) auto
 
 text \<open>
   For the case \<^prop>\<open>hyps(p,t)-cons(#v \<Rightarrow> Fls,Y) |- p\<close> we also have
   \<^prop>\<open>hyps(p,t)-{#v\<Rightarrow>Fls} \<subseteq> hyps(p, cons(v,t))\<close>.
 \<close>
 
 lemma hyps_cons:
     "p \<in> propn \<Longrightarrow> hyps(p, cons(v,t)) \<subseteq> cons(#v, hyps(p,t)-{#v\<Rightarrow>Fls})"
   by (induct set: propn) auto
 
 text \<open>Two lemmas for use with \<open>weaken_left\<close>\<close>
 
 lemma cons_Diff_same: "B-C \<subseteq> cons(a, B-cons(a,C))"
   by blast
 
 lemma cons_Diff_subset2: "cons(a, B-{c}) - D \<subseteq> cons(a, B-cons(c,D))"
   by blast
 
 text \<open>
   The set \<^term>\<open>hyps(p,t)\<close> is finite, and elements have the form
   \<^term>\<open>#v\<close> or \<^term>\<open>#v\<Rightarrow>Fls\<close>; could probably prove the stronger
   \<^prop>\<open>hyps(p,t) \<in> Fin(hyps(p,0) \<union> hyps(p,nat))\<close>.
 \<close>
 
 lemma hyps_finite: "p \<in> propn \<Longrightarrow> hyps(p,t) \<in> Fin(\<Union>v \<in> nat. {#v, #v\<Rightarrow>Fls})"
   by (induct set: propn) auto
 
 lemmas Diff_weaken_left = Diff_mono [OF _ subset_refl, THEN weaken_left]
 
 text \<open>
   Induction on the finite set of assumptions \<^term>\<open>hyps(p,t0)\<close>.  We
   may repeatedly subtract assumptions until none are left!
 \<close>
 
 lemma completeness_0_lemma [rule_format]:
     "\<lbrakk>p \<in> propn;  0 |= p\<rbrakk> \<Longrightarrow> \<forall>t. hyps(p,t) - hyps(p,t0) |- p"
   apply (frule hyps_finite)
   apply (erule Fin_induct)
    apply (simp add: logcon_thms_p Diff_0)
   txt \<open>inductive step\<close>
   apply safe
    txt \<open>Case \<^prop>\<open>hyps(p,t)-cons(#v,Y) |- p\<close>\<close>
    apply (rule thms_excluded_middle_rule)
      apply (erule_tac [3] propn.intros)
     apply (blast intro: cons_Diff_same [THEN weaken_left])
    apply (blast intro: cons_Diff_subset2 [THEN weaken_left]
      hyps_Diff [THEN Diff_weaken_left])
   txt \<open>Case \<^prop>\<open>hyps(p,t)-cons(#v \<Rightarrow> Fls,Y) |- p\<close>\<close>
   apply (rule thms_excluded_middle_rule)
     apply (erule_tac [3] propn.intros)
    apply (blast intro: cons_Diff_subset2 [THEN weaken_left]
      hyps_cons [THEN Diff_weaken_left])
   apply (blast intro: cons_Diff_same [THEN weaken_left])
   done
 
 
 subsubsection \<open>Completeness theorem\<close>
 
 lemma completeness_0: "\<lbrakk>p \<in> propn;  0 |= p\<rbrakk> \<Longrightarrow> 0 |- p"
   \<comment> \<open>The base case for completeness\<close>
   apply (rule Diff_cancel [THEN subst])
   apply (blast intro: completeness_0_lemma)
   done
 
 lemma logcon_Imp: "\<lbrakk>cons(p,H) |= q\<rbrakk> \<Longrightarrow> H |= p\<Rightarrow>q"
   \<comment> \<open>A semantic analogue of the Deduction Theorem\<close>
   by (simp add: logcon_def)
 
 lemma completeness:
      "H \<in> Fin(propn) \<Longrightarrow> p \<in> propn \<Longrightarrow> H |= p \<Longrightarrow> H |- p"
   apply (induct arbitrary: p set: Fin)
    apply (safe intro!: completeness_0)
   apply (rule weaken_left_cons [THEN thms_MP])
    apply (blast intro!: logcon_Imp propn.intros)
   apply (blast intro: propn_Is)
   done
 
 theorem thms_iff: "H \<in> Fin(propn) \<Longrightarrow> H |- p \<longleftrightarrow> H |= p \<and> p \<in> propn"
   by (blast intro: soundness completeness thms_in_pl)
 
 end
diff --git a/src/ZF/Induct/Rmap.thy b/src/ZF/Induct/Rmap.thy
--- a/src/ZF/Induct/Rmap.thy
+++ b/src/ZF/Induct/Rmap.thy
@@ -1,70 +1,70 @@
 (*  Title:      ZF/Induct/Rmap.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section \<open>An operator to ``map'' a relation over a list\<close>
 
 theory Rmap imports ZF begin
 
 consts
   rmap :: "i\<Rightarrow>i"
 
 inductive
   domains "rmap(r)" \<subseteq> "list(domain(r)) \<times> list(range(r))"
   intros
     NilI:  "\<langle>Nil,Nil\<rangle> \<in> rmap(r)"
 
     ConsI: "\<lbrakk>\<langle>x,y\<rangle>: r;  \<langle>xs,ys\<rangle> \<in> rmap(r)\<rbrakk>
             \<Longrightarrow> <Cons(x,xs), Cons(y,ys)> \<in> rmap(r)"
 
   type_intros domainI rangeI list.intros
 
 lemma rmap_mono: "r \<subseteq> s \<Longrightarrow> rmap(r) \<subseteq> rmap(s)"
-  apply (unfold rmap.defs)
+    unfolding rmap.defs
   apply (rule lfp_mono)
     apply (rule rmap.bnd_mono)+
   apply (assumption | rule Sigma_mono list_mono domain_mono range_mono basic_monos)+
   done
 
 inductive_cases
       Nil_rmap_case [elim!]: "\<langle>Nil,zs\<rangle> \<in> rmap(r)"
   and Cons_rmap_case [elim!]: "<Cons(x,xs),zs> \<in> rmap(r)"
 
 declare rmap.intros [intro]
 
 lemma rmap_rel_type: "r \<subseteq> A \<times> B \<Longrightarrow> rmap(r) \<subseteq> list(A) \<times> list(B)"
   apply (rule rmap.dom_subset [THEN subset_trans])
   apply (assumption |
     rule domain_rel_subset range_rel_subset Sigma_mono list_mono)+
   done
 
 lemma rmap_total: "A \<subseteq> domain(r) \<Longrightarrow> list(A) \<subseteq> domain(rmap(r))"
   apply (rule subsetI)
   apply (erule list.induct)
    apply blast+
   done
 
 lemma rmap_functional: "function(r) \<Longrightarrow> function(rmap(r))"
     unfolding function_def
   apply (rule impI [THEN allI, THEN allI])
   apply (erule rmap.induct)
    apply blast+
   done
 
 text \<open>
   \medskip If \<open>f\<close> is a function then \<open>rmap(f)\<close> behaves
   as expected.
 \<close>
 
 lemma rmap_fun_type: "f \<in> A->B \<Longrightarrow> rmap(f): list(A)->list(B)"
   by (simp add: Pi_iff rmap_rel_type rmap_functional rmap_total)
 
 lemma rmap_Nil: "rmap(f)`Nil = Nil"
   by (unfold apply_def) blast
 
 lemma rmap_Cons: "\<lbrakk>f \<in> A->B;  x \<in> A;  xs: list(A)\<rbrakk>
       \<Longrightarrow> rmap(f) ` Cons(x,xs) = Cons(f`x, rmap(f)`xs)"
   by (blast intro: apply_equality apply_Pair rmap_fun_type rmap.intros)
 
 end
diff --git a/src/ZF/Induct/Term.thy b/src/ZF/Induct/Term.thy
--- a/src/ZF/Induct/Term.thy
+++ b/src/ZF/Induct/Term.thy
@@ -1,284 +1,284 @@
 (*  Title:      ZF/Induct/Term.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section \<open>Terms over an alphabet\<close>
 
 theory Term imports ZF begin
 
 text \<open>
   Illustrates the list functor (essentially the same type as in \<open>Trees_Forest\<close>).
 \<close>
 
 consts
   "term" :: "i \<Rightarrow> i"
 
 datatype "term(A)" = Apply ("a \<in> A", "l \<in> list(term(A))")
   monos list_mono
   type_elims list_univ [THEN subsetD, elim_format]
 
 declare Apply [TC]
 
 definition
   term_rec :: "[i, [i, i, i] \<Rightarrow> i] \<Rightarrow> i"  where
   "term_rec(t,d) \<equiv>
     Vrec(t, \<lambda>t g. term_case(\<lambda>x zs. d(x, zs, map(\<lambda>z. g`z, zs)), t))"
 
 definition
   term_map :: "[i \<Rightarrow> i, i] \<Rightarrow> i"  where
   "term_map(f,t) \<equiv> term_rec(t, \<lambda>x zs rs. Apply(f(x), rs))"
 
 definition
   term_size :: "i \<Rightarrow> i"  where
   "term_size(t) \<equiv> term_rec(t, \<lambda>x zs rs. succ(list_add(rs)))"
 
 definition
   reflect :: "i \<Rightarrow> i"  where
   "reflect(t) \<equiv> term_rec(t, \<lambda>x zs rs. Apply(x, rev(rs)))"
 
 definition
   preorder :: "i \<Rightarrow> i"  where
   "preorder(t) \<equiv> term_rec(t, \<lambda>x zs rs. Cons(x, flat(rs)))"
 
 definition
   postorder :: "i \<Rightarrow> i"  where
   "postorder(t) \<equiv> term_rec(t, \<lambda>x zs rs. flat(rs) @ [x])"
 
 lemma term_unfold: "term(A) = A * list(term(A))"
   by (fast intro!: term.intros [unfolded term.con_defs]
     elim: term.cases [unfolded term.con_defs])
 
 lemma term_induct2:
   "\<lbrakk>t \<in> term(A);
       \<And>x.      \<lbrakk>x \<in> A\<rbrakk> \<Longrightarrow> P(Apply(x,Nil));
       \<And>x z zs. \<lbrakk>x \<in> A;  z \<in> term(A);  zs: list(term(A));  P(Apply(x,zs))
 \<rbrakk> \<Longrightarrow> P(Apply(x, Cons(z,zs)))
 \<rbrakk> \<Longrightarrow> P(t)"
   \<comment> \<open>Induction on \<^term>\<open>term(A)\<close> followed by induction on \<^term>\<open>list\<close>.\<close>
   apply (induct_tac t)
   apply (erule list.induct)
    apply (auto dest: list_CollectD)
   done
 
 lemma term_induct_eqn [consumes 1, case_names Apply]:
   "\<lbrakk>t \<in> term(A);
       \<And>x zs. \<lbrakk>x \<in> A;  zs: list(term(A));  map(f,zs) = map(g,zs)\<rbrakk> \<Longrightarrow>
               f(Apply(x,zs)) = g(Apply(x,zs))
 \<rbrakk> \<Longrightarrow> f(t) = g(t)"
   \<comment> \<open>Induction on \<^term>\<open>term(A)\<close> to prove an equation.\<close>
   apply (induct_tac t)
   apply (auto dest: map_list_Collect list_CollectD)
   done
 
 text \<open>
   \medskip Lemmas to justify using \<^term>\<open>term\<close> in other recursive
   type definitions.
 \<close>
 
 lemma term_mono: "A \<subseteq> B \<Longrightarrow> term(A) \<subseteq> term(B)"
-  apply (unfold term.defs)
+    unfolding term.defs
   apply (rule lfp_mono)
     apply (rule term.bnd_mono)+
   apply (rule univ_mono basic_monos| assumption)+
   done
 
 lemma term_univ: "term(univ(A)) \<subseteq> univ(A)"
   \<comment> \<open>Easily provable by induction also\<close>
-  apply (unfold term.defs term.con_defs)
+    unfolding term.defs term.con_defs
   apply (rule lfp_lowerbound)
    apply (rule_tac [2] A_subset_univ [THEN univ_mono])
   apply safe
   apply (assumption | rule Pair_in_univ list_univ [THEN subsetD])+
   done
 
 lemma term_subset_univ: "A \<subseteq> univ(B) \<Longrightarrow> term(A) \<subseteq> univ(B)"
   apply (rule subset_trans)
    apply (erule term_mono)
   apply (rule term_univ)
   done
 
 lemma term_into_univ: "\<lbrakk>t \<in> term(A);  A \<subseteq> univ(B)\<rbrakk> \<Longrightarrow> t \<in> univ(B)"
   by (rule term_subset_univ [THEN subsetD])
 
 text \<open>
   \medskip \<open>term_rec\<close> -- by \<open>Vset\<close> recursion.
 \<close>
 
 lemma map_lemma: "\<lbrakk>l \<in> list(A);  Ord(i);  rank(l)<i\<rbrakk>
     \<Longrightarrow> map(\<lambda>z. (\<lambda>x \<in> Vset(i).h(x)) ` z, l) = map(h,l)"
   \<comment> \<open>\<^term>\<open>map\<close> works correctly on the underlying list of terms.\<close>
   apply (induct set: list)
    apply simp
   apply (subgoal_tac "rank (a) <i \<and> rank (l) < i")
    apply (simp add: rank_of_Ord)
   apply (simp add: list.con_defs)
   apply (blast dest: rank_rls [THEN lt_trans])
   done
 
 lemma term_rec [simp]: "ts \<in> list(A) \<Longrightarrow>
   term_rec(Apply(a,ts), d) = d(a, ts, map (\<lambda>z. term_rec(z,d), ts))"
   \<comment> \<open>Typing premise is necessary to invoke \<open>map_lemma\<close>.\<close>
   apply (rule term_rec_def [THEN def_Vrec, THEN trans])
-  apply (unfold term.con_defs)
+    unfolding term.con_defs
   apply (simp add: rank_pair2 map_lemma)
   done
 
 lemma term_rec_type:
   assumes t: "t \<in> term(A)"
     and a: "\<And>x zs r. \<lbrakk>x \<in> A;  zs: list(term(A));
                    r \<in> list(\<Union>t \<in> term(A). C(t))\<rbrakk>
                 \<Longrightarrow> d(x, zs, r): C(Apply(x,zs))"
   shows "term_rec(t,d) \<in> C(t)"
   \<comment> \<open>Slightly odd typing condition on \<open>r\<close> in the second premise!\<close>
   using t
   apply induct
   apply (frule list_CollectD)
   apply (subst term_rec)
    apply (assumption | rule a)+
   apply (erule list.induct)
    apply auto
   done
 
 lemma def_term_rec:
   "\<lbrakk>\<And>t. j(t)\<equiv>term_rec(t,d);  ts: list(A)\<rbrakk> \<Longrightarrow>
     j(Apply(a,ts)) = d(a, ts, map(\<lambda>Z. j(Z), ts))"
   apply (simp only:)
   apply (erule term_rec)
   done
 
 lemma term_rec_simple_type [TC]:
   "\<lbrakk>t \<in> term(A);
       \<And>x zs r. \<lbrakk>x \<in> A;  zs: list(term(A));  r \<in> list(C)\<rbrakk>
                 \<Longrightarrow> d(x, zs, r): C
 \<rbrakk> \<Longrightarrow> term_rec(t,d) \<in> C"
   apply (erule term_rec_type)
   apply (drule subset_refl [THEN UN_least, THEN list_mono, THEN subsetD])
   apply simp
   done
 
 
 text \<open>
   \medskip \<^term>\<open>term_map\<close>.
 \<close>
 
 lemma term_map [simp]:
   "ts \<in> list(A) \<Longrightarrow>
     term_map(f, Apply(a, ts)) = Apply(f(a), map(term_map(f), ts))"
   by (rule term_map_def [THEN def_term_rec])
 
 lemma term_map_type [TC]:
     "\<lbrakk>t \<in> term(A);  \<And>x. x \<in> A \<Longrightarrow> f(x): B\<rbrakk> \<Longrightarrow> term_map(f,t) \<in> term(B)"
     unfolding term_map_def
   apply (erule term_rec_simple_type)
   apply fast
   done
 
 lemma term_map_type2 [TC]:
     "t \<in> term(A) \<Longrightarrow> term_map(f,t) \<in> term({f(u). u \<in> A})"
   apply (erule term_map_type)
   apply (erule RepFunI)
   done
 
 text \<open>
   \medskip \<^term>\<open>term_size\<close>.
 \<close>
 
 lemma term_size [simp]:
     "ts \<in> list(A) \<Longrightarrow> term_size(Apply(a, ts)) = succ(list_add(map(term_size, ts)))"
   by (rule term_size_def [THEN def_term_rec])
 
 lemma term_size_type [TC]: "t \<in> term(A) \<Longrightarrow> term_size(t) \<in> nat"
   by (auto simp add: term_size_def)
 
 
 text \<open>
   \medskip \<open>reflect\<close>.
 \<close>
 
 lemma reflect [simp]:
     "ts \<in> list(A) \<Longrightarrow> reflect(Apply(a, ts)) = Apply(a, rev(map(reflect, ts)))"
   by (rule reflect_def [THEN def_term_rec])
 
 lemma reflect_type [TC]: "t \<in> term(A) \<Longrightarrow> reflect(t) \<in> term(A)"
   by (auto simp add: reflect_def)
 
 
 text \<open>
   \medskip \<open>preorder\<close>.
 \<close>
 
 lemma preorder [simp]:
     "ts \<in> list(A) \<Longrightarrow> preorder(Apply(a, ts)) = Cons(a, flat(map(preorder, ts)))"
   by (rule preorder_def [THEN def_term_rec])
 
 lemma preorder_type [TC]: "t \<in> term(A) \<Longrightarrow> preorder(t) \<in> list(A)"
   by (simp add: preorder_def)
 
 
 text \<open>
   \medskip \<open>postorder\<close>.
 \<close>
 
 lemma postorder [simp]:
     "ts \<in> list(A) \<Longrightarrow> postorder(Apply(a, ts)) = flat(map(postorder, ts)) @ [a]"
   by (rule postorder_def [THEN def_term_rec])
 
 lemma postorder_type [TC]: "t \<in> term(A) \<Longrightarrow> postorder(t) \<in> list(A)"
   by (simp add: postorder_def)
 
 
 text \<open>
   \medskip Theorems about \<open>term_map\<close>.
 \<close>
 
 declare map_compose [simp]
 
 lemma term_map_ident: "t \<in> term(A) \<Longrightarrow> term_map(\<lambda>u. u, t) = t"
   by (induct rule: term_induct_eqn) simp
 
 lemma term_map_compose:
     "t \<in> term(A) \<Longrightarrow> term_map(f, term_map(g,t)) = term_map(\<lambda>u. f(g(u)), t)"
   by (induct rule: term_induct_eqn) simp
 
 lemma term_map_reflect:
     "t \<in> term(A) \<Longrightarrow> term_map(f, reflect(t)) = reflect(term_map(f,t))"
   by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric])
 
 
 text \<open>
   \medskip Theorems about \<open>term_size\<close>.
 \<close>
 
 lemma term_size_term_map: "t \<in> term(A) \<Longrightarrow> term_size(term_map(f,t)) = term_size(t)"
   by (induct rule: term_induct_eqn) simp
 
 lemma term_size_reflect: "t \<in> term(A) \<Longrightarrow> term_size(reflect(t)) = term_size(t)"
   by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric] list_add_rev)
 
 lemma term_size_length: "t \<in> term(A) \<Longrightarrow> term_size(t) = length(preorder(t))"
   by (induct rule: term_induct_eqn) (simp add: length_flat)
 
 
 text \<open>
   \medskip Theorems about \<open>reflect\<close>.
 \<close>
 
 lemma reflect_reflect_ident: "t \<in> term(A) \<Longrightarrow> reflect(reflect(t)) = t"
   by (induct rule: term_induct_eqn) (simp add: rev_map_distrib)
 
 
 text \<open>
   \medskip Theorems about preorder.
 \<close>
 
 lemma preorder_term_map:
     "t \<in> term(A) \<Longrightarrow> preorder(term_map(f,t)) = map(f, preorder(t))"
   by (induct rule: term_induct_eqn) (simp add: map_flat)
 
 lemma preorder_reflect_eq_rev_postorder:
     "t \<in> term(A) \<Longrightarrow> preorder(reflect(t)) = rev(postorder(t))"
   by (induct rule: term_induct_eqn)
     (simp add: rev_app_distrib rev_flat rev_map_distrib [symmetric])
 
 end
diff --git a/src/ZF/Induct/Tree_Forest.thy b/src/ZF/Induct/Tree_Forest.thy
--- a/src/ZF/Induct/Tree_Forest.thy
+++ b/src/ZF/Induct/Tree_Forest.thy
@@ -1,251 +1,251 @@
 (*  Title:      ZF/Induct/Tree_Forest.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section \<open>Trees and forests, a mutually recursive type definition\<close>
 
 theory Tree_Forest imports ZF begin
 
 subsection \<open>Datatype definition\<close>
 
 consts
   tree :: "i \<Rightarrow> i"
   forest :: "i \<Rightarrow> i"
   tree_forest :: "i \<Rightarrow> i"
 
 datatype "tree(A)" = Tcons ("a \<in> A", "f \<in> forest(A)")
   and "forest(A)" = Fnil | Fcons ("t \<in> tree(A)", "f \<in> forest(A)")
 
 (* FIXME *)
 lemmas tree'induct =
     tree_forest.mutual_induct [THEN conjunct1, THEN spec, THEN [2] rev_mp, of concl: _ t, consumes 1]
   and forest'induct =
     tree_forest.mutual_induct [THEN conjunct2, THEN spec, THEN [2] rev_mp, of concl: _ f, consumes 1]
   for t f
 
 declare tree_forest.intros [simp, TC]
 
 lemma tree_def: "tree(A) \<equiv> Part(tree_forest(A), Inl)"
   by (simp only: tree_forest.defs)
 
 lemma forest_def: "forest(A) \<equiv> Part(tree_forest(A), Inr)"
   by (simp only: tree_forest.defs)
 
 
 text \<open>
   \medskip \<^term>\<open>tree_forest(A)\<close> as the union of \<^term>\<open>tree(A)\<close>
   and \<^term>\<open>forest(A)\<close>.
 \<close>
 
 lemma tree_subset_TF: "tree(A) \<subseteq> tree_forest(A)"
-  apply (unfold tree_forest.defs)
+    unfolding tree_forest.defs
   apply (rule Part_subset)
   done
 
 lemma treeI [TC]: "x \<in> tree(A) \<Longrightarrow> x \<in> tree_forest(A)"
   by (rule tree_subset_TF [THEN subsetD])
 
 lemma forest_subset_TF: "forest(A) \<subseteq> tree_forest(A)"
-  apply (unfold tree_forest.defs)
+    unfolding tree_forest.defs
   apply (rule Part_subset)
   done
 
 lemma treeI' [TC]: "x \<in> forest(A) \<Longrightarrow> x \<in> tree_forest(A)"
   by (rule forest_subset_TF [THEN subsetD])
 
 lemma TF_equals_Un: "tree(A) \<union> forest(A) = tree_forest(A)"
   apply (insert tree_subset_TF forest_subset_TF)
   apply (auto intro!: equalityI tree_forest.intros elim: tree_forest.cases)
   done
 
 lemma tree_forest_unfold:
   "tree_forest(A) = (A \<times> forest(A)) + ({0} + tree(A) \<times> forest(A))"
     \<comment> \<open>NOT useful, but interesting \dots\<close>
   supply rews = tree_forest.con_defs tree_def forest_def
-  apply (unfold tree_def forest_def)
+    unfolding tree_def forest_def
   apply (fast intro!: tree_forest.intros [unfolded rews, THEN PartD1]
     elim: tree_forest.cases [unfolded rews])
   done
 
 lemma tree_forest_unfold':
   "tree_forest(A) =
     A \<times> Part(tree_forest(A), \<lambda>w. Inr(w)) +
     {0} + Part(tree_forest(A), \<lambda>w. Inl(w)) * Part(tree_forest(A), \<lambda>w. Inr(w))"
   by (rule tree_forest_unfold [unfolded tree_def forest_def])
 
 lemma tree_unfold: "tree(A) = {Inl(x). x \<in> A \<times> forest(A)}"
-  apply (unfold tree_def forest_def)
+    unfolding tree_def forest_def
   apply (rule Part_Inl [THEN subst])
   apply (rule tree_forest_unfold' [THEN subst_context])
   done
 
 lemma forest_unfold: "forest(A) = {Inr(x). x \<in> {0} + tree(A)*forest(A)}"
-  apply (unfold tree_def forest_def)
+    unfolding tree_def forest_def
   apply (rule Part_Inr [THEN subst])
   apply (rule tree_forest_unfold' [THEN subst_context])
   done
 
 text \<open>
   \medskip Type checking for recursor: Not needed; possibly interesting?
 \<close>
 
 lemma TF_rec_type:
   "\<lbrakk>z \<in> tree_forest(A);
       \<And>x f r. \<lbrakk>x \<in> A;  f \<in> forest(A);  r \<in> C(f)
 \<rbrakk> \<Longrightarrow> b(x,f,r) \<in> C(Tcons(x,f));
       c \<in> C(Fnil);
       \<And>t f r1 r2. \<lbrakk>t \<in> tree(A);  f \<in> forest(A);  r1 \<in> C(t); r2 \<in> C(f)
 \<rbrakk> \<Longrightarrow> d(t,f,r1,r2) \<in> C(Fcons(t,f))
 \<rbrakk> \<Longrightarrow> tree_forest_rec(b,c,d,z) \<in> C(z)"
   by (induct_tac z) simp_all
 
 lemma tree_forest_rec_type:
   "\<lbrakk>\<And>x f r. \<lbrakk>x \<in> A;  f \<in> forest(A);  r \<in> D(f)
 \<rbrakk> \<Longrightarrow> b(x,f,r) \<in> C(Tcons(x,f));
       c \<in> D(Fnil);
       \<And>t f r1 r2. \<lbrakk>t \<in> tree(A);  f \<in> forest(A);  r1 \<in> C(t); r2 \<in> D(f)
 \<rbrakk> \<Longrightarrow> d(t,f,r1,r2) \<in> D(Fcons(t,f))
 \<rbrakk> \<Longrightarrow> (\<forall>t \<in> tree(A).    tree_forest_rec(b,c,d,t) \<in> C(t)) \<and>
           (\<forall>f \<in> forest(A). tree_forest_rec(b,c,d,f) \<in> D(f))"
     \<comment> \<open>Mutually recursive version.\<close>
     unfolding Ball_def
   apply (rule tree_forest.mutual_induct)
   apply simp_all
   done
 
 
 subsection \<open>Operations\<close>
 
 consts
   map :: "[i \<Rightarrow> i, i] \<Rightarrow> i"
   size :: "i \<Rightarrow> i"
   preorder :: "i \<Rightarrow> i"
   list_of_TF :: "i \<Rightarrow> i"
   of_list :: "i \<Rightarrow> i"
   reflect :: "i \<Rightarrow> i"
 
 primrec
   "list_of_TF (Tcons(x,f)) = [Tcons(x,f)]"
   "list_of_TF (Fnil) = []"
   "list_of_TF (Fcons(t,tf)) = Cons (t, list_of_TF(tf))"
 
 primrec
   "of_list([]) = Fnil"
   "of_list(Cons(t,l)) = Fcons(t, of_list(l))"
 
 primrec
   "map (h, Tcons(x,f)) = Tcons(h(x), map(h,f))"
   "map (h, Fnil) = Fnil"
   "map (h, Fcons(t,tf)) = Fcons (map(h, t), map(h, tf))"
 
 primrec
   "size (Tcons(x,f)) = succ(size(f))"
   "size (Fnil) = 0"
   "size (Fcons(t,tf)) = size(t) #+ size(tf)"
 
 primrec
   "preorder (Tcons(x,f)) = Cons(x, preorder(f))"
   "preorder (Fnil) = Nil"
   "preorder (Fcons(t,tf)) = preorder(t) @ preorder(tf)"
 
 primrec
   "reflect (Tcons(x,f)) = Tcons(x, reflect(f))"
   "reflect (Fnil) = Fnil"
   "reflect (Fcons(t,tf)) =
     of_list (list_of_TF (reflect(tf)) @ Cons(reflect(t), Nil))"
 
 
 text \<open>
   \medskip \<open>list_of_TF\<close> and \<open>of_list\<close>.
 \<close>
 
 lemma list_of_TF_type [TC]:
     "z \<in> tree_forest(A) \<Longrightarrow> list_of_TF(z) \<in> list(tree(A))"
   by (induct set: tree_forest) simp_all
 
 lemma of_list_type [TC]: "l \<in> list(tree(A)) \<Longrightarrow> of_list(l) \<in> forest(A)"
   by (induct set: list) simp_all
 
 text \<open>
   \medskip \<open>map\<close>.
 \<close>
 
 lemma
   assumes "\<And>x. x \<in> A \<Longrightarrow> h(x): B"
   shows map_tree_type: "t \<in> tree(A) \<Longrightarrow> map(h,t) \<in> tree(B)"
     and map_forest_type: "f \<in> forest(A) \<Longrightarrow> map(h,f) \<in> forest(B)"
   using assms
   by (induct rule: tree'induct forest'induct) simp_all
 
 text \<open>
   \medskip \<open>size\<close>.
 \<close>
 
 lemma size_type [TC]: "z \<in> tree_forest(A) \<Longrightarrow> size(z) \<in> nat"
   by (induct set: tree_forest) simp_all
 
 
 text \<open>
   \medskip \<open>preorder\<close>.
 \<close>
 
 lemma preorder_type [TC]: "z \<in> tree_forest(A) \<Longrightarrow> preorder(z) \<in> list(A)"
   by (induct set: tree_forest) simp_all
 
 
 text \<open>
   \medskip Theorems about \<open>list_of_TF\<close> and \<open>of_list\<close>.
 \<close>
 
 lemma forest_induct [consumes 1, case_names Fnil Fcons]:
   "\<lbrakk>f \<in> forest(A);
       R(Fnil);
       \<And>t f. \<lbrakk>t \<in> tree(A);  f \<in> forest(A);  R(f)\<rbrakk> \<Longrightarrow> R(Fcons(t,f))
 \<rbrakk> \<Longrightarrow> R(f)"
   \<comment> \<open>Essentially the same as list induction.\<close>
   apply (erule tree_forest.mutual_induct
       [THEN conjunct2, THEN spec, THEN [2] rev_mp])
     apply (rule TrueI)
    apply simp
   apply simp
   done
 
 lemma forest_iso: "f \<in> forest(A) \<Longrightarrow> of_list(list_of_TF(f)) = f"
   by (induct rule: forest_induct) simp_all
 
 lemma tree_list_iso: "ts: list(tree(A)) \<Longrightarrow> list_of_TF(of_list(ts)) = ts"
   by (induct set: list) simp_all
 
 
 text \<open>
   \medskip Theorems about \<open>map\<close>.
 \<close>
 
 lemma map_ident: "z \<in> tree_forest(A) \<Longrightarrow> map(\<lambda>u. u, z) = z"
   by (induct set: tree_forest) simp_all
 
 lemma map_compose:
     "z \<in> tree_forest(A) \<Longrightarrow> map(h, map(j,z)) = map(\<lambda>u. h(j(u)), z)"
   by (induct set: tree_forest) simp_all
 
 
 text \<open>
   \medskip Theorems about \<open>size\<close>.
 \<close>
 
 lemma size_map: "z \<in> tree_forest(A) \<Longrightarrow> size(map(h,z)) = size(z)"
   by (induct set: tree_forest) simp_all
 
 lemma size_length: "z \<in> tree_forest(A) \<Longrightarrow> size(z) = length(preorder(z))"
   by (induct set: tree_forest) (simp_all add: length_app)
 
 text \<open>
   \medskip Theorems about \<open>preorder\<close>.
 \<close>
 
 lemma preorder_map:
     "z \<in> tree_forest(A) \<Longrightarrow> preorder(map(h,z)) = List.map(h, preorder(z))"
   by (induct set: tree_forest) (simp_all add: map_app_distrib)
 
 end
diff --git a/src/ZF/List.thy b/src/ZF/List.thy
--- a/src/ZF/List.thy
+++ b/src/ZF/List.thy
@@ -1,1270 +1,1270 @@
 (*  Title:      ZF/List.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section\<open>Lists in Zermelo-Fraenkel Set Theory\<close>
 
 theory List imports Datatype ArithSimp begin
 
 consts
   list       :: "i\<Rightarrow>i"
 
 datatype
   "list(A)" = Nil | Cons ("a \<in> A", "l \<in> list(A)")
 
 
 syntax
  "_Nil" :: i  (\<open>[]\<close>)
  "_List" :: "is \<Rightarrow> i"  (\<open>[(_)]\<close>)
 
 translations
   "[x, xs]"     == "CONST Cons(x, [xs])"
   "[x]"         == "CONST Cons(x, [])"
   "[]"          == "CONST Nil"
 
 
 consts
   length :: "i\<Rightarrow>i"
   hd     :: "i\<Rightarrow>i"
   tl     :: "i\<Rightarrow>i"
 
 primrec
   "length([]) = 0"
   "length(Cons(a,l)) = succ(length(l))"
 
 primrec
   "hd([]) = 0"
   "hd(Cons(a,l)) = a"
 
 primrec
   "tl([]) = []"
   "tl(Cons(a,l)) = l"
 
 
 consts
   map         :: "[i\<Rightarrow>i, i] \<Rightarrow> i"
   set_of_list :: "i\<Rightarrow>i"
   app         :: "[i,i]\<Rightarrow>i"                        (infixr \<open>@\<close> 60)
 
 (*map is a binding operator -- it applies to meta-level functions, not
 object-level functions.  This simplifies the final form of term_rec_conv,
 although complicating its derivation.*)
 primrec
   "map(f,[]) = []"
   "map(f,Cons(a,l)) = Cons(f(a), map(f,l))"
 
 primrec
   "set_of_list([]) = 0"
   "set_of_list(Cons(a,l)) = cons(a, set_of_list(l))"
 
 primrec
   app_Nil:  "[] @ ys = ys"
   app_Cons: "(Cons(a,l)) @ ys = Cons(a, l @ ys)"
 
 
 consts
   rev :: "i\<Rightarrow>i"
   flat       :: "i\<Rightarrow>i"
   list_add   :: "i\<Rightarrow>i"
 
 primrec
   "rev([]) = []"
   "rev(Cons(a,l)) = rev(l) @ [a]"
 
 primrec
   "flat([]) = []"
   "flat(Cons(l,ls)) = l @ flat(ls)"
 
 primrec
   "list_add([]) = 0"
   "list_add(Cons(a,l)) = a #+ list_add(l)"
 
 consts
   drop       :: "[i,i]\<Rightarrow>i"
 
 primrec
   drop_0:    "drop(0,l) = l"
   drop_succ: "drop(succ(i), l) = tl (drop(i,l))"
 
 
 (*** Thanks to Sidi Ehmety for the following ***)
 
 definition
 (* Function `take' returns the first n elements of a list *)
   take     :: "[i,i]\<Rightarrow>i"  where
   "take(n, as) \<equiv> list_rec(\<lambda>n\<in>nat. [],
                 \<lambda>a l r. \<lambda>n\<in>nat. nat_case([], \<lambda>m. Cons(a, r`m), n), as)`n"
 
 definition
   nth :: "[i, i]\<Rightarrow>i"  where
   \<comment> \<open>returns the (n+1)th element of a list, or 0 if the
    list is too short.\<close>
   "nth(n, as) \<equiv> list_rec(\<lambda>n\<in>nat. 0,
                           \<lambda>a l r. \<lambda>n\<in>nat. nat_case(a, \<lambda>m. r`m, n), as) ` n"
 
 definition
   list_update :: "[i, i, i]\<Rightarrow>i"  where
   "list_update(xs, i, v) \<equiv> list_rec(\<lambda>n\<in>nat. Nil,
       \<lambda>u us vs. \<lambda>n\<in>nat. nat_case(Cons(v, us), \<lambda>m. Cons(u, vs`m), n), xs)`i"
 
 consts
   filter :: "[i\<Rightarrow>o, i] \<Rightarrow> i"
   upt :: "[i, i] \<Rightarrow>i"
 
 primrec
   "filter(P, Nil) = Nil"
   "filter(P, Cons(x, xs)) =
      (if P(x) then Cons(x, filter(P, xs)) else filter(P, xs))"
 
 primrec
   "upt(i, 0) = Nil"
   "upt(i, succ(j)) = (if i \<le> j then upt(i, j)@[j] else Nil)"
 
 definition
   min :: "[i,i] \<Rightarrow>i"  where
     "min(x, y) \<equiv> (if x \<le> y then x else y)"
 
 definition
   max :: "[i, i] \<Rightarrow>i"  where
     "max(x, y) \<equiv> (if x \<le> y then y else x)"
 
 (*** Aspects of the datatype definition ***)
 
 declare list.intros [simp,TC]
 
 (*An elimination rule, for type-checking*)
 inductive_cases ConsE: "Cons(a,l) \<in> list(A)"
 
 lemma Cons_type_iff [simp]: "Cons(a,l) \<in> list(A) \<longleftrightarrow> a \<in> A \<and> l \<in> list(A)"
 by (blast elim: ConsE)
 
 (*Proving freeness results*)
 lemma Cons_iff: "Cons(a,l)=Cons(a',l') \<longleftrightarrow> a=a' \<and> l=l'"
 by auto
 
 lemma Nil_Cons_iff: "\<not> Nil=Cons(a,l)"
 by auto
 
 lemma list_unfold: "list(A) = {0} + (A * list(A))"
 by (blast intro!: list.intros [unfolded list.con_defs]
           elim: list.cases [unfolded list.con_defs])
 
 
 (**  Lemmas to justify using "list" in other recursive type definitions **)
 
 lemma list_mono: "A<=B \<Longrightarrow> list(A) \<subseteq> list(B)"
-apply (unfold list.defs )
+  unfolding list.defs 
 apply (rule lfp_mono)
 apply (simp_all add: list.bnd_mono)
 apply (assumption | rule univ_mono basic_monos)+
 done
 
 (*There is a similar proof by list induction.*)
 lemma list_univ: "list(univ(A)) \<subseteq> univ(A)"
-apply (unfold list.defs list.con_defs)
+  unfolding list.defs list.con_defs
 apply (rule lfp_lowerbound)
 apply (rule_tac [2] A_subset_univ [THEN univ_mono])
 apply (blast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
 done
 
 (*These two theorems justify datatypes involving list(nat), list(A), ...*)
 lemmas list_subset_univ = subset_trans [OF list_mono list_univ]
 
 lemma list_into_univ: "\<lbrakk>l \<in> list(A);  A \<subseteq> univ(B)\<rbrakk> \<Longrightarrow> l \<in> univ(B)"
 by (blast intro: list_subset_univ [THEN subsetD])
 
 lemma list_case_type:
     "\<lbrakk>l \<in> list(A);
         c \<in> C(Nil);
         \<And>x y. \<lbrakk>x \<in> A;  y \<in> list(A)\<rbrakk> \<Longrightarrow> h(x,y): C(Cons(x,y))
 \<rbrakk> \<Longrightarrow> list_case(c,h,l) \<in> C(l)"
 by (erule list.induct, auto)
 
 lemma list_0_triv: "list(0) = {Nil}"
 apply (rule equalityI, auto)
 apply (induct_tac x, auto)
 done
 
 
 (*** List functions ***)
 
 lemma tl_type: "l \<in> list(A) \<Longrightarrow> tl(l) \<in> list(A)"
 apply (induct_tac "l")
 apply (simp_all (no_asm_simp) add: list.intros)
 done
 
 (** drop **)
 
 lemma drop_Nil [simp]: "i \<in> nat \<Longrightarrow> drop(i, Nil) = Nil"
 apply (induct_tac "i")
 apply (simp_all (no_asm_simp))
 done
 
 lemma drop_succ_Cons [simp]: "i \<in> nat \<Longrightarrow> drop(succ(i), Cons(a,l)) = drop(i,l)"
 apply (rule sym)
 apply (induct_tac "i")
 apply (simp (no_asm))
 apply (simp (no_asm_simp))
 done
 
 lemma drop_type [simp,TC]: "\<lbrakk>i \<in> nat; l \<in> list(A)\<rbrakk> \<Longrightarrow> drop(i,l) \<in> list(A)"
 apply (induct_tac "i")
 apply (simp_all (no_asm_simp) add: tl_type)
 done
 
 declare drop_succ [simp del]
 
 
 (** Type checking -- proved by induction, as usual **)
 
 lemma list_rec_type [TC]:
     "\<lbrakk>l \<in> list(A);
         c \<in> C(Nil);
         \<And>x y r. \<lbrakk>x \<in> A;  y \<in> list(A);  r \<in> C(y)\<rbrakk> \<Longrightarrow> h(x,y,r): C(Cons(x,y))
 \<rbrakk> \<Longrightarrow> list_rec(c,h,l) \<in> C(l)"
 by (induct_tac "l", auto)
 
 (** map **)
 
 lemma map_type [TC]:
     "\<lbrakk>l \<in> list(A);  \<And>x. x \<in> A \<Longrightarrow> h(x): B\<rbrakk> \<Longrightarrow> map(h,l) \<in> list(B)"
 apply (simp add: map_list_def)
 apply (typecheck add: list.intros list_rec_type, blast)
 done
 
 lemma map_type2 [TC]: "l \<in> list(A) \<Longrightarrow> map(h,l) \<in> list({h(u). u \<in> A})"
 apply (erule map_type)
 apply (erule RepFunI)
 done
 
 (** length **)
 
 lemma length_type [TC]: "l \<in> list(A) \<Longrightarrow> length(l) \<in> nat"
 by (simp add: length_list_def)
 
 lemma lt_length_in_nat:
    "\<lbrakk>x < length(xs); xs \<in> list(A)\<rbrakk> \<Longrightarrow> x \<in> nat"
 by (frule lt_nat_in_nat, typecheck)
 
 (** app **)
 
 lemma app_type [TC]: "\<lbrakk>xs: list(A);  ys: list(A)\<rbrakk> \<Longrightarrow> xs@ys \<in> list(A)"
 by (simp add: app_list_def)
 
 (** rev **)
 
 lemma rev_type [TC]: "xs: list(A) \<Longrightarrow> rev(xs) \<in> list(A)"
 by (simp add: rev_list_def)
 
 
 (** flat **)
 
 lemma flat_type [TC]: "ls: list(list(A)) \<Longrightarrow> flat(ls) \<in> list(A)"
 by (simp add: flat_list_def)
 
 
 (** set_of_list **)
 
 lemma set_of_list_type [TC]: "l \<in> list(A) \<Longrightarrow> set_of_list(l) \<in> Pow(A)"
   unfolding set_of_list_list_def
 apply (erule list_rec_type, auto)
 done
 
 lemma set_of_list_append:
      "xs: list(A) \<Longrightarrow> set_of_list (xs@ys) = set_of_list(xs) \<union> set_of_list(ys)"
 apply (erule list.induct)
 apply (simp_all (no_asm_simp) add: Un_cons)
 done
 
 
 (** list_add **)
 
 lemma list_add_type [TC]: "xs: list(nat) \<Longrightarrow> list_add(xs) \<in> nat"
 by (simp add: list_add_list_def)
 
 
 (*** theorems about map ***)
 
 lemma map_ident [simp]: "l \<in> list(A) \<Longrightarrow> map(\<lambda>u. u, l) = l"
 apply (induct_tac "l")
 apply (simp_all (no_asm_simp))
 done
 
 lemma map_compose: "l \<in> list(A) \<Longrightarrow> map(h, map(j,l)) = map(\<lambda>u. h(j(u)), l)"
 apply (induct_tac "l")
 apply (simp_all (no_asm_simp))
 done
 
 lemma map_app_distrib: "xs: list(A) \<Longrightarrow> map(h, xs@ys) = map(h,xs) @ map(h,ys)"
 apply (induct_tac "xs")
 apply (simp_all (no_asm_simp))
 done
 
 lemma map_flat: "ls: list(list(A)) \<Longrightarrow> map(h, flat(ls)) = flat(map(map(h),ls))"
 apply (induct_tac "ls")
 apply (simp_all (no_asm_simp) add: map_app_distrib)
 done
 
 lemma list_rec_map:
      "l \<in> list(A) \<Longrightarrow>
       list_rec(c, d, map(h,l)) =
       list_rec(c, \<lambda>x xs r. d(h(x), map(h,xs), r), l)"
 apply (induct_tac "l")
 apply (simp_all (no_asm_simp))
 done
 
 (** theorems about list(Collect(A,P)) -- used in Induct/Term.thy **)
 
 (* @{term"c \<in> list(Collect(B,P)) \<Longrightarrow> c \<in> list"} *)
 lemmas list_CollectD = Collect_subset [THEN list_mono, THEN subsetD]
 
 lemma map_list_Collect: "l \<in> list({x \<in> A. h(x)=j(x)}) \<Longrightarrow> map(h,l) = map(j,l)"
 apply (induct_tac "l")
 apply (simp_all (no_asm_simp))
 done
 
 (*** theorems about length ***)
 
 lemma length_map [simp]: "xs: list(A) \<Longrightarrow> length(map(h,xs)) = length(xs)"
 by (induct_tac "xs", simp_all)
 
 lemma length_app [simp]:
      "\<lbrakk>xs: list(A); ys: list(A)\<rbrakk>
       \<Longrightarrow> length(xs@ys) = length(xs) #+ length(ys)"
 by (induct_tac "xs", simp_all)
 
 lemma length_rev [simp]: "xs: list(A) \<Longrightarrow> length(rev(xs)) = length(xs)"
 apply (induct_tac "xs")
 apply (simp_all (no_asm_simp) add: length_app)
 done
 
 lemma length_flat:
      "ls: list(list(A)) \<Longrightarrow> length(flat(ls)) = list_add(map(length,ls))"
 apply (induct_tac "ls")
 apply (simp_all (no_asm_simp) add: length_app)
 done
 
 (** Length and drop **)
 
 (*Lemma for the inductive step of drop_length*)
 lemma drop_length_Cons [rule_format]:
      "xs: list(A) \<Longrightarrow>
            \<forall>x.  \<exists>z zs. drop(length(xs), Cons(x,xs)) = Cons(z,zs)"
 by (erule list.induct, simp_all)
 
 lemma drop_length [rule_format]:
      "l \<in> list(A) \<Longrightarrow> \<forall>i \<in> length(l). (\<exists>z zs. drop(i,l) = Cons(z,zs))"
 apply (erule list.induct, simp_all, safe)
 apply (erule drop_length_Cons)
 apply (rule natE)
 apply (erule Ord_trans [OF asm_rl length_type Ord_nat], assumption, simp_all)
 apply (blast intro: succ_in_naturalD length_type)
 done
 
 
 (*** theorems about app ***)
 
 lemma app_right_Nil [simp]: "xs: list(A) \<Longrightarrow> xs@Nil=xs"
 by (erule list.induct, simp_all)
 
 lemma app_assoc: "xs: list(A) \<Longrightarrow> (xs@ys)@zs = xs@(ys@zs)"
 by (induct_tac "xs", simp_all)
 
 lemma flat_app_distrib: "ls: list(list(A)) \<Longrightarrow> flat(ls@ms) = flat(ls)@flat(ms)"
 apply (induct_tac "ls")
 apply (simp_all (no_asm_simp) add: app_assoc)
 done
 
 (*** theorems about rev ***)
 
 lemma rev_map_distrib: "l \<in> list(A) \<Longrightarrow> rev(map(h,l)) = map(h,rev(l))"
 apply (induct_tac "l")
 apply (simp_all (no_asm_simp) add: map_app_distrib)
 done
 
 (*Simplifier needs the premises as assumptions because rewriting will not
   instantiate the variable ?A in the rules' typing conditions; note that
   rev_type does not instantiate ?A.  Only the premises do.
 *)
 lemma rev_app_distrib:
      "\<lbrakk>xs: list(A);  ys: list(A)\<rbrakk> \<Longrightarrow> rev(xs@ys) = rev(ys)@rev(xs)"
 apply (erule list.induct)
 apply (simp_all add: app_assoc)
 done
 
 lemma rev_rev_ident [simp]: "l \<in> list(A) \<Longrightarrow> rev(rev(l))=l"
 apply (induct_tac "l")
 apply (simp_all (no_asm_simp) add: rev_app_distrib)
 done
 
 lemma rev_flat: "ls: list(list(A)) \<Longrightarrow> rev(flat(ls)) = flat(map(rev,rev(ls)))"
 apply (induct_tac "ls")
 apply (simp_all add: map_app_distrib flat_app_distrib rev_app_distrib)
 done
 
 
 (*** theorems about list_add ***)
 
 lemma list_add_app:
      "\<lbrakk>xs: list(nat);  ys: list(nat)\<rbrakk>
       \<Longrightarrow> list_add(xs@ys) = list_add(ys) #+ list_add(xs)"
 apply (induct_tac "xs", simp_all)
 done
 
 lemma list_add_rev: "l \<in> list(nat) \<Longrightarrow> list_add(rev(l)) = list_add(l)"
 apply (induct_tac "l")
 apply (simp_all (no_asm_simp) add: list_add_app)
 done
 
 lemma list_add_flat:
      "ls: list(list(nat)) \<Longrightarrow> list_add(flat(ls)) = list_add(map(list_add,ls))"
 apply (induct_tac "ls")
 apply (simp_all (no_asm_simp) add: list_add_app)
 done
 
 (** New induction rules **)
 
 lemma list_append_induct [case_names Nil snoc, consumes 1]:
     "\<lbrakk>l \<in> list(A);
         P(Nil);
         \<And>x y. \<lbrakk>x \<in> A;  y \<in> list(A);  P(y)\<rbrakk> \<Longrightarrow> P(y @ [x])
 \<rbrakk> \<Longrightarrow> P(l)"
 apply (subgoal_tac "P(rev(rev(l)))", simp)
 apply (erule rev_type [THEN list.induct], simp_all)
 done
 
 lemma list_complete_induct_lemma [rule_format]:
  assumes ih:
     "\<And>l. \<lbrakk>l \<in> list(A);
              \<forall>l' \<in> list(A). length(l') < length(l) \<longrightarrow> P(l')\<rbrakk>
           \<Longrightarrow> P(l)"
   shows "n \<in> nat \<Longrightarrow> \<forall>l \<in> list(A). length(l) < n \<longrightarrow> P(l)"
 apply (induct_tac n, simp)
 apply (blast intro: ih elim!: leE)
 done
 
 theorem list_complete_induct:
       "\<lbrakk>l \<in> list(A);
           \<And>l. \<lbrakk>l \<in> list(A);
                   \<forall>l' \<in> list(A). length(l') < length(l) \<longrightarrow> P(l')\<rbrakk>
                \<Longrightarrow> P(l)
 \<rbrakk> \<Longrightarrow> P(l)"
 apply (rule list_complete_induct_lemma [of A])
    prefer 4 apply (rule le_refl, simp)
   apply blast
  apply simp
 apply assumption
 done
 
 
 (*** Thanks to Sidi Ehmety for these results about min, take, etc. ***)
 
 (** min FIXME: replace by Int! **)
 (* Min theorems are also true for i, j ordinals *)
 lemma min_sym: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> min(i,j)=min(j,i)"
   unfolding min_def
 apply (auto dest!: not_lt_imp_le dest: lt_not_sym intro: le_anti_sym)
 done
 
 lemma min_type [simp,TC]: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> min(i,j):nat"
 by (unfold min_def, auto)
 
 lemma min_0 [simp]: "i \<in> nat \<Longrightarrow> min(0,i) = 0"
   unfolding min_def
 apply (auto dest: not_lt_imp_le)
 done
 
 lemma min_02 [simp]: "i \<in> nat \<Longrightarrow> min(i, 0) = 0"
   unfolding min_def
 apply (auto dest: not_lt_imp_le)
 done
 
 lemma lt_min_iff: "\<lbrakk>i \<in> nat; j \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> i<min(j,k) \<longleftrightarrow> i<j \<and> i<k"
   unfolding min_def
 apply (auto dest!: not_lt_imp_le intro: lt_trans2 lt_trans)
 done
 
 lemma min_succ_succ [simp]:
      "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow>  min(succ(i), succ(j))= succ(min(i, j))"
 apply (unfold min_def, auto)
 done
 
 (*** more theorems about lists ***)
 
 (** filter **)
 
 lemma filter_append [simp]:
      "xs:list(A) \<Longrightarrow> filter(P, xs@ys) = filter(P, xs) @ filter(P, ys)"
 by (induct_tac "xs", auto)
 
 lemma filter_type [simp,TC]: "xs:list(A) \<Longrightarrow> filter(P, xs):list(A)"
 by (induct_tac "xs", auto)
 
 lemma length_filter: "xs:list(A) \<Longrightarrow> length(filter(P, xs)) \<le> length(xs)"
 apply (induct_tac "xs", auto)
 apply (rule_tac j = "length (l) " in le_trans)
 apply (auto simp add: le_iff)
 done
 
 lemma filter_is_subset: "xs:list(A) \<Longrightarrow> set_of_list(filter(P,xs)) \<subseteq> set_of_list(xs)"
 by (induct_tac "xs", auto)
 
 lemma filter_False [simp]: "xs:list(A) \<Longrightarrow> filter(\<lambda>p. False, xs) = Nil"
 by (induct_tac "xs", auto)
 
 lemma filter_True [simp]: "xs:list(A) \<Longrightarrow> filter(\<lambda>p. True, xs) = xs"
 by (induct_tac "xs", auto)
 
 (** length **)
 
 lemma length_is_0_iff [simp]: "xs:list(A) \<Longrightarrow> length(xs)=0 \<longleftrightarrow> xs=Nil"
 by (erule list.induct, auto)
 
 lemma length_is_0_iff2 [simp]: "xs:list(A) \<Longrightarrow> 0 = length(xs) \<longleftrightarrow> xs=Nil"
 by (erule list.induct, auto)
 
 lemma length_tl [simp]: "xs:list(A) \<Longrightarrow> length(tl(xs)) = length(xs) #- 1"
 by (erule list.induct, auto)
 
 lemma length_greater_0_iff: "xs:list(A) \<Longrightarrow> 0<length(xs) \<longleftrightarrow> xs \<noteq> Nil"
 by (erule list.induct, auto)
 
 lemma length_succ_iff: "xs:list(A) \<Longrightarrow> length(xs)=succ(n) \<longleftrightarrow> (\<exists>y ys. xs=Cons(y, ys) \<and> length(ys)=n)"
 by (erule list.induct, auto)
 
 (** more theorems about append **)
 
 lemma append_is_Nil_iff [simp]:
      "xs:list(A) \<Longrightarrow> (xs@ys = Nil) \<longleftrightarrow> (xs=Nil \<and> ys = Nil)"
 by (erule list.induct, auto)
 
 lemma append_is_Nil_iff2 [simp]:
      "xs:list(A) \<Longrightarrow> (Nil = xs@ys) \<longleftrightarrow> (xs=Nil \<and> ys = Nil)"
 by (erule list.induct, auto)
 
 lemma append_left_is_self_iff [simp]:
      "xs:list(A) \<Longrightarrow> (xs@ys = xs) \<longleftrightarrow> (ys = Nil)"
 by (erule list.induct, auto)
 
 lemma append_left_is_self_iff2 [simp]:
      "xs:list(A) \<Longrightarrow> (xs = xs@ys) \<longleftrightarrow> (ys = Nil)"
 by (erule list.induct, auto)
 
 (*TOO SLOW as a default simprule!*)
 lemma append_left_is_Nil_iff [rule_format]:
      "\<lbrakk>xs:list(A); ys:list(A); zs:list(A)\<rbrakk> \<Longrightarrow>
    length(ys)=length(zs) \<longrightarrow> (xs@ys=zs \<longleftrightarrow> (xs=Nil \<and> ys=zs))"
 apply (erule list.induct)
 apply (auto simp add: length_app)
 done
 
 (*TOO SLOW as a default simprule!*)
 lemma append_left_is_Nil_iff2 [rule_format]:
      "\<lbrakk>xs:list(A); ys:list(A); zs:list(A)\<rbrakk> \<Longrightarrow>
    length(ys)=length(zs) \<longrightarrow> (zs=ys@xs \<longleftrightarrow> (xs=Nil \<and> ys=zs))"
 apply (erule list.induct)
 apply (auto simp add: length_app)
 done
 
 lemma append_eq_append_iff [rule_format]:
      "xs:list(A) \<Longrightarrow> \<forall>ys \<in> list(A).
       length(xs)=length(ys) \<longrightarrow> (xs@us = ys@vs) \<longleftrightarrow> (xs=ys \<and> us=vs)"
 apply (erule list.induct)
 apply (simp (no_asm_simp))
 apply clarify
 apply (erule_tac a = ys in list.cases, auto)
 done
 declare append_eq_append_iff [simp]
 
 lemma append_eq_append [rule_format]:
   "xs:list(A) \<Longrightarrow>
    \<forall>ys \<in> list(A). \<forall>us \<in> list(A). \<forall>vs \<in> list(A).
    length(us) = length(vs) \<longrightarrow> (xs@us = ys@vs) \<longrightarrow> (xs=ys \<and> us=vs)"
 apply (induct_tac "xs")
 apply (force simp add: length_app, clarify)
 apply (erule_tac a = ys in list.cases, simp)
 apply (subgoal_tac "Cons (a, l) @ us =vs")
  apply (drule rev_iffD1 [OF _ append_left_is_Nil_iff], simp_all, blast)
 done
 
 lemma append_eq_append_iff2 [simp]:
  "\<lbrakk>xs:list(A); ys:list(A); us:list(A); vs:list(A); length(us)=length(vs)\<rbrakk>
   \<Longrightarrow>  xs@us = ys@vs \<longleftrightarrow> (xs=ys \<and> us=vs)"
 apply (rule iffI)
 apply (rule append_eq_append, auto)
 done
 
 lemma append_self_iff [simp]:
      "\<lbrakk>xs:list(A); ys:list(A); zs:list(A)\<rbrakk> \<Longrightarrow> xs@ys=xs@zs \<longleftrightarrow> ys=zs"
 by simp
 
 lemma append_self_iff2 [simp]:
      "\<lbrakk>xs:list(A); ys:list(A); zs:list(A)\<rbrakk> \<Longrightarrow> ys@xs=zs@xs \<longleftrightarrow> ys=zs"
 by simp
 
 (* Can also be proved from append_eq_append_iff2,
 but the proof requires two more hypotheses: x \<in> A and y \<in> A *)
 lemma append1_eq_iff [rule_format]:
      "xs:list(A) \<Longrightarrow> \<forall>ys \<in> list(A). xs@[x] = ys@[y] \<longleftrightarrow> (xs = ys \<and> x=y)"
 apply (erule list.induct)
  apply clarify
  apply (erule list.cases)
  apply simp_all
 txt\<open>Inductive step\<close>
 apply clarify
 apply (erule_tac a=ys in list.cases, simp_all)
 done
 declare append1_eq_iff [simp]
 
 lemma append_right_is_self_iff [simp]:
      "\<lbrakk>xs:list(A); ys:list(A)\<rbrakk> \<Longrightarrow> (xs@ys = ys) \<longleftrightarrow> (xs=Nil)"
 by (simp (no_asm_simp) add: append_left_is_Nil_iff)
 
 lemma append_right_is_self_iff2 [simp]:
      "\<lbrakk>xs:list(A); ys:list(A)\<rbrakk> \<Longrightarrow> (ys = xs@ys) \<longleftrightarrow> (xs=Nil)"
 apply (rule iffI)
 apply (drule sym, auto)
 done
 
 lemma hd_append [rule_format]:
      "xs:list(A) \<Longrightarrow> xs \<noteq> Nil \<longrightarrow> hd(xs @ ys) = hd(xs)"
 by (induct_tac "xs", auto)
 declare hd_append [simp]
 
 lemma tl_append [rule_format]:
      "xs:list(A) \<Longrightarrow> xs\<noteq>Nil \<longrightarrow> tl(xs @ ys) = tl(xs)@ys"
 by (induct_tac "xs", auto)
 declare tl_append [simp]
 
 (** rev **)
 lemma rev_is_Nil_iff [simp]: "xs:list(A) \<Longrightarrow> (rev(xs) = Nil \<longleftrightarrow> xs = Nil)"
 by (erule list.induct, auto)
 
 lemma Nil_is_rev_iff [simp]: "xs:list(A) \<Longrightarrow> (Nil = rev(xs) \<longleftrightarrow> xs = Nil)"
 by (erule list.induct, auto)
 
 lemma rev_is_rev_iff [rule_format]:
      "xs:list(A) \<Longrightarrow> \<forall>ys \<in> list(A). rev(xs)=rev(ys) \<longleftrightarrow> xs=ys"
 apply (erule list.induct, force, clarify)
 apply (erule_tac a = ys in list.cases, auto)
 done
 declare rev_is_rev_iff [simp]
 
 lemma rev_list_elim [rule_format]:
      "xs:list(A) \<Longrightarrow>
       (xs=Nil \<longrightarrow> P) \<longrightarrow> (\<forall>ys \<in> list(A). \<forall>y \<in> A. xs =ys@[y] \<longrightarrow>P)\<longrightarrow>P"
 by (erule list_append_induct, auto)
 
 
 (** more theorems about drop **)
 
 lemma length_drop [rule_format]:
      "n \<in> nat \<Longrightarrow> \<forall>xs \<in> list(A). length(drop(n, xs)) = length(xs) #- n"
 apply (erule nat_induct)
 apply (auto elim: list.cases)
 done
 declare length_drop [simp]
 
 lemma drop_all [rule_format]:
      "n \<in> nat \<Longrightarrow> \<forall>xs \<in> list(A). length(xs) \<le> n \<longrightarrow> drop(n, xs)=Nil"
 apply (erule nat_induct)
 apply (auto elim: list.cases)
 done
 declare drop_all [simp]
 
 lemma drop_append [rule_format]:
      "n \<in> nat \<Longrightarrow>
       \<forall>xs \<in> list(A). drop(n, xs@ys) = drop(n,xs) @ drop(n #- length(xs), ys)"
 apply (induct_tac "n")
 apply (auto elim: list.cases)
 done
 
 lemma drop_drop:
     "m \<in> nat \<Longrightarrow> \<forall>xs \<in> list(A). \<forall>n \<in> nat. drop(n, drop(m, xs))=drop(n #+ m, xs)"
 apply (induct_tac "m")
 apply (auto elim: list.cases)
 done
 
 (** take **)
 
 lemma take_0 [simp]: "xs:list(A) \<Longrightarrow> take(0, xs) =  Nil"
   unfolding take_def
 apply (erule list.induct, auto)
 done
 
 lemma take_succ_Cons [simp]:
     "n \<in> nat \<Longrightarrow> take(succ(n), Cons(a, xs)) = Cons(a, take(n, xs))"
 by (simp add: take_def)
 
 (* Needed for proving take_all *)
 lemma take_Nil [simp]: "n \<in> nat \<Longrightarrow> take(n, Nil) = Nil"
 by (unfold take_def, auto)
 
 lemma take_all [rule_format]:
      "n \<in> nat \<Longrightarrow> \<forall>xs \<in> list(A). length(xs) \<le> n  \<longrightarrow> take(n, xs) = xs"
 apply (erule nat_induct)
 apply (auto elim: list.cases)
 done
 declare take_all [simp]
 
 lemma take_type [rule_format]:
      "xs:list(A) \<Longrightarrow> \<forall>n \<in> nat. take(n, xs):list(A)"
 apply (erule list.induct, simp, clarify)
 apply (erule natE, auto)
 done
 declare take_type [simp,TC]
 
 lemma take_append [rule_format]:
  "xs:list(A) \<Longrightarrow>
   \<forall>ys \<in> list(A). \<forall>n \<in> nat. take(n, xs @ ys) =
                             take(n, xs) @ take(n #- length(xs), ys)"
 apply (erule list.induct, simp, clarify)
 apply (erule natE, auto)
 done
 declare take_append [simp]
 
 lemma take_take [rule_format]:
    "m \<in> nat \<Longrightarrow>
     \<forall>xs \<in> list(A). \<forall>n \<in> nat. take(n, take(m,xs))= take(min(n, m), xs)"
 apply (induct_tac "m", auto)
 apply (erule_tac a = xs in list.cases)
 apply (auto simp add: take_Nil)
 apply (erule_tac n=n in natE)
 apply (auto intro: take_0 take_type)
 done
 
 (** nth **)
 
 lemma nth_0 [simp]: "nth(0, Cons(a, l)) = a"
 by (simp add: nth_def)
 
 lemma nth_Cons [simp]: "n \<in> nat \<Longrightarrow> nth(succ(n), Cons(a,l)) = nth(n,l)"
 by (simp add: nth_def)
 
 lemma nth_empty [simp]: "nth(n, Nil) = 0"
 by (simp add: nth_def)
 
 lemma nth_type [rule_format]:
      "xs:list(A) \<Longrightarrow> \<forall>n. n < length(xs) \<longrightarrow> nth(n,xs) \<in> A"
 apply (erule list.induct, simp, clarify)
 apply (subgoal_tac "n \<in> nat")
  apply (erule natE, auto dest!: le_in_nat)
 done
 declare nth_type [simp,TC]
 
 lemma nth_eq_0 [rule_format]:
      "xs:list(A) \<Longrightarrow> \<forall>n \<in> nat. length(xs) \<le> n \<longrightarrow> nth(n,xs) = 0"
 apply (erule list.induct, simp, clarify)
 apply (erule natE, auto)
 done
 
 lemma nth_append [rule_format]:
   "xs:list(A) \<Longrightarrow>
    \<forall>n \<in> nat. nth(n, xs @ ys) = (if n < length(xs) then nth(n,xs)
                                 else nth(n #- length(xs), ys))"
 apply (induct_tac "xs", simp, clarify)
 apply (erule natE, auto)
 done
 
 lemma set_of_list_conv_nth:
     "xs:list(A)
      \<Longrightarrow> set_of_list(xs) = {x \<in> A. \<exists>i\<in>nat. i<length(xs) \<and> x = nth(i,xs)}"
 apply (induct_tac "xs", simp_all)
 apply (rule equalityI, auto)
 apply (rule_tac x = 0 in bexI, auto)
 apply (erule natE, auto)
 done
 
 (* Other theorems about lists *)
 
 lemma nth_take_lemma [rule_format]:
  "k \<in> nat \<Longrightarrow>
   \<forall>xs \<in> list(A). (\<forall>ys \<in> list(A). k \<le> length(xs) \<longrightarrow> k \<le> length(ys) \<longrightarrow>
       (\<forall>i \<in> nat. i<k \<longrightarrow> nth(i,xs) = nth(i,ys))\<longrightarrow> take(k,xs) = take(k,ys))"
 apply (induct_tac "k")
 apply (simp_all (no_asm_simp) add: lt_succ_eq_0_disj all_conj_distrib)
 apply clarify
 (*Both lists are non-empty*)
 apply (erule_tac a=xs in list.cases, simp)
 apply (erule_tac a=ys in list.cases, clarify)
 apply (simp (no_asm_use) )
 apply clarify
 apply (simp (no_asm_simp))
 apply (rule conjI, force)
 apply (rename_tac y ys z zs)
 apply (drule_tac x = zs and x1 = ys in bspec [THEN bspec], auto)
 done
 
 lemma nth_equalityI [rule_format]:
      "\<lbrakk>xs:list(A); ys:list(A); length(xs) = length(ys);
          \<forall>i \<in> nat. i < length(xs) \<longrightarrow> nth(i,xs) = nth(i,ys)\<rbrakk>
       \<Longrightarrow> xs = ys"
 apply (subgoal_tac "length (xs) \<le> length (ys) ")
 apply (cut_tac k="length(xs)" and xs=xs and ys=ys in nth_take_lemma)
 apply (simp_all add: take_all)
 done
 
 (*The famous take-lemma*)
 
 lemma take_equalityI [rule_format]:
     "\<lbrakk>xs:list(A); ys:list(A); (\<forall>i \<in> nat. take(i, xs) = take(i,ys))\<rbrakk>
      \<Longrightarrow> xs = ys"
 apply (case_tac "length (xs) \<le> length (ys) ")
 apply (drule_tac x = "length (ys) " in bspec)
 apply (drule_tac [3] not_lt_imp_le)
 apply (subgoal_tac [5] "length (ys) \<le> length (xs) ")
 apply (rule_tac [6] j = "succ (length (ys))" in le_trans)
 apply (rule_tac [6] leI)
 apply (drule_tac [5] x = "length (xs) " in bspec)
 apply (simp_all add: take_all)
 done
 
 lemma nth_drop [rule_format]:
   "n \<in> nat \<Longrightarrow> \<forall>i \<in> nat. \<forall>xs \<in> list(A). nth(i, drop(n, xs)) = nth(n #+ i, xs)"
 apply (induct_tac "n", simp_all, clarify)
 apply (erule list.cases, auto)
 done
 
 lemma take_succ [rule_format]:
   "xs\<in>list(A)
    \<Longrightarrow> \<forall>i. i < length(xs) \<longrightarrow> take(succ(i), xs) = take(i,xs) @ [nth(i, xs)]"
 apply (induct_tac "xs", auto)
 apply (subgoal_tac "i\<in>nat")
 apply (erule natE)
 apply (auto simp add: le_in_nat)
 done
 
 lemma take_add [rule_format]:
      "\<lbrakk>xs\<in>list(A); j\<in>nat\<rbrakk>
       \<Longrightarrow> \<forall>i\<in>nat. take(i #+ j, xs) = take(i,xs) @ take(j, drop(i,xs))"
 apply (induct_tac "xs", simp_all, clarify)
 apply (erule_tac n = i in natE, simp_all)
 done
 
 lemma length_take:
      "l\<in>list(A) \<Longrightarrow> \<forall>n\<in>nat. length(take(n,l)) = min(n, length(l))"
 apply (induct_tac "l", safe, simp_all)
 apply (erule natE, simp_all)
 done
 
 subsection\<open>The function zip\<close>
 
 text\<open>Crafty definition to eliminate a type argument\<close>
 
 consts
   zip_aux        :: "[i,i]\<Rightarrow>i"
 
 primrec (*explicit lambda is required because both arguments of "un" vary*)
   "zip_aux(B,[]) =
      (\<lambda>ys \<in> list(B). list_case([], \<lambda>y l. [], ys))"
 
   "zip_aux(B,Cons(x,l)) =
      (\<lambda>ys \<in> list(B).
         list_case(Nil, \<lambda>y zs. Cons(\<langle>x,y\<rangle>, zip_aux(B,l)`zs), ys))"
 
 definition
   zip :: "[i, i]\<Rightarrow>i"  where
    "zip(xs, ys) \<equiv> zip_aux(set_of_list(ys),xs)`ys"
 
 
 (* zip equations *)
 
 lemma list_on_set_of_list: "xs \<in> list(A) \<Longrightarrow> xs \<in> list(set_of_list(xs))"
 apply (induct_tac xs, simp_all)
 apply (blast intro: list_mono [THEN subsetD])
 done
 
 lemma zip_Nil [simp]: "ys:list(A) \<Longrightarrow> zip(Nil, ys)=Nil"
 apply (simp add: zip_def list_on_set_of_list [of _ A])
 apply (erule list.cases, simp_all)
 done
 
 lemma zip_Nil2 [simp]: "xs:list(A) \<Longrightarrow> zip(xs, Nil)=Nil"
 apply (simp add: zip_def list_on_set_of_list [of _ A])
 apply (erule list.cases, simp_all)
 done
 
 lemma zip_aux_unique [rule_format]:
      "\<lbrakk>B<=C;  xs \<in> list(A)\<rbrakk>
       \<Longrightarrow> \<forall>ys \<in> list(B). zip_aux(C,xs) ` ys = zip_aux(B,xs) ` ys"
 apply (induct_tac xs)
  apply simp_all
  apply (blast intro: list_mono [THEN subsetD], clarify)
 apply (erule_tac a=ys in list.cases, auto)
 apply (blast intro: list_mono [THEN subsetD])
 done
 
 lemma zip_Cons_Cons [simp]:
      "\<lbrakk>xs:list(A); ys:list(B); x \<in> A; y \<in> B\<rbrakk> \<Longrightarrow>
       zip(Cons(x,xs), Cons(y, ys)) = Cons(\<langle>x,y\<rangle>, zip(xs, ys))"
 apply (simp add: zip_def, auto)
 apply (rule zip_aux_unique, auto)
 apply (simp add: list_on_set_of_list [of _ B])
 apply (blast intro: list_on_set_of_list list_mono [THEN subsetD])
 done
 
 lemma zip_type [rule_format]:
      "xs:list(A) \<Longrightarrow> \<forall>ys \<in> list(B). zip(xs, ys):list(A*B)"
 apply (induct_tac "xs")
 apply (simp (no_asm))
 apply clarify
 apply (erule_tac a = ys in list.cases, auto)
 done
 declare zip_type [simp,TC]
 
 (* zip length *)
 lemma length_zip [rule_format]:
      "xs:list(A) \<Longrightarrow> \<forall>ys \<in> list(B). length(zip(xs,ys)) =
                                      min(length(xs), length(ys))"
   unfolding min_def
 apply (induct_tac "xs", simp_all, clarify)
 apply (erule_tac a = ys in list.cases, auto)
 done
 declare length_zip [simp]
 
 lemma zip_append1 [rule_format]:
  "\<lbrakk>ys:list(A); zs:list(B)\<rbrakk> \<Longrightarrow>
   \<forall>xs \<in> list(A). zip(xs @ ys, zs) =
                  zip(xs, take(length(xs), zs)) @ zip(ys, drop(length(xs),zs))"
 apply (induct_tac "zs", force, clarify)
 apply (erule_tac a = xs in list.cases, simp_all)
 done
 
 lemma zip_append2 [rule_format]:
  "\<lbrakk>xs:list(A); zs:list(B)\<rbrakk> \<Longrightarrow> \<forall>ys \<in> list(B). zip(xs, ys@zs) =
        zip(take(length(ys), xs), ys) @ zip(drop(length(ys), xs), zs)"
 apply (induct_tac "xs", force, clarify)
 apply (erule_tac a = ys in list.cases, auto)
 done
 
 lemma zip_append [simp]:
  "\<lbrakk>length(xs) = length(us); length(ys) = length(vs);
      xs:list(A); us:list(B); ys:list(A); vs:list(B)\<rbrakk>
   \<Longrightarrow> zip(xs@ys,us@vs) = zip(xs, us) @ zip(ys, vs)"
 by (simp (no_asm_simp) add: zip_append1 drop_append diff_self_eq_0)
 
 
 lemma zip_rev [rule_format]:
  "ys:list(B) \<Longrightarrow> \<forall>xs \<in> list(A).
     length(xs) = length(ys) \<longrightarrow> zip(rev(xs), rev(ys)) = rev(zip(xs, ys))"
 apply (induct_tac "ys", force, clarify)
 apply (erule_tac a = xs in list.cases)
 apply (auto simp add: length_rev)
 done
 declare zip_rev [simp]
 
 lemma nth_zip [rule_format]:
    "ys:list(B) \<Longrightarrow> \<forall>i \<in> nat. \<forall>xs \<in> list(A).
                     i < length(xs) \<longrightarrow> i < length(ys) \<longrightarrow>
                     nth(i,zip(xs, ys)) = <nth(i,xs),nth(i, ys)>"
 apply (induct_tac "ys", force, clarify)
 apply (erule_tac a = xs in list.cases, simp)
 apply (auto elim: natE)
 done
 declare nth_zip [simp]
 
 lemma set_of_list_zip [rule_format]:
      "\<lbrakk>xs:list(A); ys:list(B); i \<in> nat\<rbrakk>
       \<Longrightarrow> set_of_list(zip(xs, ys)) =
           {\<langle>x, y\<rangle>:A*B. \<exists>i\<in>nat. i < min(length(xs), length(ys))
           \<and> x = nth(i, xs) \<and> y = nth(i, ys)}"
 by (force intro!: Collect_cong simp add: lt_min_iff set_of_list_conv_nth)
 
 (** list_update **)
 
 lemma list_update_Nil [simp]: "i \<in> nat \<Longrightarrow>list_update(Nil, i, v) = Nil"
 by (unfold list_update_def, auto)
 
 lemma list_update_Cons_0 [simp]: "list_update(Cons(x, xs), 0, v)= Cons(v, xs)"
 by (unfold list_update_def, auto)
 
 lemma list_update_Cons_succ [simp]:
   "n \<in> nat \<Longrightarrow>
     list_update(Cons(x, xs), succ(n), v)= Cons(x, list_update(xs, n, v))"
 apply (unfold list_update_def, auto)
 done
 
 lemma list_update_type [rule_format]:
      "\<lbrakk>xs:list(A); v \<in> A\<rbrakk> \<Longrightarrow> \<forall>n \<in> nat. list_update(xs, n, v):list(A)"
 apply (induct_tac "xs")
 apply (simp (no_asm))
 apply clarify
 apply (erule natE, auto)
 done
 declare list_update_type [simp,TC]
 
 lemma length_list_update [rule_format]:
      "xs:list(A) \<Longrightarrow> \<forall>i \<in> nat. length(list_update(xs, i, v))=length(xs)"
 apply (induct_tac "xs")
 apply (simp (no_asm))
 apply clarify
 apply (erule natE, auto)
 done
 declare length_list_update [simp]
 
 lemma nth_list_update [rule_format]:
      "\<lbrakk>xs:list(A)\<rbrakk> \<Longrightarrow> \<forall>i \<in> nat. \<forall>j \<in> nat. i < length(xs)  \<longrightarrow>
          nth(j, list_update(xs, i, x)) = (if i=j then x else nth(j, xs))"
 apply (induct_tac "xs")
  apply simp_all
 apply clarify
 apply (rename_tac i j)
 apply (erule_tac n=i in natE)
 apply (erule_tac [2] n=j in natE)
 apply (erule_tac n=j in natE, simp_all, force)
 done
 
 lemma nth_list_update_eq [simp]:
      "\<lbrakk>i < length(xs); xs:list(A)\<rbrakk> \<Longrightarrow> nth(i, list_update(xs, i,x)) = x"
 by (simp (no_asm_simp) add: lt_length_in_nat nth_list_update)
 
 
 lemma nth_list_update_neq [rule_format]:
   "xs:list(A) \<Longrightarrow>
      \<forall>i \<in> nat. \<forall>j \<in> nat. i \<noteq> j \<longrightarrow> nth(j, list_update(xs,i,x)) = nth(j,xs)"
 apply (induct_tac "xs")
  apply (simp (no_asm))
 apply clarify
 apply (erule natE)
 apply (erule_tac [2] natE, simp_all)
 apply (erule natE, simp_all)
 done
 declare nth_list_update_neq [simp]
 
 lemma list_update_overwrite [rule_format]:
      "xs:list(A) \<Longrightarrow> \<forall>i \<in> nat. i < length(xs)
    \<longrightarrow> list_update(list_update(xs, i, x), i, y) = list_update(xs, i,y)"
 apply (induct_tac "xs")
  apply (simp (no_asm))
 apply clarify
 apply (erule natE, auto)
 done
 declare list_update_overwrite [simp]
 
 lemma list_update_same_conv [rule_format]:
      "xs:list(A) \<Longrightarrow>
       \<forall>i \<in> nat. i < length(xs) \<longrightarrow>
                  (list_update(xs, i, x) = xs) \<longleftrightarrow> (nth(i, xs) = x)"
 apply (induct_tac "xs")
  apply (simp (no_asm))
 apply clarify
 apply (erule natE, auto)
 done
 
 lemma update_zip [rule_format]:
      "ys:list(B) \<Longrightarrow>
       \<forall>i \<in> nat. \<forall>xy \<in> A*B. \<forall>xs \<in> list(A).
         length(xs) = length(ys) \<longrightarrow>
         list_update(zip(xs, ys), i, xy) = zip(list_update(xs, i, fst(xy)),
                                               list_update(ys, i, snd(xy)))"
 apply (induct_tac "ys")
  apply auto
 apply (erule_tac a = xs in list.cases)
 apply (auto elim: natE)
 done
 
 lemma set_update_subset_cons [rule_format]:
   "xs:list(A) \<Longrightarrow>
    \<forall>i \<in> nat. set_of_list(list_update(xs, i, x)) \<subseteq> cons(x, set_of_list(xs))"
 apply (induct_tac "xs")
  apply simp
 apply (rule ballI)
 apply (erule natE, simp_all, auto)
 done
 
 lemma set_of_list_update_subsetI:
      "\<lbrakk>set_of_list(xs) \<subseteq> A; xs:list(A); x \<in> A; i \<in> nat\<rbrakk>
    \<Longrightarrow> set_of_list(list_update(xs, i,x)) \<subseteq> A"
 apply (rule subset_trans)
 apply (rule set_update_subset_cons, auto)
 done
 
 (** upt **)
 
 lemma upt_rec:
      "j \<in> nat \<Longrightarrow> upt(i,j) = (if i<j then Cons(i, upt(succ(i), j)) else Nil)"
 apply (induct_tac "j", auto)
 apply (drule not_lt_imp_le)
 apply (auto simp: lt_Ord intro: le_anti_sym)
 done
 
 lemma upt_conv_Nil [simp]: "\<lbrakk>j \<le> i; j \<in> nat\<rbrakk> \<Longrightarrow> upt(i,j) = Nil"
 apply (subst upt_rec, auto)
 apply (auto simp add: le_iff)
 apply (drule lt_asym [THEN notE], auto)
 done
 
 (*Only needed if upt_Suc is deleted from the simpset*)
 lemma upt_succ_append:
      "\<lbrakk>i \<le> j; j \<in> nat\<rbrakk> \<Longrightarrow> upt(i,succ(j)) = upt(i, j)@[j]"
 by simp
 
 lemma upt_conv_Cons:
      "\<lbrakk>i<j; j \<in> nat\<rbrakk>  \<Longrightarrow> upt(i,j) = Cons(i,upt(succ(i),j))"
 apply (rule trans)
 apply (rule upt_rec, auto)
 done
 
 lemma upt_type [simp,TC]: "j \<in> nat \<Longrightarrow> upt(i,j):list(nat)"
 by (induct_tac "j", auto)
 
 (*LOOPS as a simprule, since j<=j*)
 lemma upt_add_eq_append:
      "\<lbrakk>i \<le> j; j \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> upt(i, j #+k) = upt(i,j)@upt(j,j#+k)"
 apply (induct_tac "k")
 apply (auto simp add: app_assoc app_type)
 apply (rule_tac j = j in le_trans, auto)
 done
 
 lemma length_upt [simp]: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow>length(upt(i,j)) = j #- i"
 apply (induct_tac "j")
 apply (rule_tac [2] sym)
 apply (auto dest!: not_lt_imp_le simp add: diff_succ diff_is_0_iff)
 done
 
 lemma nth_upt [simp]:
      "\<lbrakk>i \<in> nat; j \<in> nat; k \<in> nat; i #+ k < j\<rbrakk> \<Longrightarrow> nth(k, upt(i,j)) = i #+ k"
 apply (rotate_tac -1, erule rev_mp)
 apply (induct_tac "j", simp)
 apply (auto dest!: not_lt_imp_le
             simp add: nth_append le_iff less_diff_conv add_commute)
 done
 
 lemma take_upt [rule_format]:
      "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow>
          \<forall>i \<in> nat. i #+ m \<le> n \<longrightarrow> take(m, upt(i,n)) = upt(i,i#+m)"
 apply (induct_tac "m")
 apply (simp (no_asm_simp) add: take_0)
 apply clarify
 apply (subst upt_rec, simp)
 apply (rule sym)
 apply (subst upt_rec, simp)
 apply (simp_all del: upt.simps)
 apply (rule_tac j = "succ (i #+ x) " in lt_trans2)
 apply auto
 done
 declare take_upt [simp]
 
 lemma map_succ_upt:
      "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow> map(succ, upt(m,n))= upt(succ(m), succ(n))"
 apply (induct_tac "n")
 apply (auto simp add: map_app_distrib)
 done
 
 lemma nth_map [rule_format]:
      "xs:list(A) \<Longrightarrow>
       \<forall>n \<in> nat. n < length(xs) \<longrightarrow> nth(n, map(f, xs)) = f(nth(n, xs))"
 apply (induct_tac "xs", simp)
 apply (rule ballI)
 apply (induct_tac "n", auto)
 done
 declare nth_map [simp]
 
 lemma nth_map_upt [rule_format]:
      "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow>
       \<forall>i \<in> nat. i < n #- m \<longrightarrow> nth(i, map(f, upt(m,n))) = f(m #+ i)"
 apply (rule_tac n = m and m = n in diff_induct, typecheck, simp, simp)
 apply (subst map_succ_upt [symmetric], simp_all, clarify)
 apply (subgoal_tac "i < length (upt (0, x))")
  prefer 2
  apply (simp add: less_diff_conv)
  apply (rule_tac j = "succ (i #+ y) " in lt_trans2)
   apply simp
  apply simp
 apply (subgoal_tac "i < length (upt (y, x))")
  apply (simp_all add: add_commute less_diff_conv)
 done
 
 (** sublist (a generalization of nth to sets) **)
 
 definition
   sublist :: "[i, i] \<Rightarrow> i"  where
     "sublist(xs, A)\<equiv>
      map(fst, (filter(\<lambda>p. snd(p): A, zip(xs, upt(0,length(xs))))))"
 
 lemma sublist_0 [simp]: "xs:list(A) \<Longrightarrow>sublist(xs, 0) =Nil"
 by (unfold sublist_def, auto)
 
 lemma sublist_Nil [simp]: "sublist(Nil, A) = Nil"
 by (unfold sublist_def, auto)
 
 lemma sublist_shift_lemma:
  "\<lbrakk>xs:list(B); i \<in> nat\<rbrakk> \<Longrightarrow>
   map(fst, filter(\<lambda>p. snd(p):A, zip(xs, upt(i,i #+ length(xs))))) =
   map(fst, filter(\<lambda>p. snd(p):nat \<and> snd(p) #+ i \<in> A, zip(xs,upt(0,length(xs)))))"
 apply (erule list_append_induct)
 apply (simp (no_asm_simp))
 apply (auto simp add: add_commute length_app filter_append map_app_distrib)
 done
 
 lemma sublist_type [simp,TC]:
      "xs:list(B) \<Longrightarrow> sublist(xs, A):list(B)"
   unfolding sublist_def
 apply (induct_tac "xs")
 apply (auto simp add: filter_append map_app_distrib)
 done
 
 lemma upt_add_eq_append2:
      "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> upt(0, i #+ j) = upt(0, i) @ upt(i, i #+ j)"
 by (simp add: upt_add_eq_append [of 0] nat_0_le)
 
 lemma sublist_append:
  "\<lbrakk>xs:list(B); ys:list(B)\<rbrakk> \<Longrightarrow>
   sublist(xs@ys, A) = sublist(xs, A) @ sublist(ys, {j \<in> nat. j #+ length(xs): A})"
   unfolding sublist_def
 apply (erule_tac l = ys in list_append_induct, simp)
 apply (simp (no_asm_simp) add: upt_add_eq_append2 app_assoc [symmetric])
 apply (auto simp add: sublist_shift_lemma length_type map_app_distrib app_assoc)
 apply (simp_all add: add_commute)
 done
 
 
 lemma sublist_Cons:
      "\<lbrakk>xs:list(B); x \<in> B\<rbrakk> \<Longrightarrow>
       sublist(Cons(x, xs), A) =
       (if 0 \<in> A then [x] else []) @ sublist(xs, {j \<in> nat. succ(j) \<in> A})"
 apply (erule_tac l = xs in list_append_induct)
 apply (simp (no_asm_simp) add: sublist_def)
 apply (simp del: app_Cons add: app_Cons [symmetric] sublist_append, simp)
 done
 
 lemma sublist_singleton [simp]:
      "sublist([x], A) = (if 0 \<in> A then [x] else [])"
 by (simp add: sublist_Cons)
 
 lemma sublist_upt_eq_take [rule_format]:
     "xs:list(A) \<Longrightarrow> \<forall>n\<in>nat. sublist(xs,n) = take(n,xs)"
 apply (erule list.induct, simp)
 apply (clarify )
 apply (erule natE)
 apply (simp_all add: nat_eq_Collect_lt Ord_mem_iff_lt sublist_Cons)
 done
 declare sublist_upt_eq_take [simp]
 
 lemma sublist_Int_eq:
      "xs \<in> list(B) \<Longrightarrow> sublist(xs, A \<inter> nat) = sublist(xs, A)"
 apply (erule list.induct)
 apply (simp_all add: sublist_Cons)
 done
 
 text\<open>Repetition of a List Element\<close>
 
 consts   repeat :: "[i,i]\<Rightarrow>i"
 primrec
   "repeat(a,0) = []"
 
   "repeat(a,succ(n)) = Cons(a,repeat(a,n))"
 
 lemma length_repeat: "n \<in> nat \<Longrightarrow> length(repeat(a,n)) = n"
 by (induct_tac n, auto)
 
 lemma repeat_succ_app: "n \<in> nat \<Longrightarrow> repeat(a,succ(n)) = repeat(a,n) @ [a]"
 apply (induct_tac n)
 apply (simp_all del: app_Cons add: app_Cons [symmetric])
 done
 
 lemma repeat_type [TC]: "\<lbrakk>a \<in> A; n \<in> nat\<rbrakk> \<Longrightarrow> repeat(a,n) \<in> list(A)"
 by (induct_tac n, auto)
 
 end
diff --git a/src/ZF/Order.thy b/src/ZF/Order.thy
--- a/src/ZF/Order.thy
+++ b/src/ZF/Order.thy
@@ -1,714 +1,714 @@
 (*  Title:      ZF/Order.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 
 Results from the book "Set Theory: an Introduction to Independence Proofs"
         by Kenneth Kunen.  Chapter 1, section 6.
 Additional definitions and lemmas for reflexive orders.
 *)
 
 section\<open>Partial and Total Orderings: Basic Definitions and Properties\<close>
 
 theory Order imports WF Perm begin
 
 text \<open>We adopt the following convention: \<open>ord\<close> is used for
   strict orders and \<open>order\<close> is used for their reflexive
   counterparts.\<close>
 
 definition
   part_ord :: "[i,i]\<Rightarrow>o"                (*Strict partial ordering*)  where
    "part_ord(A,r) \<equiv> irrefl(A,r) \<and> trans[A](r)"
 
 definition
   linear   :: "[i,i]\<Rightarrow>o"                (*Strict total ordering*)  where
    "linear(A,r) \<equiv> (\<forall>x\<in>A. \<forall>y\<in>A. \<langle>x,y\<rangle>:r | x=y | \<langle>y,x\<rangle>:r)"
 
 definition
   tot_ord  :: "[i,i]\<Rightarrow>o"                (*Strict total ordering*)  where
    "tot_ord(A,r) \<equiv> part_ord(A,r) \<and> linear(A,r)"
 
 definition
   "preorder_on(A, r) \<equiv> refl(A, r) \<and> trans[A](r)"
 
 definition                              (*Partial ordering*)
   "partial_order_on(A, r) \<equiv> preorder_on(A, r) \<and> antisym(r)"
 
 abbreviation
   "Preorder(r) \<equiv> preorder_on(field(r), r)"
 
 abbreviation
   "Partial_order(r) \<equiv> partial_order_on(field(r), r)"
 
 definition
   well_ord :: "[i,i]\<Rightarrow>o"                (*Well-ordering*)  where
    "well_ord(A,r) \<equiv> tot_ord(A,r) \<and> wf[A](r)"
 
 definition
   mono_map :: "[i,i,i,i]\<Rightarrow>i"            (*Order-preserving maps*)  where
    "mono_map(A,r,B,s) \<equiv>
               {f \<in> A->B. \<forall>x\<in>A. \<forall>y\<in>A. \<langle>x,y\<rangle>:r \<longrightarrow> <f`x,f`y>:s}"
 
 definition
   ord_iso  :: "[i,i,i,i]\<Rightarrow>i"  (\<open>(\<langle>_, _\<rangle> \<cong>/ \<langle>_, _\<rangle>)\<close> 51)  (*Order isomorphisms*)  where
    "\<langle>A,r\<rangle> \<cong> \<langle>B,s\<rangle> \<equiv>
               {f \<in> bij(A,B). \<forall>x\<in>A. \<forall>y\<in>A. \<langle>x,y\<rangle>:r \<longleftrightarrow> <f`x,f`y>:s}"
 
 definition
   pred     :: "[i,i,i]\<Rightarrow>i"              (*Set of predecessors*)  where
    "pred(A,x,r) \<equiv> {y \<in> A. \<langle>y,x\<rangle>:r}"
 
 definition
   ord_iso_map :: "[i,i,i,i]\<Rightarrow>i"         (*Construction for linearity theorem*)  where
    "ord_iso_map(A,r,B,s) \<equiv>
      \<Union>x\<in>A. \<Union>y\<in>B. \<Union>f \<in> ord_iso(pred(A,x,r), r, pred(B,y,s), s). {\<langle>x,y\<rangle>}"
 
 definition
   first :: "[i, i, i] \<Rightarrow> o"  where
     "first(u, X, R) \<equiv> u \<in> X \<and> (\<forall>v\<in>X. v\<noteq>u \<longrightarrow> \<langle>u,v\<rangle> \<in> R)"
 
 subsection\<open>Immediate Consequences of the Definitions\<close>
 
 lemma part_ord_Imp_asym:
     "part_ord(A,r) \<Longrightarrow> asym(r \<inter> A*A)"
 by (unfold part_ord_def irrefl_def trans_on_def asym_def, blast)
 
 lemma linearE:
     "\<lbrakk>linear(A,r);  x \<in> A;  y \<in> A;
         \<langle>x,y\<rangle>:r \<Longrightarrow> P;  x=y \<Longrightarrow> P;  \<langle>y,x\<rangle>:r \<Longrightarrow> P\<rbrakk>
      \<Longrightarrow> P"
 by (simp add: linear_def, blast)
 
 
 (** General properties of well_ord **)
 
 lemma well_ordI:
     "\<lbrakk>wf[A](r); linear(A,r)\<rbrakk> \<Longrightarrow> well_ord(A,r)"
 apply (simp add: irrefl_def part_ord_def tot_ord_def
                  trans_on_def well_ord_def wf_on_not_refl)
 apply (fast elim: linearE wf_on_asym wf_on_chain3)
 done
 
 lemma well_ord_is_wf:
     "well_ord(A,r) \<Longrightarrow> wf[A](r)"
 by (unfold well_ord_def, safe)
 
 lemma well_ord_is_trans_on:
     "well_ord(A,r) \<Longrightarrow> trans[A](r)"
 by (unfold well_ord_def tot_ord_def part_ord_def, safe)
 
 lemma well_ord_is_linear: "well_ord(A,r) \<Longrightarrow> linear(A,r)"
 by (unfold well_ord_def tot_ord_def, blast)
 
 
 (** Derived rules for pred(A,x,r) **)
 
 lemma pred_iff: "y \<in> pred(A,x,r) \<longleftrightarrow> \<langle>y,x\<rangle>:r \<and> y \<in> A"
 by (unfold pred_def, blast)
 
 lemmas predI = conjI [THEN pred_iff [THEN iffD2]]
 
 lemma predE: "\<lbrakk>y \<in> pred(A,x,r);  \<lbrakk>y \<in> A; \<langle>y,x\<rangle>:r\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
 by (simp add: pred_def)
 
 lemma pred_subset_under: "pred(A,x,r) \<subseteq> r -`` {x}"
 by (simp add: pred_def, blast)
 
 lemma pred_subset: "pred(A,x,r) \<subseteq> A"
 by (simp add: pred_def, blast)
 
 lemma pred_pred_eq:
     "pred(pred(A,x,r), y, r) = pred(A,x,r) \<inter> pred(A,y,r)"
 by (simp add: pred_def, blast)
 
 lemma trans_pred_pred_eq:
     "\<lbrakk>trans[A](r);  \<langle>y,x\<rangle>:r;  x \<in> A;  y \<in> A\<rbrakk>
      \<Longrightarrow> pred(pred(A,x,r), y, r) = pred(A,y,r)"
 by (unfold trans_on_def pred_def, blast)
 
 
 subsection\<open>Restricting an Ordering's Domain\<close>
 
 (** The ordering's properties hold over all subsets of its domain
     [including initial segments of the form pred(A,x,r) **)
 
 (*Note: a relation s such that s<=r need not be a partial ordering*)
 lemma part_ord_subset:
     "\<lbrakk>part_ord(A,r);  B<=A\<rbrakk> \<Longrightarrow> part_ord(B,r)"
 by (unfold part_ord_def irrefl_def trans_on_def, blast)
 
 lemma linear_subset:
     "\<lbrakk>linear(A,r);  B<=A\<rbrakk> \<Longrightarrow> linear(B,r)"
 by (unfold linear_def, blast)
 
 lemma tot_ord_subset:
     "\<lbrakk>tot_ord(A,r);  B<=A\<rbrakk> \<Longrightarrow> tot_ord(B,r)"
   unfolding tot_ord_def
 apply (fast elim!: part_ord_subset linear_subset)
 done
 
 lemma well_ord_subset:
     "\<lbrakk>well_ord(A,r);  B<=A\<rbrakk> \<Longrightarrow> well_ord(B,r)"
   unfolding well_ord_def
 apply (fast elim!: tot_ord_subset wf_on_subset_A)
 done
 
 
 (** Relations restricted to a smaller domain, by Krzysztof Grabczewski **)
 
 lemma irrefl_Int_iff: "irrefl(A,r \<inter> A*A) \<longleftrightarrow> irrefl(A,r)"
 by (unfold irrefl_def, blast)
 
 lemma trans_on_Int_iff: "trans[A](r \<inter> A*A) \<longleftrightarrow> trans[A](r)"
 by (unfold trans_on_def, blast)
 
 lemma part_ord_Int_iff: "part_ord(A,r \<inter> A*A) \<longleftrightarrow> part_ord(A,r)"
   unfolding part_ord_def
 apply (simp add: irrefl_Int_iff trans_on_Int_iff)
 done
 
 lemma linear_Int_iff: "linear(A,r \<inter> A*A) \<longleftrightarrow> linear(A,r)"
 by (unfold linear_def, blast)
 
 lemma tot_ord_Int_iff: "tot_ord(A,r \<inter> A*A) \<longleftrightarrow> tot_ord(A,r)"
   unfolding tot_ord_def
 apply (simp add: part_ord_Int_iff linear_Int_iff)
 done
 
 lemma wf_on_Int_iff: "wf[A](r \<inter> A*A) \<longleftrightarrow> wf[A](r)"
 apply (unfold wf_on_def wf_def, fast) (*10 times faster than blast!*)
 done
 
 lemma well_ord_Int_iff: "well_ord(A,r \<inter> A*A) \<longleftrightarrow> well_ord(A,r)"
   unfolding well_ord_def
 apply (simp add: tot_ord_Int_iff wf_on_Int_iff)
 done
 
 
 subsection\<open>Empty and Unit Domains\<close>
 
 (*The empty relation is well-founded*)
 lemma wf_on_any_0: "wf[A](0)"
 by (simp add: wf_on_def wf_def, fast)
 
 subsubsection\<open>Relations over the Empty Set\<close>
 
 lemma irrefl_0: "irrefl(0,r)"
 by (unfold irrefl_def, blast)
 
 lemma trans_on_0: "trans[0](r)"
 by (unfold trans_on_def, blast)
 
 lemma part_ord_0: "part_ord(0,r)"
   unfolding part_ord_def
 apply (simp add: irrefl_0 trans_on_0)
 done
 
 lemma linear_0: "linear(0,r)"
 by (unfold linear_def, blast)
 
 lemma tot_ord_0: "tot_ord(0,r)"
   unfolding tot_ord_def
 apply (simp add: part_ord_0 linear_0)
 done
 
 lemma wf_on_0: "wf[0](r)"
 by (unfold wf_on_def wf_def, blast)
 
 lemma well_ord_0: "well_ord(0,r)"
   unfolding well_ord_def
 apply (simp add: tot_ord_0 wf_on_0)
 done
 
 
 subsubsection\<open>The Empty Relation Well-Orders the Unit Set\<close>
 
 text\<open>by Grabczewski\<close>
 
 lemma tot_ord_unit: "tot_ord({a},0)"
 by (simp add: irrefl_def trans_on_def part_ord_def linear_def tot_ord_def)
 
 lemma well_ord_unit: "well_ord({a},0)"
   unfolding well_ord_def
 apply (simp add: tot_ord_unit wf_on_any_0)
 done
 
 
 subsection\<open>Order-Isomorphisms\<close>
 
 text\<open>Suppes calls them "similarities"\<close>
 
 (** Order-preserving (monotone) maps **)
 
 lemma mono_map_is_fun: "f \<in> mono_map(A,r,B,s) \<Longrightarrow> f \<in> A->B"
 by (simp add: mono_map_def)
 
 lemma mono_map_is_inj:
     "\<lbrakk>linear(A,r);  wf[B](s);  f \<in> mono_map(A,r,B,s)\<rbrakk> \<Longrightarrow> f \<in> inj(A,B)"
 apply (unfold mono_map_def inj_def, clarify)
 apply (erule_tac x=w and y=x in linearE, assumption+)
 apply (force intro: apply_type dest: wf_on_not_refl)+
 done
 
 lemma ord_isoI:
     "\<lbrakk>f \<in> bij(A, B);
         \<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<langle>x, y\<rangle> \<in> r \<longleftrightarrow> <f`x, f`y> \<in> s\<rbrakk>
      \<Longrightarrow> f \<in> ord_iso(A,r,B,s)"
 by (simp add: ord_iso_def)
 
 lemma ord_iso_is_mono_map:
     "f \<in> ord_iso(A,r,B,s) \<Longrightarrow> f \<in> mono_map(A,r,B,s)"
 apply (simp add: ord_iso_def mono_map_def)
 apply (blast dest!: bij_is_fun)
 done
 
 lemma ord_iso_is_bij:
     "f \<in> ord_iso(A,r,B,s) \<Longrightarrow> f \<in> bij(A,B)"
 by (simp add: ord_iso_def)
 
 (*Needed?  But ord_iso_converse is!*)
 lemma ord_iso_apply:
     "\<lbrakk>f \<in> ord_iso(A,r,B,s);  \<langle>x,y\<rangle>: r;  x \<in> A;  y \<in> A\<rbrakk> \<Longrightarrow> <f`x, f`y> \<in> s"
 by (simp add: ord_iso_def)
 
 lemma ord_iso_converse:
     "\<lbrakk>f \<in> ord_iso(A,r,B,s);  \<langle>x,y\<rangle>: s;  x \<in> B;  y \<in> B\<rbrakk>
      \<Longrightarrow> <converse(f) ` x, converse(f) ` y> \<in> r"
 apply (simp add: ord_iso_def, clarify)
 apply (erule bspec [THEN bspec, THEN iffD2])
 apply (erule asm_rl bij_converse_bij [THEN bij_is_fun, THEN apply_type])+
 apply (auto simp add: right_inverse_bij)
 done
 
 
 (** Symmetry and Transitivity Rules **)
 
 (*Reflexivity of similarity*)
 lemma ord_iso_refl: "id(A): ord_iso(A,r,A,r)"
 by (rule id_bij [THEN ord_isoI], simp)
 
 (*Symmetry of similarity*)
 lemma ord_iso_sym: "f \<in> ord_iso(A,r,B,s) \<Longrightarrow> converse(f): ord_iso(B,s,A,r)"
 apply (simp add: ord_iso_def)
 apply (auto simp add: right_inverse_bij bij_converse_bij
                       bij_is_fun [THEN apply_funtype])
 done
 
 (*Transitivity of similarity*)
 lemma mono_map_trans:
     "\<lbrakk>g \<in> mono_map(A,r,B,s);  f \<in> mono_map(B,s,C,t)\<rbrakk>
      \<Longrightarrow> (f O g): mono_map(A,r,C,t)"
   unfolding mono_map_def
 apply (auto simp add: comp_fun)
 done
 
 (*Transitivity of similarity: the order-isomorphism relation*)
 lemma ord_iso_trans:
     "\<lbrakk>g \<in> ord_iso(A,r,B,s);  f \<in> ord_iso(B,s,C,t)\<rbrakk>
      \<Longrightarrow> (f O g): ord_iso(A,r,C,t)"
 apply (unfold ord_iso_def, clarify)
 apply (frule bij_is_fun [of f])
 apply (frule bij_is_fun [of g])
 apply (auto simp add: comp_bij)
 done
 
 (** Two monotone maps can make an order-isomorphism **)
 
 lemma mono_ord_isoI:
     "\<lbrakk>f \<in> mono_map(A,r,B,s);  g \<in> mono_map(B,s,A,r);
         f O g = id(B);  g O f = id(A)\<rbrakk> \<Longrightarrow> f \<in> ord_iso(A,r,B,s)"
 apply (simp add: ord_iso_def mono_map_def, safe)
 apply (intro fg_imp_bijective, auto)
 apply (subgoal_tac "<g` (f`x), g` (f`y) > \<in> r")
 apply (simp add: comp_eq_id_iff [THEN iffD1])
 apply (blast intro: apply_funtype)
 done
 
 lemma well_ord_mono_ord_isoI:
      "\<lbrakk>well_ord(A,r);  well_ord(B,s);
          f \<in> mono_map(A,r,B,s);  converse(f): mono_map(B,s,A,r)\<rbrakk>
       \<Longrightarrow> f \<in> ord_iso(A,r,B,s)"
 apply (intro mono_ord_isoI, auto)
 apply (frule mono_map_is_fun [THEN fun_is_rel])
 apply (erule converse_converse [THEN subst], rule left_comp_inverse)
 apply (blast intro: left_comp_inverse mono_map_is_inj well_ord_is_linear
                     well_ord_is_wf)+
 done
 
 
 (** Order-isomorphisms preserve the ordering's properties **)
 
 lemma part_ord_ord_iso:
     "\<lbrakk>part_ord(B,s);  f \<in> ord_iso(A,r,B,s)\<rbrakk> \<Longrightarrow> part_ord(A,r)"
 apply (simp add: part_ord_def irrefl_def trans_on_def ord_iso_def)
 apply (fast intro: bij_is_fun [THEN apply_type])
 done
 
 lemma linear_ord_iso:
     "\<lbrakk>linear(B,s);  f \<in> ord_iso(A,r,B,s)\<rbrakk> \<Longrightarrow> linear(A,r)"
 apply (simp add: linear_def ord_iso_def, safe)
 apply (drule_tac x1 = "f`x" and x = "f`y" in bspec [THEN bspec])
 apply (safe elim!: bij_is_fun [THEN apply_type])
 apply (drule_tac t = "(`) (converse (f))" in subst_context)
 apply (simp add: left_inverse_bij)
 done
 
 lemma wf_on_ord_iso:
     "\<lbrakk>wf[B](s);  f \<in> ord_iso(A,r,B,s)\<rbrakk> \<Longrightarrow> wf[A](r)"
 apply (simp add: wf_on_def wf_def ord_iso_def, safe)
 apply (drule_tac x = "{f`z. z \<in> Z \<inter> A}" in spec)
 apply (safe intro!: equalityI)
 apply (blast dest!: equalityD1 intro: bij_is_fun [THEN apply_type])+
 done
 
 lemma well_ord_ord_iso:
     "\<lbrakk>well_ord(B,s);  f \<in> ord_iso(A,r,B,s)\<rbrakk> \<Longrightarrow> well_ord(A,r)"
-apply (unfold well_ord_def tot_ord_def)
+  unfolding well_ord_def tot_ord_def
 apply (fast elim!: part_ord_ord_iso linear_ord_iso wf_on_ord_iso)
 done
 
 
 subsection\<open>Main results of Kunen, Chapter 1 section 6\<close>
 
 (*Inductive argument for Kunen's Lemma 6.1, etc.
   Simple proof from Halmos, page 72*)
 lemma well_ord_iso_subset_lemma:
      "\<lbrakk>well_ord(A,r);  f \<in> ord_iso(A,r, A',r);  A'<= A;  y \<in> A\<rbrakk>
       \<Longrightarrow> \<not> <f`y, y>: r"
 apply (simp add: well_ord_def ord_iso_def)
 apply (elim conjE CollectE)
 apply (rule_tac a=y in wf_on_induct, assumption+)
 apply (blast dest: bij_is_fun [THEN apply_type])
 done
 
 (*Kunen's Lemma 6.1 \<in> there's no order-isomorphism to an initial segment
                      of a well-ordering*)
 lemma well_ord_iso_predE:
      "\<lbrakk>well_ord(A,r);  f \<in> ord_iso(A, r, pred(A,x,r), r);  x \<in> A\<rbrakk> \<Longrightarrow> P"
 apply (insert well_ord_iso_subset_lemma [of A r f "pred(A,x,r)" x])
 apply (simp add: pred_subset)
 (*Now we know  f`x < x *)
 apply (drule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type], assumption)
 (*Now we also know @{term"f`x \<in> pred(A,x,r)"}: contradiction! *)
 apply (simp add: well_ord_def pred_def)
 done
 
 (*Simple consequence of Lemma 6.1*)
 lemma well_ord_iso_pred_eq:
      "\<lbrakk>well_ord(A,r);  f \<in> ord_iso(pred(A,a,r), r, pred(A,c,r), r);
          a \<in> A;  c \<in> A\<rbrakk> \<Longrightarrow> a=c"
 apply (frule well_ord_is_trans_on)
 apply (frule well_ord_is_linear)
 apply (erule_tac x=a and y=c in linearE, assumption+)
 apply (drule ord_iso_sym)
 (*two symmetric cases*)
 apply (auto elim!: well_ord_subset [OF _ pred_subset, THEN well_ord_iso_predE]
             intro!: predI
             simp add: trans_pred_pred_eq)
 done
 
 (*Does not assume r is a wellordering!*)
 lemma ord_iso_image_pred:
      "\<lbrakk>f \<in> ord_iso(A,r,B,s);  a \<in> A\<rbrakk> \<Longrightarrow> f `` pred(A,a,r) = pred(B, f`a, s)"
-apply (unfold ord_iso_def pred_def)
+  unfolding ord_iso_def pred_def
 apply (erule CollectE)
 apply (simp (no_asm_simp) add: image_fun [OF bij_is_fun Collect_subset])
 apply (rule equalityI)
 apply (safe elim!: bij_is_fun [THEN apply_type])
 apply (rule RepFun_eqI)
 apply (blast intro!: right_inverse_bij [symmetric])
 apply (auto simp add: right_inverse_bij  bij_is_fun [THEN apply_funtype])
 done
 
 lemma ord_iso_restrict_image:
      "\<lbrakk>f \<in> ord_iso(A,r,B,s);  C<=A\<rbrakk>
       \<Longrightarrow> restrict(f,C) \<in> ord_iso(C, r, f``C, s)"
 apply (simp add: ord_iso_def)
 apply (blast intro: bij_is_inj restrict_bij)
 done
 
 (*But in use, A and B may themselves be initial segments.  Then use
   trans_pred_pred_eq to simplify the pred(pred...) terms.  See just below.*)
 lemma ord_iso_restrict_pred:
    "\<lbrakk>f \<in> ord_iso(A,r,B,s);   a \<in> A\<rbrakk>
     \<Longrightarrow> restrict(f, pred(A,a,r)) \<in> ord_iso(pred(A,a,r), r, pred(B, f`a, s), s)"
 apply (simp add: ord_iso_image_pred [symmetric])
 apply (blast intro: ord_iso_restrict_image elim: predE)
 done
 
 (*Tricky; a lot of forward proof!*)
 lemma well_ord_iso_preserving:
      "\<lbrakk>well_ord(A,r);  well_ord(B,s);  \<langle>a,c\<rangle>: r;
          f \<in> ord_iso(pred(A,a,r), r, pred(B,b,s), s);
          g \<in> ord_iso(pred(A,c,r), r, pred(B,d,s), s);
          a \<in> A;  c \<in> A;  b \<in> B;  d \<in> B\<rbrakk> \<Longrightarrow> \<langle>b,d\<rangle>: s"
 apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type], (erule asm_rl predI predE)+)
 apply (subgoal_tac "b = g`a")
 apply (simp (no_asm_simp))
 apply (rule well_ord_iso_pred_eq, auto)
 apply (frule ord_iso_restrict_pred, (erule asm_rl predI)+)
 apply (simp add: well_ord_is_trans_on trans_pred_pred_eq)
 apply (erule ord_iso_sym [THEN ord_iso_trans], assumption)
 done
 
 (*See Halmos, page 72*)
 lemma well_ord_iso_unique_lemma:
      "\<lbrakk>well_ord(A,r);
          f \<in> ord_iso(A,r, B,s);  g \<in> ord_iso(A,r, B,s);  y \<in> A\<rbrakk>
       \<Longrightarrow> \<not> <g`y, f`y> \<in> s"
 apply (frule well_ord_iso_subset_lemma)
 apply (rule_tac f = "converse (f) " and g = g in ord_iso_trans)
 apply auto
 apply (blast intro: ord_iso_sym)
 apply (frule ord_iso_is_bij [of f])
 apply (frule ord_iso_is_bij [of g])
 apply (frule ord_iso_converse)
 apply (blast intro!: bij_converse_bij
              intro: bij_is_fun apply_funtype)+
 apply (erule notE)
 apply (simp add: left_inverse_bij bij_is_fun comp_fun_apply [of _ A B])
 done
 
 
 (*Kunen's Lemma 6.2: Order-isomorphisms between well-orderings are unique*)
 lemma well_ord_iso_unique: "\<lbrakk>well_ord(A,r);
          f \<in> ord_iso(A,r, B,s);  g \<in> ord_iso(A,r, B,s)\<rbrakk> \<Longrightarrow> f = g"
 apply (rule fun_extension)
 apply (erule ord_iso_is_bij [THEN bij_is_fun])+
 apply (subgoal_tac "f`x \<in> B \<and> g`x \<in> B \<and> linear(B,s)")
  apply (simp add: linear_def)
  apply (blast dest: well_ord_iso_unique_lemma)
 apply (blast intro: ord_iso_is_bij bij_is_fun apply_funtype
                     well_ord_is_linear well_ord_ord_iso ord_iso_sym)
 done
 
 subsection\<open>Towards Kunen's Theorem 6.3: Linearity of the Similarity Relation\<close>
 
 lemma ord_iso_map_subset: "ord_iso_map(A,r,B,s) \<subseteq> A*B"
 by (unfold ord_iso_map_def, blast)
 
 lemma domain_ord_iso_map: "domain(ord_iso_map(A,r,B,s)) \<subseteq> A"
 by (unfold ord_iso_map_def, blast)
 
 lemma range_ord_iso_map: "range(ord_iso_map(A,r,B,s)) \<subseteq> B"
 by (unfold ord_iso_map_def, blast)
 
 lemma converse_ord_iso_map:
     "converse(ord_iso_map(A,r,B,s)) = ord_iso_map(B,s,A,r)"
   unfolding ord_iso_map_def
 apply (blast intro: ord_iso_sym)
 done
 
 lemma function_ord_iso_map:
     "well_ord(B,s) \<Longrightarrow> function(ord_iso_map(A,r,B,s))"
-apply (unfold ord_iso_map_def function_def)
+  unfolding ord_iso_map_def function_def
 apply (blast intro: well_ord_iso_pred_eq ord_iso_sym ord_iso_trans)
 done
 
 lemma ord_iso_map_fun: "well_ord(B,s) \<Longrightarrow> ord_iso_map(A,r,B,s)
            \<in> domain(ord_iso_map(A,r,B,s)) -> range(ord_iso_map(A,r,B,s))"
 by (simp add: Pi_iff function_ord_iso_map
                  ord_iso_map_subset [THEN domain_times_range])
 
 lemma ord_iso_map_mono_map:
     "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk>
      \<Longrightarrow> ord_iso_map(A,r,B,s)
            \<in> mono_map(domain(ord_iso_map(A,r,B,s)), r,
                       range(ord_iso_map(A,r,B,s)), s)"
   unfolding mono_map_def
 apply (simp (no_asm_simp) add: ord_iso_map_fun)
 apply safe
 apply (subgoal_tac "x \<in> A \<and> ya:A \<and> y \<in> B \<and> yb:B")
  apply (simp add: apply_equality [OF _  ord_iso_map_fun])
    unfolding ord_iso_map_def
  apply (blast intro: well_ord_iso_preserving, blast)
 done
 
 lemma ord_iso_map_ord_iso:
     "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk> \<Longrightarrow> ord_iso_map(A,r,B,s)
            \<in> ord_iso(domain(ord_iso_map(A,r,B,s)), r,
                       range(ord_iso_map(A,r,B,s)), s)"
 apply (rule well_ord_mono_ord_isoI)
    prefer 4
    apply (rule converse_ord_iso_map [THEN subst])
    apply (simp add: ord_iso_map_mono_map
                     ord_iso_map_subset [THEN converse_converse])
 apply (blast intro!: domain_ord_iso_map range_ord_iso_map
              intro: well_ord_subset ord_iso_map_mono_map)+
 done
 
 
 (*One way of saying that domain(ord_iso_map(A,r,B,s)) is downwards-closed*)
 lemma domain_ord_iso_map_subset:
      "\<lbrakk>well_ord(A,r);  well_ord(B,s);
          a \<in> A;  a \<notin> domain(ord_iso_map(A,r,B,s))\<rbrakk>
       \<Longrightarrow>  domain(ord_iso_map(A,r,B,s)) \<subseteq> pred(A, a, r)"
   unfolding ord_iso_map_def
 apply (safe intro!: predI)
 (*Case analysis on  xa vs a in r *)
 apply (simp (no_asm_simp))
 apply (frule_tac A = A in well_ord_is_linear)
 apply (rename_tac b y f)
 apply (erule_tac x=b and y=a in linearE, assumption+)
 (*Trivial case: b=a*)
 apply clarify
 apply blast
 (*Harder case: \<langle>a, xa\<rangle>: r*)
 apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type],
        (erule asm_rl predI predE)+)
 apply (frule ord_iso_restrict_pred)
  apply (simp add: pred_iff)
 apply (simp split: split_if_asm
           add: well_ord_is_trans_on trans_pred_pred_eq domain_UN domain_Union, blast)
 done
 
 (*For the 4-way case analysis in the main result*)
 lemma domain_ord_iso_map_cases:
      "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk>
       \<Longrightarrow> domain(ord_iso_map(A,r,B,s)) = A |
           (\<exists>x\<in>A. domain(ord_iso_map(A,r,B,s)) = pred(A,x,r))"
 apply (frule well_ord_is_wf)
-apply (unfold wf_on_def wf_def)
+  unfolding wf_on_def wf_def
 apply (drule_tac x = "A-domain (ord_iso_map (A,r,B,s))" in spec)
 apply safe
 (*The first case: the domain equals A*)
 apply (rule domain_ord_iso_map [THEN equalityI])
 apply (erule Diff_eq_0_iff [THEN iffD1])
 (*The other case: the domain equals an initial segment*)
 apply (blast del: domainI subsetI
              elim!: predE
              intro!: domain_ord_iso_map_subset
              intro: subsetI)+
 done
 
 (*As above, by duality*)
 lemma range_ord_iso_map_cases:
     "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk>
      \<Longrightarrow> range(ord_iso_map(A,r,B,s)) = B |
          (\<exists>y\<in>B. range(ord_iso_map(A,r,B,s)) = pred(B,y,s))"
 apply (rule converse_ord_iso_map [THEN subst])
 apply (simp add: domain_ord_iso_map_cases)
 done
 
 text\<open>Kunen's Theorem 6.3: Fundamental Theorem for Well-Ordered Sets\<close>
 theorem well_ord_trichotomy:
    "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk>
     \<Longrightarrow> ord_iso_map(A,r,B,s) \<in> ord_iso(A, r, B, s) |
         (\<exists>x\<in>A. ord_iso_map(A,r,B,s) \<in> ord_iso(pred(A,x,r), r, B, s)) |
         (\<exists>y\<in>B. ord_iso_map(A,r,B,s) \<in> ord_iso(A, r, pred(B,y,s), s))"
 apply (frule_tac B = B in domain_ord_iso_map_cases, assumption)
 apply (frule_tac B = B in range_ord_iso_map_cases, assumption)
 apply (drule ord_iso_map_ord_iso, assumption)
 apply (elim disjE bexE)
    apply (simp_all add: bexI)
 apply (rule wf_on_not_refl [THEN notE])
   apply (erule well_ord_is_wf)
  apply assumption
 apply (subgoal_tac "\<langle>x,y\<rangle>: ord_iso_map (A,r,B,s) ")
  apply (drule rangeI)
  apply (simp add: pred_def)
 apply (unfold ord_iso_map_def, blast)
 done
 
 
 subsection\<open>Miscellaneous Results by Krzysztof Grabczewski\<close>
 
 (** Properties of converse(r) **)
 
 lemma irrefl_converse: "irrefl(A,r) \<Longrightarrow> irrefl(A,converse(r))"
 by (unfold irrefl_def, blast)
 
 lemma trans_on_converse: "trans[A](r) \<Longrightarrow> trans[A](converse(r))"
 by (unfold trans_on_def, blast)
 
 lemma part_ord_converse: "part_ord(A,r) \<Longrightarrow> part_ord(A,converse(r))"
   unfolding part_ord_def
 apply (blast intro!: irrefl_converse trans_on_converse)
 done
 
 lemma linear_converse: "linear(A,r) \<Longrightarrow> linear(A,converse(r))"
 by (unfold linear_def, blast)
 
 lemma tot_ord_converse: "tot_ord(A,r) \<Longrightarrow> tot_ord(A,converse(r))"
   unfolding tot_ord_def
 apply (blast intro!: part_ord_converse linear_converse)
 done
 
 
 (** By Krzysztof Grabczewski.
     Lemmas involving the first element of a well ordered set **)
 
 lemma first_is_elem: "first(b,B,r) \<Longrightarrow> b \<in> B"
 by (unfold first_def, blast)
 
 lemma well_ord_imp_ex1_first:
         "\<lbrakk>well_ord(A,r); B<=A; B\<noteq>0\<rbrakk> \<Longrightarrow> (\<exists>!b. first(b,B,r))"
-apply (unfold well_ord_def wf_on_def wf_def first_def)
+  unfolding well_ord_def wf_on_def wf_def first_def
 apply (elim conjE allE disjE, blast)
 apply (erule bexE)
 apply (rule_tac a = x in ex1I, auto)
 apply (unfold tot_ord_def linear_def, blast)
 done
 
 lemma the_first_in:
      "\<lbrakk>well_ord(A,r); B<=A; B\<noteq>0\<rbrakk> \<Longrightarrow> (THE b. first(b,B,r)) \<in> B"
 apply (drule well_ord_imp_ex1_first, assumption+)
 apply (rule first_is_elem)
 apply (erule theI)
 done
 
 
 subsection \<open>Lemmas for the Reflexive Orders\<close>
 
 lemma subset_vimage_vimage_iff:
   "\<lbrakk>Preorder(r); A \<subseteq> field(r); B \<subseteq> field(r)\<rbrakk> \<Longrightarrow>
   r -`` A \<subseteq> r -`` B \<longleftrightarrow> (\<forall>a\<in>A. \<exists>b\<in>B. \<langle>a, b\<rangle> \<in> r)"
   apply (auto simp: subset_def preorder_on_def refl_def vimage_def image_def)
    apply blast
   unfolding trans_on_def
   apply (erule_tac P = "(\<lambda>x. \<forall>y\<in>field(r).
           \<forall>z\<in>field(r). \<langle>x, y\<rangle> \<in> r \<longrightarrow> \<langle>y, z\<rangle> \<in> r \<longrightarrow> \<langle>x, z\<rangle> \<in> r)" for r in rev_ballE)
     (* instance obtained from proof term generated by best *)
    apply best
   apply blast
   done
 
 lemma subset_vimage1_vimage1_iff:
   "\<lbrakk>Preorder(r); a \<in> field(r); b \<in> field(r)\<rbrakk> \<Longrightarrow>
   r -`` {a} \<subseteq> r -`` {b} \<longleftrightarrow> \<langle>a, b\<rangle> \<in> r"
   by (simp add: subset_vimage_vimage_iff)
 
 lemma Refl_antisym_eq_Image1_Image1_iff:
   "\<lbrakk>refl(field(r), r); antisym(r); a \<in> field(r); b \<in> field(r)\<rbrakk> \<Longrightarrow>
   r `` {a} = r `` {b} \<longleftrightarrow> a = b"
   apply rule
    apply (frule equality_iffD)
    apply (drule equality_iffD)
    apply (simp add: antisym_def refl_def)
    apply best
   apply (simp add: antisym_def refl_def)
   done
 
 lemma Partial_order_eq_Image1_Image1_iff:
   "\<lbrakk>Partial_order(r); a \<in> field(r); b \<in> field(r)\<rbrakk> \<Longrightarrow>
   r `` {a} = r `` {b} \<longleftrightarrow> a = b"
   by (simp add: partial_order_on_def preorder_on_def
     Refl_antisym_eq_Image1_Image1_iff)
 
 lemma Refl_antisym_eq_vimage1_vimage1_iff:
   "\<lbrakk>refl(field(r), r); antisym(r); a \<in> field(r); b \<in> field(r)\<rbrakk> \<Longrightarrow>
   r -`` {a} = r -`` {b} \<longleftrightarrow> a = b"
   apply rule
    apply (frule equality_iffD)
    apply (drule equality_iffD)
    apply (simp add: antisym_def refl_def)
    apply best
   apply (simp add: antisym_def refl_def)
   done
 
 lemma Partial_order_eq_vimage1_vimage1_iff:
   "\<lbrakk>Partial_order(r); a \<in> field(r); b \<in> field(r)\<rbrakk> \<Longrightarrow>
   r -`` {a} = r -`` {b} \<longleftrightarrow> a = b"
   by (simp add: partial_order_on_def preorder_on_def
     Refl_antisym_eq_vimage1_vimage1_iff)
 
 end
diff --git a/src/ZF/OrderArith.thy b/src/ZF/OrderArith.thy
--- a/src/ZF/OrderArith.thy
+++ b/src/ZF/OrderArith.thy
@@ -1,568 +1,568 @@
 (*  Title:      ZF/OrderArith.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section\<open>Combining Orderings: Foundations of Ordinal Arithmetic\<close>
 
 theory OrderArith imports Order Sum Ordinal begin
 
 definition
   (*disjoint sum of two relations; underlies ordinal addition*)
   radd    :: "[i,i,i,i]\<Rightarrow>i"  where
     "radd(A,r,B,s) \<equiv>
                 {z: (A+B) * (A+B).
                     (\<exists>x y. z = \<langle>Inl(x), Inr(y)\<rangle>)   |
                     (\<exists>x' x. z = \<langle>Inl(x'), Inl(x)\<rangle> \<and> \<langle>x',x\<rangle>:r)   |
                     (\<exists>y' y. z = \<langle>Inr(y'), Inr(y)\<rangle> \<and> \<langle>y',y\<rangle>:s)}"
 
 definition
   (*lexicographic product of two relations; underlies ordinal multiplication*)
   rmult   :: "[i,i,i,i]\<Rightarrow>i"  where
     "rmult(A,r,B,s) \<equiv>
                 {z: (A*B) * (A*B).
                     \<exists>x' y' x y. z = \<langle>\<langle>x',y'\<rangle>, \<langle>x,y\<rangle>\<rangle> \<and>
                        (\<langle>x',x\<rangle>: r | (x'=x \<and> \<langle>y',y\<rangle>: s))}"
 
 definition
   (*inverse image of a relation*)
   rvimage :: "[i,i,i]\<Rightarrow>i"  where
     "rvimage(A,f,r) \<equiv> {z \<in> A*A. \<exists>x y. z = \<langle>x,y\<rangle> \<and> \<langle>f`x,f`y\<rangle>: r}"
 
 definition
   measure :: "[i, i\<Rightarrow>i] \<Rightarrow> i"  where
     "measure(A,f) \<equiv> {\<langle>x,y\<rangle>: A*A. f(x) < f(y)}"
 
 
 subsection\<open>Addition of Relations -- Disjoint Sum\<close>
 
 subsubsection\<open>Rewrite rules.  Can be used to obtain introduction rules\<close>
 
 lemma radd_Inl_Inr_iff [iff]:
     "\<langle>Inl(a), Inr(b)\<rangle> \<in> radd(A,r,B,s)  \<longleftrightarrow>  a \<in> A \<and> b \<in> B"
 by (unfold radd_def, blast)
 
 lemma radd_Inl_iff [iff]:
     "\<langle>Inl(a'), Inl(a)\<rangle> \<in> radd(A,r,B,s)  \<longleftrightarrow>  a':A \<and> a \<in> A \<and> \<langle>a',a\<rangle>:r"
 by (unfold radd_def, blast)
 
 lemma radd_Inr_iff [iff]:
     "\<langle>Inr(b'), Inr(b)\<rangle> \<in> radd(A,r,B,s) \<longleftrightarrow>  b':B \<and> b \<in> B \<and> \<langle>b',b\<rangle>:s"
 by (unfold radd_def, blast)
 
 lemma radd_Inr_Inl_iff [simp]:
     "\<langle>Inr(b), Inl(a)\<rangle> \<in> radd(A,r,B,s) \<longleftrightarrow> False"
 by (unfold radd_def, blast)
 
 declare radd_Inr_Inl_iff [THEN iffD1, dest!]
 
 subsubsection\<open>Elimination Rule\<close>
 
 lemma raddE:
     "\<lbrakk>\<langle>p',p\<rangle> \<in> radd(A,r,B,s);
         \<And>x y. \<lbrakk>p'=Inl(x); x \<in> A; p=Inr(y); y \<in> B\<rbrakk> \<Longrightarrow> Q;
         \<And>x' x. \<lbrakk>p'=Inl(x'); p=Inl(x); \<langle>x',x\<rangle>: r; x':A; x \<in> A\<rbrakk> \<Longrightarrow> Q;
         \<And>y' y. \<lbrakk>p'=Inr(y'); p=Inr(y); \<langle>y',y\<rangle>: s; y':B; y \<in> B\<rbrakk> \<Longrightarrow> Q
 \<rbrakk> \<Longrightarrow> Q"
 by (unfold radd_def, blast)
 
 subsubsection\<open>Type checking\<close>
 
 lemma radd_type: "radd(A,r,B,s) \<subseteq> (A+B) * (A+B)"
   unfolding radd_def
 apply (rule Collect_subset)
 done
 
 lemmas field_radd = radd_type [THEN field_rel_subset]
 
 subsubsection\<open>Linearity\<close>
 
 lemma linear_radd:
     "\<lbrakk>linear(A,r);  linear(B,s)\<rbrakk> \<Longrightarrow> linear(A+B,radd(A,r,B,s))"
 by (unfold linear_def, blast)
 
 
 subsubsection\<open>Well-foundedness\<close>
 
 lemma wf_on_radd: "\<lbrakk>wf[A](r);  wf[B](s)\<rbrakk> \<Longrightarrow> wf[A+B](radd(A,r,B,s))"
 apply (rule wf_onI2)
 apply (subgoal_tac "\<forall>x\<in>A. Inl (x) \<in> Ba")
  \<comment> \<open>Proving the lemma, which is needed twice!\<close>
  prefer 2
  apply (erule_tac V = "y \<in> A + B" in thin_rl)
  apply (rule_tac ballI)
  apply (erule_tac r = r and a = x in wf_on_induct, assumption)
  apply blast
 txt\<open>Returning to main part of proof\<close>
 apply safe
 apply blast
 apply (erule_tac r = s and a = ya in wf_on_induct, assumption, blast)
 done
 
 lemma wf_radd: "\<lbrakk>wf(r);  wf(s)\<rbrakk> \<Longrightarrow> wf(radd(field(r),r,field(s),s))"
 apply (simp add: wf_iff_wf_on_field)
 apply (rule wf_on_subset_A [OF _ field_radd])
 apply (blast intro: wf_on_radd)
 done
 
 lemma well_ord_radd:
      "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk> \<Longrightarrow> well_ord(A+B, radd(A,r,B,s))"
 apply (rule well_ordI)
 apply (simp add: well_ord_def wf_on_radd)
 apply (simp add: well_ord_def tot_ord_def linear_radd)
 done
 
 subsubsection\<open>An \<^term>\<open>ord_iso\<close> congruence law\<close>
 
 lemma sum_bij:
      "\<lbrakk>f \<in> bij(A,C);  g \<in> bij(B,D)\<rbrakk>
       \<Longrightarrow> (\<lambda>z\<in>A+B. case(\<lambda>x. Inl(f`x), \<lambda>y. Inr(g`y), z)) \<in> bij(A+B, C+D)"
 apply (rule_tac d = "case (\<lambda>x. Inl (converse(f)`x), \<lambda>y. Inr(converse(g)`y))"
        in lam_bijective)
 apply (typecheck add: bij_is_inj inj_is_fun)
 apply (auto simp add: left_inverse_bij right_inverse_bij)
 done
 
 lemma sum_ord_iso_cong:
     "\<lbrakk>f \<in> ord_iso(A,r,A',r');  g \<in> ord_iso(B,s,B',s')\<rbrakk> \<Longrightarrow>
             (\<lambda>z\<in>A+B. case(\<lambda>x. Inl(f`x), \<lambda>y. Inr(g`y), z))
             \<in> ord_iso(A+B, radd(A,r,B,s), A'+B', radd(A',r',B',s'))"
   unfolding ord_iso_def
 apply (safe intro!: sum_bij)
 (*Do the beta-reductions now*)
 apply (auto cong add: conj_cong simp add: bij_is_fun [THEN apply_type])
 done
 
 (*Could we prove an ord_iso result?  Perhaps
      ord_iso(A+B, radd(A,r,B,s), A \<union> B, r \<union> s) *)
 lemma sum_disjoint_bij: "A \<inter> B = 0 \<Longrightarrow>
             (\<lambda>z\<in>A+B. case(\<lambda>x. x, \<lambda>y. y, z)) \<in> bij(A+B, A \<union> B)"
 apply (rule_tac d = "\<lambda>z. if z \<in> A then Inl (z) else Inr (z) " in lam_bijective)
 apply auto
 done
 
 subsubsection\<open>Associativity\<close>
 
 lemma sum_assoc_bij:
      "(\<lambda>z\<in>(A+B)+C. case(case(Inl, \<lambda>y. Inr(Inl(y))), \<lambda>y. Inr(Inr(y)), z))
       \<in> bij((A+B)+C, A+(B+C))"
 apply (rule_tac d = "case (\<lambda>x. Inl (Inl (x)), case (\<lambda>x. Inl (Inr (x)), Inr))"
        in lam_bijective)
 apply auto
 done
 
 lemma sum_assoc_ord_iso:
      "(\<lambda>z\<in>(A+B)+C. case(case(Inl, \<lambda>y. Inr(Inl(y))), \<lambda>y. Inr(Inr(y)), z))
       \<in> ord_iso((A+B)+C, radd(A+B, radd(A,r,B,s), C, t),
                 A+(B+C), radd(A, r, B+C, radd(B,s,C,t)))"
 by (rule sum_assoc_bij [THEN ord_isoI], auto)
 
 
 subsection\<open>Multiplication of Relations -- Lexicographic Product\<close>
 
 subsubsection\<open>Rewrite rule.  Can be used to obtain introduction rules\<close>
 
 lemma  rmult_iff [iff]:
     "\<langle>\<langle>a',b'\<rangle>, \<langle>a,b\<rangle>\<rangle> \<in> rmult(A,r,B,s) \<longleftrightarrow>
             (\<langle>a',a\<rangle>: r  \<and> a':A \<and> a \<in> A \<and> b': B \<and> b \<in> B) |
             (\<langle>b',b\<rangle>: s  \<and> a'=a \<and> a \<in> A \<and> b': B \<and> b \<in> B)"
 
 by (unfold rmult_def, blast)
 
 lemma rmultE:
     "\<lbrakk>\<langle>\<langle>a',b'\<rangle>, \<langle>a,b\<rangle>\<rangle> \<in> rmult(A,r,B,s);
         \<lbrakk>\<langle>a',a\<rangle>: r;  a':A;  a \<in> A;  b':B;  b \<in> B\<rbrakk> \<Longrightarrow> Q;
         \<lbrakk>\<langle>b',b\<rangle>: s;  a \<in> A;  a'=a;  b':B;  b \<in> B\<rbrakk> \<Longrightarrow> Q
 \<rbrakk> \<Longrightarrow> Q"
 by blast
 
 subsubsection\<open>Type checking\<close>
 
 lemma rmult_type: "rmult(A,r,B,s) \<subseteq> (A*B) * (A*B)"
 by (unfold rmult_def, rule Collect_subset)
 
 lemmas field_rmult = rmult_type [THEN field_rel_subset]
 
 subsubsection\<open>Linearity\<close>
 
 lemma linear_rmult:
     "\<lbrakk>linear(A,r);  linear(B,s)\<rbrakk> \<Longrightarrow> linear(A*B,rmult(A,r,B,s))"
 by (simp add: linear_def, blast)
 
 subsubsection\<open>Well-foundedness\<close>
 
 lemma wf_on_rmult: "\<lbrakk>wf[A](r);  wf[B](s)\<rbrakk> \<Longrightarrow> wf[A*B](rmult(A,r,B,s))"
 apply (rule wf_onI2)
 apply (erule SigmaE)
 apply (erule ssubst)
 apply (subgoal_tac "\<forall>b\<in>B. \<langle>x,b\<rangle>: Ba", blast)
 apply (erule_tac a = x in wf_on_induct, assumption)
 apply (rule ballI)
 apply (erule_tac a = b in wf_on_induct, assumption)
 apply (best elim!: rmultE bspec [THEN mp])
 done
 
 
 lemma wf_rmult: "\<lbrakk>wf(r);  wf(s)\<rbrakk> \<Longrightarrow> wf(rmult(field(r),r,field(s),s))"
 apply (simp add: wf_iff_wf_on_field)
 apply (rule wf_on_subset_A [OF _ field_rmult])
 apply (blast intro: wf_on_rmult)
 done
 
 lemma well_ord_rmult:
      "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk> \<Longrightarrow> well_ord(A*B, rmult(A,r,B,s))"
 apply (rule well_ordI)
 apply (simp add: well_ord_def wf_on_rmult)
 apply (simp add: well_ord_def tot_ord_def linear_rmult)
 done
 
 
 subsubsection\<open>An \<^term>\<open>ord_iso\<close> congruence law\<close>
 
 lemma prod_bij:
      "\<lbrakk>f \<in> bij(A,C);  g \<in> bij(B,D)\<rbrakk>
       \<Longrightarrow> (lam \<langle>x,y\<rangle>:A*B. \<langle>f`x, g`y\<rangle>) \<in> bij(A*B, C*D)"
 apply (rule_tac d = "\<lambda>\<langle>x,y\<rangle>. \<langle>converse (f) `x, converse (g) `y\<rangle>"
        in lam_bijective)
 apply (typecheck add: bij_is_inj inj_is_fun)
 apply (auto simp add: left_inverse_bij right_inverse_bij)
 done
 
 lemma prod_ord_iso_cong:
     "\<lbrakk>f \<in> ord_iso(A,r,A',r');  g \<in> ord_iso(B,s,B',s')\<rbrakk>
      \<Longrightarrow> (lam \<langle>x,y\<rangle>:A*B. \<langle>f`x, g`y\<rangle>)
          \<in> ord_iso(A*B, rmult(A,r,B,s), A'*B', rmult(A',r',B',s'))"
   unfolding ord_iso_def
 apply (safe intro!: prod_bij)
 apply (simp_all add: bij_is_fun [THEN apply_type])
 apply (blast intro: bij_is_inj [THEN inj_apply_equality])
 done
 
 lemma singleton_prod_bij: "(\<lambda>z\<in>A. \<langle>x,z\<rangle>) \<in> bij(A, {x}*A)"
 by (rule_tac d = snd in lam_bijective, auto)
 
 (*Used??*)
 lemma singleton_prod_ord_iso:
      "well_ord({x},xr) \<Longrightarrow>
           (\<lambda>z\<in>A. \<langle>x,z\<rangle>) \<in> ord_iso(A, r, {x}*A, rmult({x}, xr, A, r))"
 apply (rule singleton_prod_bij [THEN ord_isoI])
 apply (simp (no_asm_simp))
 apply (blast dest: well_ord_is_wf [THEN wf_on_not_refl])
 done
 
 (*Here we build a complicated function term, then simplify it using
   case_cong, id_conv, comp_lam, case_case.*)
 lemma prod_sum_singleton_bij:
      "a\<notin>C \<Longrightarrow>
        (\<lambda>x\<in>C*B + D. case(\<lambda>x. x, \<lambda>y.\<langle>a,y\<rangle>, x))
        \<in> bij(C*B + D, C*B \<union> {a}*D)"
 apply (rule subst_elem)
 apply (rule id_bij [THEN sum_bij, THEN comp_bij])
 apply (rule singleton_prod_bij)
 apply (rule sum_disjoint_bij, blast)
 apply (simp (no_asm_simp) cong add: case_cong)
 apply (rule comp_lam [THEN trans, symmetric])
 apply (fast elim!: case_type)
 apply (simp (no_asm_simp) add: case_case)
 done
 
 lemma prod_sum_singleton_ord_iso:
  "\<lbrakk>a \<in> A;  well_ord(A,r)\<rbrakk> \<Longrightarrow>
     (\<lambda>x\<in>pred(A,a,r)*B + pred(B,b,s). case(\<lambda>x. x, \<lambda>y.\<langle>a,y\<rangle>, x))
     \<in> ord_iso(pred(A,a,r)*B + pred(B,b,s),
                   radd(A*B, rmult(A,r,B,s), B, s),
               pred(A,a,r)*B \<union> {a}*pred(B,b,s), rmult(A,r,B,s))"
 apply (rule prod_sum_singleton_bij [THEN ord_isoI])
 apply (simp (no_asm_simp) add: pred_iff well_ord_is_wf [THEN wf_on_not_refl])
 apply (auto elim!: well_ord_is_wf [THEN wf_on_asym] predE)
 done
 
 subsubsection\<open>Distributive law\<close>
 
 lemma sum_prod_distrib_bij:
      "(lam \<langle>x,z\<rangle>:(A+B)*C. case(\<lambda>y. Inl(\<langle>y,z\<rangle>), \<lambda>y. Inr(\<langle>y,z\<rangle>), x))
       \<in> bij((A+B)*C, (A*C)+(B*C))"
 by (rule_tac d = "case (\<lambda>\<langle>x,y\<rangle>.\<langle>Inl (x),y\<rangle>, \<lambda>\<langle>x,y\<rangle>.\<langle>Inr (x),y\<rangle>) "
     in lam_bijective, auto)
 
 lemma sum_prod_distrib_ord_iso:
  "(lam \<langle>x,z\<rangle>:(A+B)*C. case(\<lambda>y. Inl(\<langle>y,z\<rangle>), \<lambda>y. Inr(\<langle>y,z\<rangle>), x))
   \<in> ord_iso((A+B)*C, rmult(A+B, radd(A,r,B,s), C, t),
             (A*C)+(B*C), radd(A*C, rmult(A,r,C,t), B*C, rmult(B,s,C,t)))"
 by (rule sum_prod_distrib_bij [THEN ord_isoI], auto)
 
 subsubsection\<open>Associativity\<close>
 
 lemma prod_assoc_bij:
      "(lam \<langle>\<langle>x,y\<rangle>, z\<rangle>:(A*B)*C. \<langle>x,\<langle>y,z\<rangle>\<rangle>) \<in> bij((A*B)*C, A*(B*C))"
 by (rule_tac d = "\<lambda>\<langle>x, \<langle>y,z\<rangle>\<rangle>. \<langle>\<langle>x,y\<rangle>, z\<rangle>" in lam_bijective, auto)
 
 lemma prod_assoc_ord_iso:
  "(lam \<langle>\<langle>x,y\<rangle>, z\<rangle>:(A*B)*C. \<langle>x,\<langle>y,z\<rangle>\<rangle>)
   \<in> ord_iso((A*B)*C, rmult(A*B, rmult(A,r,B,s), C, t),
             A*(B*C), rmult(A, r, B*C, rmult(B,s,C,t)))"
 by (rule prod_assoc_bij [THEN ord_isoI], auto)
 
 subsection\<open>Inverse Image of a Relation\<close>
 
 subsubsection\<open>Rewrite rule\<close>
 
 lemma rvimage_iff: "\<langle>a,b\<rangle> \<in> rvimage(A,f,r)  \<longleftrightarrow>  \<langle>f`a,f`b\<rangle>: r \<and> a \<in> A \<and> b \<in> A"
 by (unfold rvimage_def, blast)
 
 subsubsection\<open>Type checking\<close>
 
 lemma rvimage_type: "rvimage(A,f,r) \<subseteq> A*A"
 by (unfold rvimage_def, rule Collect_subset)
 
 lemmas field_rvimage = rvimage_type [THEN field_rel_subset]
 
 lemma rvimage_converse: "rvimage(A,f, converse(r)) = converse(rvimage(A,f,r))"
 by (unfold rvimage_def, blast)
 
 
 subsubsection\<open>Partial Ordering Properties\<close>
 
 lemma irrefl_rvimage:
     "\<lbrakk>f \<in> inj(A,B);  irrefl(B,r)\<rbrakk> \<Longrightarrow> irrefl(A, rvimage(A,f,r))"
-apply (unfold irrefl_def rvimage_def)
+  unfolding irrefl_def rvimage_def
 apply (blast intro: inj_is_fun [THEN apply_type])
 done
 
 lemma trans_on_rvimage:
     "\<lbrakk>f \<in> inj(A,B);  trans[B](r)\<rbrakk> \<Longrightarrow> trans[A](rvimage(A,f,r))"
-apply (unfold trans_on_def rvimage_def)
+  unfolding trans_on_def rvimage_def
 apply (blast intro: inj_is_fun [THEN apply_type])
 done
 
 lemma part_ord_rvimage:
     "\<lbrakk>f \<in> inj(A,B);  part_ord(B,r)\<rbrakk> \<Longrightarrow> part_ord(A, rvimage(A,f,r))"
   unfolding part_ord_def
 apply (blast intro!: irrefl_rvimage trans_on_rvimage)
 done
 
 subsubsection\<open>Linearity\<close>
 
 lemma linear_rvimage:
     "\<lbrakk>f \<in> inj(A,B);  linear(B,r)\<rbrakk> \<Longrightarrow> linear(A,rvimage(A,f,r))"
 apply (simp add: inj_def linear_def rvimage_iff)
 apply (blast intro: apply_funtype)
 done
 
 lemma tot_ord_rvimage:
     "\<lbrakk>f \<in> inj(A,B);  tot_ord(B,r)\<rbrakk> \<Longrightarrow> tot_ord(A, rvimage(A,f,r))"
   unfolding tot_ord_def
 apply (blast intro!: part_ord_rvimage linear_rvimage)
 done
 
 
 subsubsection\<open>Well-foundedness\<close>
 
 lemma wf_rvimage [intro!]: "wf(r) \<Longrightarrow> wf(rvimage(A,f,r))"
 apply (simp (no_asm_use) add: rvimage_def wf_eq_minimal)
 apply clarify
 apply (subgoal_tac "\<exists>w. w \<in> {w: {f`x. x \<in> Q}. \<exists>x. x \<in> Q \<and> (f`x = w) }")
  apply (erule allE)
  apply (erule impE)
  apply assumption
  apply blast
 apply blast
 done
 
 text\<open>But note that the combination of \<open>wf_imp_wf_on\<close> and
  \<open>wf_rvimage\<close> gives \<^prop>\<open>wf(r) \<Longrightarrow> wf[C](rvimage(A,f,r))\<close>\<close>
 lemma wf_on_rvimage: "\<lbrakk>f \<in> A\<rightarrow>B;  wf[B](r)\<rbrakk> \<Longrightarrow> wf[A](rvimage(A,f,r))"
 apply (rule wf_onI2)
 apply (subgoal_tac "\<forall>z\<in>A. f`z=f`y \<longrightarrow> z \<in> Ba")
  apply blast
 apply (erule_tac a = "f`y" in wf_on_induct)
  apply (blast intro!: apply_funtype)
 apply (blast intro!: apply_funtype dest!: rvimage_iff [THEN iffD1])
 done
 
 (*Note that we need only wf[A](...) and linear(A,...) to get the result!*)
 lemma well_ord_rvimage:
      "\<lbrakk>f \<in> inj(A,B);  well_ord(B,r)\<rbrakk> \<Longrightarrow> well_ord(A, rvimage(A,f,r))"
 apply (rule well_ordI)
-apply (unfold well_ord_def tot_ord_def)
+  unfolding well_ord_def tot_ord_def
 apply (blast intro!: wf_on_rvimage inj_is_fun)
 apply (blast intro!: linear_rvimage)
 done
 
 lemma ord_iso_rvimage:
     "f \<in> bij(A,B) \<Longrightarrow> f \<in> ord_iso(A, rvimage(A,f,s), B, s)"
   unfolding ord_iso_def
 apply (simp add: rvimage_iff)
 done
 
 lemma ord_iso_rvimage_eq:
     "f \<in> ord_iso(A,r, B,s) \<Longrightarrow> rvimage(A,f,s) = r \<inter> A*A"
 by (unfold ord_iso_def rvimage_def, blast)
 
 
 subsection\<open>Every well-founded relation is a subset of some inverse image of
       an ordinal\<close>
 
 lemma wf_rvimage_Ord: "Ord(i) \<Longrightarrow> wf(rvimage(A, f, Memrel(i)))"
 by (blast intro: wf_rvimage wf_Memrel)
 
 
 definition
   wfrank :: "[i,i]\<Rightarrow>i"  where
     "wfrank(r,a) \<equiv> wfrec(r, a, \<lambda>x f. \<Union>y \<in> r-``{x}. succ(f`y))"
 
 definition
   wftype :: "i\<Rightarrow>i"  where
     "wftype(r) \<equiv> \<Union>y \<in> range(r). succ(wfrank(r,y))"
 
 lemma wfrank: "wf(r) \<Longrightarrow> wfrank(r,a) = (\<Union>y \<in> r-``{a}. succ(wfrank(r,y)))"
 by (subst wfrank_def [THEN def_wfrec], simp_all)
 
 lemma Ord_wfrank: "wf(r) \<Longrightarrow> Ord(wfrank(r,a))"
 apply (rule_tac a=a in wf_induct, assumption)
 apply (subst wfrank, assumption)
 apply (rule Ord_succ [THEN Ord_UN], blast)
 done
 
 lemma wfrank_lt: "\<lbrakk>wf(r); \<langle>a,b\<rangle> \<in> r\<rbrakk> \<Longrightarrow> wfrank(r,a) < wfrank(r,b)"
 apply (rule_tac a1 = b in wfrank [THEN ssubst], assumption)
 apply (rule UN_I [THEN ltI])
 apply (simp add: Ord_wfrank vimage_iff)+
 done
 
 lemma Ord_wftype: "wf(r) \<Longrightarrow> Ord(wftype(r))"
 by (simp add: wftype_def Ord_wfrank)
 
 lemma wftypeI: "\<lbrakk>wf(r);  x \<in> field(r)\<rbrakk> \<Longrightarrow> wfrank(r,x) \<in> wftype(r)"
 apply (simp add: wftype_def)
 apply (blast intro: wfrank_lt [THEN ltD])
 done
 
 
 lemma wf_imp_subset_rvimage:
      "\<lbrakk>wf(r); r \<subseteq> A*A\<rbrakk> \<Longrightarrow> \<exists>i f. Ord(i) \<and> r \<subseteq> rvimage(A, f, Memrel(i))"
 apply (rule_tac x="wftype(r)" in exI)
 apply (rule_tac x="\<lambda>x\<in>A. wfrank(r,x)" in exI)
 apply (simp add: Ord_wftype, clarify)
 apply (frule subsetD, assumption, clarify)
 apply (simp add: rvimage_iff wfrank_lt [THEN ltD])
 apply (blast intro: wftypeI)
 done
 
 theorem wf_iff_subset_rvimage:
   "relation(r) \<Longrightarrow> wf(r) \<longleftrightarrow> (\<exists>i f A. Ord(i) \<and> r \<subseteq> rvimage(A, f, Memrel(i)))"
 by (blast dest!: relation_field_times_field wf_imp_subset_rvimage
           intro: wf_rvimage_Ord [THEN wf_subset])
 
 
 subsection\<open>Other Results\<close>
 
 lemma wf_times: "A \<inter> B = 0 \<Longrightarrow> wf(A*B)"
 by (simp add: wf_def, blast)
 
 text\<open>Could also be used to prove \<open>wf_radd\<close>\<close>
 lemma wf_Un:
      "\<lbrakk>range(r) \<inter> domain(s) = 0; wf(r);  wf(s)\<rbrakk> \<Longrightarrow> wf(r \<union> s)"
 apply (simp add: wf_def, clarify)
 apply (rule equalityI)
  prefer 2 apply blast
 apply clarify
 apply (drule_tac x=Z in spec)
 apply (drule_tac x="Z \<inter> domain(s)" in spec)
 apply simp
 apply (blast intro: elim: equalityE)
 done
 
 subsubsection\<open>The Empty Relation\<close>
 
 lemma wf0: "wf(0)"
 by (simp add: wf_def, blast)
 
 lemma linear0: "linear(0,0)"
 by (simp add: linear_def)
 
 lemma well_ord0: "well_ord(0,0)"
 by (blast intro: wf_imp_wf_on well_ordI wf0 linear0)
 
 subsubsection\<open>The "measure" relation is useful with wfrec\<close>
 
 lemma measure_eq_rvimage_Memrel:
      "measure(A,f) = rvimage(A,Lambda(A,f),Memrel(Collect(RepFun(A,f),Ord)))"
 apply (simp (no_asm) add: measure_def rvimage_def Memrel_iff)
 apply (rule equalityI, auto)
 apply (auto intro: Ord_in_Ord simp add: lt_def)
 done
 
 lemma wf_measure [iff]: "wf(measure(A,f))"
 by (simp (no_asm) add: measure_eq_rvimage_Memrel wf_Memrel wf_rvimage)
 
 lemma measure_iff [iff]: "\<langle>x,y\<rangle> \<in> measure(A,f) \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> f(x)<f(y)"
 by (simp (no_asm) add: measure_def)
 
 lemma linear_measure:
  assumes Ordf: "\<And>x. x \<in> A \<Longrightarrow> Ord(f(x))"
      and inj:  "\<And>x y. \<lbrakk>x \<in> A; y \<in> A; f(x) = f(y)\<rbrakk> \<Longrightarrow> x=y"
  shows "linear(A, measure(A,f))"
 apply (auto simp add: linear_def)
 apply (rule_tac i="f(x)" and j="f(y)" in Ord_linear_lt)
     apply (simp_all add: Ordf)
 apply (blast intro: inj)
 done
 
 lemma wf_on_measure: "wf[B](measure(A,f))"
 by (rule wf_imp_wf_on [OF wf_measure])
 
 lemma well_ord_measure:
  assumes Ordf: "\<And>x. x \<in> A \<Longrightarrow> Ord(f(x))"
      and inj:  "\<And>x y. \<lbrakk>x \<in> A; y \<in> A; f(x) = f(y)\<rbrakk> \<Longrightarrow> x=y"
  shows "well_ord(A, measure(A,f))"
 apply (rule well_ordI)
 apply (rule wf_on_measure)
 apply (blast intro: linear_measure Ordf inj)
 done
 
 lemma measure_type: "measure(A,f) \<subseteq> A*A"
 by (auto simp add: measure_def)
 
 subsubsection\<open>Well-foundedness of Unions\<close>
 
 lemma wf_on_Union:
  assumes wfA: "wf[A](r)"
      and wfB: "\<And>a. a\<in>A \<Longrightarrow> wf[B(a)](s)"
      and ok: "\<And>a u v. \<lbrakk>\<langle>u,v\<rangle> \<in> s; v \<in> B(a); a \<in> A\<rbrakk>
                        \<Longrightarrow> (\<exists>a'\<in>A. \<langle>a',a\<rangle> \<in> r \<and> u \<in> B(a')) | u \<in> B(a)"
  shows "wf[\<Union>a\<in>A. B(a)](s)"
 apply (rule wf_onI2)
 apply (erule UN_E)
 apply (subgoal_tac "\<forall>z \<in> B(a). z \<in> Ba", blast)
 apply (rule_tac a = a in wf_on_induct [OF wfA], assumption)
 apply (rule ballI)
 apply (rule_tac a = z in wf_on_induct [OF wfB], assumption, assumption)
 apply (rename_tac u)
 apply (drule_tac x=u in bspec, blast)
 apply (erule mp, clarify)
 apply (frule ok, assumption+, blast)
 done
 
 subsubsection\<open>Bijections involving Powersets\<close>
 
 lemma Pow_sum_bij:
     "(\<lambda>Z \<in> Pow(A+B). \<langle>{x \<in> A. Inl(x) \<in> Z}, {y \<in> B. Inr(y) \<in> Z}\<rangle>)
      \<in> bij(Pow(A+B), Pow(A)*Pow(B))"
 apply (rule_tac d = "\<lambda>\<langle>X,Y\<rangle>. {Inl (x). x \<in> X} \<union> {Inr (y). y \<in> Y}"
        in lam_bijective)
 apply force+
 done
 
 text\<open>As a special case, we have \<^term>\<open>bij(Pow(A*B), A \<rightarrow> Pow(B))\<close>\<close>
 lemma Pow_Sigma_bij:
     "(\<lambda>r \<in> Pow(Sigma(A,B)). \<lambda>x \<in> A. r``{x})
      \<in> bij(Pow(Sigma(A,B)), \<Prod>x \<in> A. Pow(B(x)))"
 apply (rule_tac d = "\<lambda>f. \<Union>x \<in> A. \<Union>y \<in> f`x. {\<langle>x,y\<rangle>}" in lam_bijective)
 apply (blast intro: lam_type)
 apply (blast dest: apply_type, simp_all)
 apply fast (*strange, but blast can't do it*)
 apply (rule fun_extension, auto)
 by blast
 
 end
diff --git a/src/ZF/OrderType.thy b/src/ZF/OrderType.thy
--- a/src/ZF/OrderType.thy
+++ b/src/ZF/OrderType.thy
@@ -1,1028 +1,1028 @@
 (*  Title:      ZF/OrderType.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section\<open>Order Types and Ordinal Arithmetic\<close>
 
 theory OrderType imports OrderArith OrdQuant Nat begin
 
 text\<open>The order type of a well-ordering is the least ordinal isomorphic to it.
 Ordinal arithmetic is traditionally defined in terms of order types, as it is
 here.  But a definition by transfinite recursion would be much simpler!\<close>
 
 definition
   ordermap  :: "[i,i]\<Rightarrow>i"  where
    "ordermap(A,r) \<equiv> \<lambda>x\<in>A. wfrec[A](r, x, \<lambda>x f. f `` pred(A,x,r))"
 
 definition
   ordertype :: "[i,i]\<Rightarrow>i"  where
    "ordertype(A,r) \<equiv> ordermap(A,r)``A"
 
 definition
   (*alternative definition of ordinal numbers*)
   Ord_alt   :: "i \<Rightarrow> o"  where
    "Ord_alt(X) \<equiv> well_ord(X, Memrel(X)) \<and> (\<forall>u\<in>X. u=pred(X, u, Memrel(X)))"
 
 definition
   (*coercion to ordinal: if not, just 0*)
   ordify    :: "i\<Rightarrow>i"  where
     "ordify(x) \<equiv> if Ord(x) then x else 0"
 
 definition
   (*ordinal multiplication*)
   omult      :: "[i,i]\<Rightarrow>i"           (infixl \<open>**\<close> 70)  where
    "i ** j \<equiv> ordertype(j*i, rmult(j,Memrel(j),i,Memrel(i)))"
 
 definition
   (*ordinal addition*)
   raw_oadd   :: "[i,i]\<Rightarrow>i"  where
     "raw_oadd(i,j) \<equiv> ordertype(i+j, radd(i,Memrel(i),j,Memrel(j)))"
 
 definition
   oadd      :: "[i,i]\<Rightarrow>i"           (infixl \<open>++\<close> 65)  where
     "i ++ j \<equiv> raw_oadd(ordify(i),ordify(j))"
 
 definition
   (*ordinal subtraction*)
   odiff      :: "[i,i]\<Rightarrow>i"           (infixl \<open>--\<close> 65)  where
     "i -- j \<equiv> ordertype(i-j, Memrel(i))"
 
 
 subsection\<open>Proofs needing the combination of Ordinal.thy and Order.thy\<close>
 
 lemma le_well_ord_Memrel: "j \<le> i \<Longrightarrow> well_ord(j, Memrel(i))"
 apply (rule well_ordI)
 apply (rule wf_Memrel [THEN wf_imp_wf_on])
 apply (simp add: ltD lt_Ord linear_def
                  ltI [THEN lt_trans2 [of _ j i]])
 apply (intro ballI Ord_linear)
 apply (blast intro: Ord_in_Ord lt_Ord)+
 done
 
 (*"Ord(i) \<Longrightarrow> well_ord(i, Memrel(i))"*)
 lemmas well_ord_Memrel = le_refl [THEN le_well_ord_Memrel]
 
 (*Kunen's Theorem 7.3 (i), page 16;  see also Ordinal/Ord_in_Ord
   The smaller ordinal is an initial segment of the larger *)
 lemma lt_pred_Memrel:
     "j<i \<Longrightarrow> pred(i, j, Memrel(i)) = j"
 apply (simp add: pred_def lt_def)
 apply (blast intro: Ord_trans)
 done
 
 lemma pred_Memrel:
       "x \<in> A \<Longrightarrow> pred(A, x, Memrel(A)) = A \<inter> x"
 by (unfold pred_def Memrel_def, blast)
 
 lemma Ord_iso_implies_eq_lemma:
      "\<lbrakk>j<i;  f \<in> ord_iso(i,Memrel(i),j,Memrel(j))\<rbrakk> \<Longrightarrow> R"
 apply (frule lt_pred_Memrel)
 apply (erule ltE)
 apply (rule well_ord_Memrel [THEN well_ord_iso_predE, of i f j], auto)
   unfolding ord_iso_def
 (*Combining the two simplifications causes looping*)
 apply (simp (no_asm_simp))
 apply (blast intro: bij_is_fun [THEN apply_type] Ord_trans)
 done
 
 (*Kunen's Theorem 7.3 (ii), page 16.  Isomorphic ordinals are equal*)
 lemma Ord_iso_implies_eq:
      "\<lbrakk>Ord(i);  Ord(j);  f \<in> ord_iso(i,Memrel(i),j,Memrel(j))\<rbrakk>
       \<Longrightarrow> i=j"
 apply (rule_tac i = i and j = j in Ord_linear_lt)
 apply (blast intro: ord_iso_sym Ord_iso_implies_eq_lemma)+
 done
 
 
 subsection\<open>Ordermap and ordertype\<close>
 
 lemma ordermap_type:
     "ordermap(A,r) \<in> A -> ordertype(A,r)"
-apply (unfold ordermap_def ordertype_def)
+  unfolding ordermap_def ordertype_def
 apply (rule lam_type)
 apply (rule lamI [THEN imageI], assumption+)
 done
 
 subsubsection\<open>Unfolding of ordermap\<close>
 
 (*Useful for cardinality reasoning; see CardinalArith.ML*)
 lemma ordermap_eq_image:
     "\<lbrakk>wf[A](r);  x \<in> A\<rbrakk>
      \<Longrightarrow> ordermap(A,r) ` x = ordermap(A,r) `` pred(A,x,r)"
-apply (unfold ordermap_def pred_def)
+  unfolding ordermap_def pred_def
 apply (simp (no_asm_simp))
 apply (erule wfrec_on [THEN trans], assumption)
 apply (simp (no_asm_simp) add: subset_iff image_lam vimage_singleton_iff)
 done
 
 (*Useful for rewriting PROVIDED pred is not unfolded until later!*)
 lemma ordermap_pred_unfold:
      "\<lbrakk>wf[A](r);  x \<in> A\<rbrakk>
       \<Longrightarrow> ordermap(A,r) ` x = {ordermap(A,r)`y . y \<in> pred(A,x,r)}"
 by (simp add: ordermap_eq_image pred_subset ordermap_type [THEN image_fun])
 
 (*pred-unfolded version.  NOT suitable for rewriting -- loops!*)
 lemmas ordermap_unfold = ordermap_pred_unfold [simplified pred_def]
 
 (*The theorem above is
 
 \<lbrakk>wf[A](r); x \<in> A\<rbrakk>
 \<Longrightarrow> ordermap(A,r) ` x = {ordermap(A,r) ` y . y: {y \<in> A . \<langle>y,x\<rangle> \<in> r}}
 
 NOTE: the definition of ordermap used here delivers ordinals only if r is
 transitive.  If r is the predecessor relation on the naturals then
 ordermap(nat,predr) ` n equals {n-1} and not n.  A more complicated definition,
 like
 
   ordermap(A,r) ` x = Union{succ(ordermap(A,r) ` y) . y: {y \<in> A . \<langle>y,x\<rangle> \<in> r}},
 
 might eliminate the need for r to be transitive.
 *)
 
 
 subsubsection\<open>Showing that ordermap, ordertype yield ordinals\<close>
 
 lemma Ord_ordermap:
     "\<lbrakk>well_ord(A,r);  x \<in> A\<rbrakk> \<Longrightarrow> Ord(ordermap(A,r) ` x)"
 apply (unfold well_ord_def tot_ord_def part_ord_def, safe)
 apply (rule_tac a=x in wf_on_induct, assumption+)
 apply (simp (no_asm_simp) add: ordermap_pred_unfold)
 apply (rule OrdI [OF _ Ord_is_Transset])
-apply (unfold pred_def Transset_def)
+  unfolding pred_def Transset_def
 apply (blast intro: trans_onD
              dest!: ordermap_unfold [THEN equalityD1])+
 done
 
 lemma Ord_ordertype:
     "well_ord(A,r) \<Longrightarrow> Ord(ordertype(A,r))"
   unfolding ordertype_def
 apply (subst image_fun [OF ordermap_type subset_refl])
 apply (rule OrdI [OF _ Ord_is_Transset])
 prefer 2 apply (blast intro: Ord_ordermap)
-apply (unfold Transset_def well_ord_def)
+  unfolding Transset_def well_ord_def
 apply (blast intro: trans_onD
              dest!: ordermap_unfold [THEN equalityD1])
 done
 
 
 subsubsection\<open>ordermap preserves the orderings in both directions\<close>
 
 lemma ordermap_mono:
      "\<lbrakk>\<langle>w,x\<rangle>: r;  wf[A](r);  w \<in> A; x \<in> A\<rbrakk>
       \<Longrightarrow> ordermap(A,r)`w \<in> ordermap(A,r)`x"
 apply (erule_tac x1 = x in ordermap_unfold [THEN ssubst], assumption, blast)
 done
 
 (*linearity of r is crucial here*)
 lemma converse_ordermap_mono:
     "\<lbrakk>ordermap(A,r)`w \<in> ordermap(A,r)`x;  well_ord(A,r); w \<in> A; x \<in> A\<rbrakk>
      \<Longrightarrow> \<langle>w,x\<rangle>: r"
 apply (unfold well_ord_def tot_ord_def, safe)
 apply (erule_tac x=w and y=x in linearE, assumption+)
 apply (blast elim!: mem_not_refl [THEN notE])
 apply (blast dest: ordermap_mono intro: mem_asym)
 done
 
 lemma ordermap_surj: "ordermap(A, r) \<in> surj(A, ordertype(A, r))"
   unfolding ordertype_def
   by (rule surj_image) (rule ordermap_type)
 
 lemma ordermap_bij:
     "well_ord(A,r) \<Longrightarrow> ordermap(A,r) \<in> bij(A, ordertype(A,r))"
-apply (unfold well_ord_def tot_ord_def bij_def inj_def)
+  unfolding well_ord_def tot_ord_def bij_def inj_def
 apply (force intro!: ordermap_type ordermap_surj
              elim: linearE dest: ordermap_mono
              simp add: mem_not_refl)
 done
 
 subsubsection\<open>Isomorphisms involving ordertype\<close>
 
 lemma ordertype_ord_iso:
  "well_ord(A,r)
   \<Longrightarrow> ordermap(A,r) \<in> ord_iso(A,r, ordertype(A,r), Memrel(ordertype(A,r)))"
   unfolding ord_iso_def
 apply (safe elim!: well_ord_is_wf
             intro!: ordermap_type [THEN apply_type] ordermap_mono ordermap_bij)
 apply (blast dest!: converse_ordermap_mono)
 done
 
 lemma ordertype_eq:
      "\<lbrakk>f \<in> ord_iso(A,r,B,s);  well_ord(B,s)\<rbrakk>
       \<Longrightarrow> ordertype(A,r) = ordertype(B,s)"
 apply (frule well_ord_ord_iso, assumption)
 apply (rule Ord_iso_implies_eq, (erule Ord_ordertype)+)
 apply (blast intro: ord_iso_trans ord_iso_sym ordertype_ord_iso)
 done
 
 lemma ordertype_eq_imp_ord_iso:
      "\<lbrakk>ordertype(A,r) = ordertype(B,s); well_ord(A,r);  well_ord(B,s)\<rbrakk>
       \<Longrightarrow> \<exists>f. f \<in> ord_iso(A,r,B,s)"
 apply (rule exI)
 apply (rule ordertype_ord_iso [THEN ord_iso_trans], assumption)
 apply (erule ssubst)
 apply (erule ordertype_ord_iso [THEN ord_iso_sym])
 done
 
 subsubsection\<open>Basic equalities for ordertype\<close>
 
 (*Ordertype of Memrel*)
 lemma le_ordertype_Memrel: "j \<le> i \<Longrightarrow> ordertype(j,Memrel(i)) = j"
 apply (rule Ord_iso_implies_eq [symmetric])
 apply (erule ltE, assumption)
 apply (blast intro: le_well_ord_Memrel Ord_ordertype)
 apply (rule ord_iso_trans)
 apply (erule_tac [2] le_well_ord_Memrel [THEN ordertype_ord_iso])
 apply (rule id_bij [THEN ord_isoI])
 apply (simp (no_asm_simp))
 apply (fast elim: ltE Ord_in_Ord Ord_trans)
 done
 
 (*"Ord(i) \<Longrightarrow> ordertype(i, Memrel(i)) = i"*)
 lemmas ordertype_Memrel = le_refl [THEN le_ordertype_Memrel]
 
 lemma ordertype_0 [simp]: "ordertype(0,r) = 0"
 apply (rule id_bij [THEN ord_isoI, THEN ordertype_eq, THEN trans])
 apply (erule emptyE)
 apply (rule well_ord_0)
 apply (rule Ord_0 [THEN ordertype_Memrel])
 done
 
 (*Ordertype of rvimage:  \<lbrakk>f \<in> bij(A,B);  well_ord(B,s)\<rbrakk> \<Longrightarrow>
                          ordertype(A, rvimage(A,f,s)) = ordertype(B,s) *)
 lemmas bij_ordertype_vimage = ord_iso_rvimage [THEN ordertype_eq]
 
 subsubsection\<open>A fundamental unfolding law for ordertype.\<close>
 
 (*Ordermap returns the same result if applied to an initial segment*)
 lemma ordermap_pred_eq_ordermap:
      "\<lbrakk>well_ord(A,r);  y \<in> A;  z \<in> pred(A,y,r)\<rbrakk>
       \<Longrightarrow> ordermap(pred(A,y,r), r) ` z = ordermap(A, r) ` z"
 apply (frule wf_on_subset_A [OF well_ord_is_wf pred_subset])
 apply (rule_tac a=z in wf_on_induct, assumption+)
 apply (safe elim!: predE)
 apply (simp (no_asm_simp) add: ordermap_pred_unfold well_ord_is_wf pred_iff)
 (*combining these two simplifications LOOPS! *)
 apply (simp (no_asm_simp) add: pred_pred_eq)
 apply (simp add: pred_def)
 apply (rule RepFun_cong [OF _ refl])
 apply (drule well_ord_is_trans_on)
 apply (fast elim!: trans_onD)
 done
 
 lemma ordertype_unfold:
     "ordertype(A,r) = {ordermap(A,r)`y . y \<in> A}"
   unfolding ordertype_def
 apply (rule image_fun [OF ordermap_type subset_refl])
 done
 
 text\<open>Theorems by Krzysztof Grabczewski; proofs simplified by lcp\<close>
 
 lemma ordertype_pred_subset: "\<lbrakk>well_ord(A,r);  x \<in> A\<rbrakk> \<Longrightarrow>
           ordertype(pred(A,x,r),r) \<subseteq> ordertype(A,r)"
 apply (simp add: ordertype_unfold well_ord_subset [OF _ pred_subset])
 apply (fast intro: ordermap_pred_eq_ordermap elim: predE)
 done
 
 lemma ordertype_pred_lt:
      "\<lbrakk>well_ord(A,r);  x \<in> A\<rbrakk>
       \<Longrightarrow> ordertype(pred(A,x,r),r) < ordertype(A,r)"
 apply (rule ordertype_pred_subset [THEN subset_imp_le, THEN leE])
 apply (simp_all add: Ord_ordertype well_ord_subset [OF _ pred_subset])
 apply (erule sym [THEN ordertype_eq_imp_ord_iso, THEN exE])
 apply (erule_tac [3] well_ord_iso_predE)
 apply (simp_all add: well_ord_subset [OF _ pred_subset])
 done
 
 (*May rewrite with this -- provided no rules are supplied for proving that
         well_ord(pred(A,x,r), r) *)
 lemma ordertype_pred_unfold:
      "well_ord(A,r)
       \<Longrightarrow> ordertype(A,r) = {ordertype(pred(A,x,r),r). x \<in> A}"
 apply (rule equalityI)
 apply (safe intro!: ordertype_pred_lt [THEN ltD])
 apply (auto simp add: ordertype_def well_ord_is_wf [THEN ordermap_eq_image]
                       ordermap_type [THEN image_fun]
                       ordermap_pred_eq_ordermap pred_subset)
 done
 
 
 subsection\<open>Alternative definition of ordinal\<close>
 
 (*proof by Krzysztof Grabczewski*)
 lemma Ord_is_Ord_alt: "Ord(i) \<Longrightarrow> Ord_alt(i)"
   unfolding Ord_alt_def
 apply (rule conjI)
 apply (erule well_ord_Memrel)
 apply (unfold Ord_def Transset_def pred_def Memrel_def, blast)
 done
 
 (*proof by lcp*)
 lemma Ord_alt_is_Ord:
     "Ord_alt(i) \<Longrightarrow> Ord(i)"
 apply (unfold Ord_alt_def Ord_def Transset_def well_ord_def
                      tot_ord_def part_ord_def trans_on_def)
 apply (simp add: pred_Memrel)
 apply (blast elim!: equalityE)
 done
 
 
 subsection\<open>Ordinal Addition\<close>
 
 subsubsection\<open>Order Type calculations for radd\<close>
 
 text\<open>Addition with 0\<close>
 
 lemma bij_sum_0: "(\<lambda>z\<in>A+0. case(\<lambda>x. x, \<lambda>y. y, z)) \<in> bij(A+0, A)"
 apply (rule_tac d = Inl in lam_bijective, safe)
 apply (simp_all (no_asm_simp))
 done
 
 lemma ordertype_sum_0_eq:
      "well_ord(A,r) \<Longrightarrow> ordertype(A+0, radd(A,r,0,s)) = ordertype(A,r)"
 apply (rule bij_sum_0 [THEN ord_isoI, THEN ordertype_eq])
 prefer 2 apply assumption
 apply force
 done
 
 lemma bij_0_sum: "(\<lambda>z\<in>0+A. case(\<lambda>x. x, \<lambda>y. y, z)) \<in> bij(0+A, A)"
 apply (rule_tac d = Inr in lam_bijective, safe)
 apply (simp_all (no_asm_simp))
 done
 
 lemma ordertype_0_sum_eq:
      "well_ord(A,r) \<Longrightarrow> ordertype(0+A, radd(0,s,A,r)) = ordertype(A,r)"
 apply (rule bij_0_sum [THEN ord_isoI, THEN ordertype_eq])
 prefer 2 apply assumption
 apply force
 done
 
 text\<open>Initial segments of radd.  Statements by Grabczewski\<close>
 
 (*In fact, pred(A+B, Inl(a), radd(A,r,B,s)) = pred(A,a,r)+0 *)
 lemma pred_Inl_bij:
  "a \<in> A \<Longrightarrow> (\<lambda>x\<in>pred(A,a,r). Inl(x))
           \<in> bij(pred(A,a,r), pred(A+B, Inl(a), radd(A,r,B,s)))"
   unfolding pred_def
 apply (rule_tac d = "case (\<lambda>x. x, \<lambda>y. y) " in lam_bijective)
 apply auto
 done
 
 lemma ordertype_pred_Inl_eq:
      "\<lbrakk>a \<in> A;  well_ord(A,r)\<rbrakk>
       \<Longrightarrow> ordertype(pred(A+B, Inl(a), radd(A,r,B,s)), radd(A,r,B,s)) =
           ordertype(pred(A,a,r), r)"
 apply (rule pred_Inl_bij [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
 apply (simp_all add: well_ord_subset [OF _ pred_subset])
 apply (simp add: pred_def)
 done
 
 lemma pred_Inr_bij:
  "b \<in> B \<Longrightarrow>
          id(A+pred(B,b,s))
          \<in> bij(A+pred(B,b,s), pred(A+B, Inr(b), radd(A,r,B,s)))"
-apply (unfold pred_def id_def)
+  unfolding pred_def id_def
 apply (rule_tac d = "\<lambda>z. z" in lam_bijective, auto)
 done
 
 lemma ordertype_pred_Inr_eq:
      "\<lbrakk>b \<in> B;  well_ord(A,r);  well_ord(B,s)\<rbrakk>
       \<Longrightarrow> ordertype(pred(A+B, Inr(b), radd(A,r,B,s)), radd(A,r,B,s)) =
           ordertype(A+pred(B,b,s), radd(A,r,pred(B,b,s),s))"
 apply (rule pred_Inr_bij [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
 prefer 2 apply (force simp add: pred_def id_def, assumption)
 apply (blast intro: well_ord_radd well_ord_subset [OF _ pred_subset])
 done
 
 
 subsubsection\<open>ordify: trivial coercion to an ordinal\<close>
 
 lemma Ord_ordify [iff, TC]: "Ord(ordify(x))"
 by (simp add: ordify_def)
 
 (*Collapsing*)
 lemma ordify_idem [simp]: "ordify(ordify(x)) = ordify(x)"
 by (simp add: ordify_def)
 
 
 subsubsection\<open>Basic laws for ordinal addition\<close>
 
 lemma Ord_raw_oadd: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> Ord(raw_oadd(i,j))"
 by (simp add: raw_oadd_def ordify_def Ord_ordertype well_ord_radd
               well_ord_Memrel)
 
 lemma Ord_oadd [iff,TC]: "Ord(i++j)"
 by (simp add: oadd_def Ord_raw_oadd)
 
 
 text\<open>Ordinal addition with zero\<close>
 
 lemma raw_oadd_0: "Ord(i) \<Longrightarrow> raw_oadd(i,0) = i"
 by (simp add: raw_oadd_def ordify_def ordertype_sum_0_eq
               ordertype_Memrel well_ord_Memrel)
 
 lemma oadd_0 [simp]: "Ord(i) \<Longrightarrow> i++0 = i"
 apply (simp (no_asm_simp) add: oadd_def raw_oadd_0 ordify_def)
 done
 
 lemma raw_oadd_0_left: "Ord(i) \<Longrightarrow> raw_oadd(0,i) = i"
 by (simp add: raw_oadd_def ordify_def ordertype_0_sum_eq ordertype_Memrel
               well_ord_Memrel)
 
 lemma oadd_0_left [simp]: "Ord(i) \<Longrightarrow> 0++i = i"
 by (simp add: oadd_def raw_oadd_0_left ordify_def)
 
 
 lemma oadd_eq_if_raw_oadd:
      "i++j = (if Ord(i) then (if Ord(j) then raw_oadd(i,j) else i)
               else (if Ord(j) then j else 0))"
 by (simp add: oadd_def ordify_def raw_oadd_0_left raw_oadd_0)
 
 lemma raw_oadd_eq_oadd: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> raw_oadd(i,j) = i++j"
 by (simp add: oadd_def ordify_def)
 
 (*** Further properties of ordinal addition.  Statements by Grabczewski,
     proofs by lcp. ***)
 
 (*Surely also provable by transfinite induction on j?*)
 lemma lt_oadd1: "k<i \<Longrightarrow> k < i++j"
 apply (simp add: oadd_def ordify_def lt_Ord2 raw_oadd_0, clarify)
 apply (simp add: raw_oadd_def)
 apply (rule ltE, assumption)
 apply (rule ltI)
 apply (force simp add: ordertype_pred_unfold well_ord_radd well_ord_Memrel
           ordertype_pred_Inl_eq lt_pred_Memrel leI [THEN le_ordertype_Memrel])
 apply (blast intro: Ord_ordertype well_ord_radd well_ord_Memrel)
 done
 
 (*Thus also we obtain the rule  @{term"i++j = k \<Longrightarrow> i \<le> k"} *)
 lemma oadd_le_self: "Ord(i) \<Longrightarrow> i \<le> i++j"
 apply (rule all_lt_imp_le)
 apply (auto simp add: Ord_oadd lt_oadd1)
 done
 
 text\<open>Various other results\<close>
 
 lemma id_ord_iso_Memrel: "A<=B \<Longrightarrow> id(A) \<in> ord_iso(A, Memrel(A), A, Memrel(B))"
 apply (rule id_bij [THEN ord_isoI])
 apply (simp (no_asm_simp))
 apply blast
 done
 
 lemma subset_ord_iso_Memrel:
      "\<lbrakk>f \<in> ord_iso(A,Memrel(B),C,r); A<=B\<rbrakk> \<Longrightarrow> f \<in> ord_iso(A,Memrel(A),C,r)"
 apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN fun_is_rel])
 apply (frule ord_iso_trans [OF id_ord_iso_Memrel], assumption)
 apply (simp add: right_comp_id)
 done
 
 lemma restrict_ord_iso:
      "\<lbrakk>f \<in> ord_iso(i, Memrel(i), Order.pred(A,a,r), r);  a \<in> A; j < i;
        trans[A](r)\<rbrakk>
       \<Longrightarrow> restrict(f,j) \<in> ord_iso(j, Memrel(j), Order.pred(A,f`j,r), r)"
 apply (frule ltD)
 apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type], assumption)
 apply (frule ord_iso_restrict_pred, assumption)
 apply (simp add: pred_iff trans_pred_pred_eq lt_pred_Memrel)
 apply (blast intro!: subset_ord_iso_Memrel le_imp_subset [OF leI])
 done
 
 lemma restrict_ord_iso2:
      "\<lbrakk>f \<in> ord_iso(Order.pred(A,a,r), r, i, Memrel(i));  a \<in> A;
        j < i; trans[A](r)\<rbrakk>
       \<Longrightarrow> converse(restrict(converse(f), j))
           \<in> ord_iso(Order.pred(A, converse(f)`j, r), r, j, Memrel(j))"
 by (blast intro: restrict_ord_iso ord_iso_sym ltI)
 
 lemma ordertype_sum_Memrel:
      "\<lbrakk>well_ord(A,r);  k<j\<rbrakk>
       \<Longrightarrow> ordertype(A+k, radd(A, r, k, Memrel(j))) =
           ordertype(A+k, radd(A, r, k, Memrel(k)))"
 apply (erule ltE)
 apply (rule ord_iso_refl [THEN sum_ord_iso_cong, THEN ordertype_eq])
 apply (erule OrdmemD [THEN id_ord_iso_Memrel, THEN ord_iso_sym])
 apply (simp_all add: well_ord_radd well_ord_Memrel)
 done
 
 lemma oadd_lt_mono2: "k<j \<Longrightarrow> i++k < i++j"
 apply (simp add: oadd_def ordify_def raw_oadd_0_left lt_Ord lt_Ord2, clarify)
 apply (simp add: raw_oadd_def)
 apply (rule ltE, assumption)
 apply (rule ordertype_pred_unfold [THEN equalityD2, THEN subsetD, THEN ltI])
 apply (simp_all add: Ord_ordertype well_ord_radd well_ord_Memrel)
 apply (rule bexI)
 apply (erule_tac [2] InrI)
 apply (simp add: ordertype_pred_Inr_eq well_ord_Memrel lt_pred_Memrel
                  leI [THEN le_ordertype_Memrel] ordertype_sum_Memrel)
 done
 
 lemma oadd_lt_cancel2: "\<lbrakk>i++j < i++k;  Ord(j)\<rbrakk> \<Longrightarrow> j<k"
 apply (simp (asm_lr) add: oadd_eq_if_raw_oadd split: split_if_asm)
  prefer 2
  apply (frule_tac i = i and j = j in oadd_le_self)
  apply (simp (asm_lr) add: oadd_def ordify_def lt_Ord not_lt_iff_le [THEN iff_sym])
 apply (rule Ord_linear_lt, auto)
 apply (simp_all add: raw_oadd_eq_oadd)
 apply (blast dest: oadd_lt_mono2 elim: lt_irrefl lt_asym)+
 done
 
 lemma oadd_lt_iff2: "Ord(j) \<Longrightarrow> i++j < i++k \<longleftrightarrow> j<k"
 by (blast intro!: oadd_lt_mono2 dest!: oadd_lt_cancel2)
 
 lemma oadd_inject: "\<lbrakk>i++j = i++k;  Ord(j); Ord(k)\<rbrakk> \<Longrightarrow> j=k"
 apply (simp add: oadd_eq_if_raw_oadd split: split_if_asm)
 apply (simp add: raw_oadd_eq_oadd)
 apply (rule Ord_linear_lt, auto)
 apply (force dest: oadd_lt_mono2 [of concl: i] simp add: lt_not_refl)+
 done
 
 lemma lt_oadd_disj: "k < i++j \<Longrightarrow> k<i | (\<exists>l\<in>j. k = i++l )"
 apply (simp add: Ord_in_Ord' [of _ j] oadd_eq_if_raw_oadd
             split: split_if_asm)
  prefer 2
  apply (simp add: Ord_in_Ord' [of _ j] lt_def)
 apply (simp add: ordertype_pred_unfold well_ord_radd well_ord_Memrel raw_oadd_def)
 apply (erule ltD [THEN RepFunE])
 apply (force simp add: ordertype_pred_Inl_eq well_ord_Memrel ltI
                        lt_pred_Memrel le_ordertype_Memrel leI
                        ordertype_pred_Inr_eq ordertype_sum_Memrel)
 done
 
 
 subsubsection\<open>Ordinal addition with successor -- via associativity!\<close>
 
 lemma oadd_assoc: "(i++j)++k = i++(j++k)"
 apply (simp add: oadd_eq_if_raw_oadd Ord_raw_oadd raw_oadd_0 raw_oadd_0_left, clarify)
 apply (simp add: raw_oadd_def)
 apply (rule ordertype_eq [THEN trans])
 apply (rule sum_ord_iso_cong [OF ordertype_ord_iso [THEN ord_iso_sym]
                                  ord_iso_refl])
 apply (simp_all add: Ord_ordertype well_ord_radd well_ord_Memrel)
 apply (rule sum_assoc_ord_iso [THEN ordertype_eq, THEN trans])
 apply (rule_tac [2] ordertype_eq)
 apply (rule_tac [2] sum_ord_iso_cong [OF ord_iso_refl ordertype_ord_iso])
 apply (blast intro: Ord_ordertype well_ord_radd well_ord_Memrel)+
 done
 
 lemma oadd_unfold: "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> i++j = i \<union> (\<Union>k\<in>j. {i++k})"
 apply (rule subsetI [THEN equalityI])
 apply (erule ltI [THEN lt_oadd_disj, THEN disjE])
 apply (blast intro: Ord_oadd)
 apply (blast elim!: ltE, blast)
 apply (force intro: lt_oadd1 oadd_lt_mono2 simp add: Ord_mem_iff_lt)
 done
 
 lemma oadd_1: "Ord(i) \<Longrightarrow> i++1 = succ(i)"
 apply (simp (no_asm_simp) add: oadd_unfold Ord_1 oadd_0)
 apply blast
 done
 
 lemma oadd_succ [simp]: "Ord(j) \<Longrightarrow> i++succ(j) = succ(i++j)"
 apply (simp add: oadd_eq_if_raw_oadd, clarify)
 apply (simp add: raw_oadd_eq_oadd)
 apply (simp add: oadd_1 [of j, symmetric] oadd_1 [of "i++j", symmetric]
                  oadd_assoc)
 done
 
 
 text\<open>Ordinal addition with limit ordinals\<close>
 
 lemma oadd_UN:
      "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> Ord(j(x));  a \<in> A\<rbrakk>
       \<Longrightarrow> i ++ (\<Union>x\<in>A. j(x)) = (\<Union>x\<in>A. i++j(x))"
 by (blast intro: ltI Ord_UN Ord_oadd lt_oadd1 [THEN ltD]
                  oadd_lt_mono2 [THEN ltD]
           elim!: ltE dest!: ltI [THEN lt_oadd_disj])
 
 lemma oadd_Limit: "Limit(j) \<Longrightarrow> i++j = (\<Union>k\<in>j. i++k)"
 apply (frule Limit_has_0 [THEN ltD])
 apply (simp add: Limit_is_Ord [THEN Ord_in_Ord] oadd_UN [symmetric]
                  Union_eq_UN [symmetric] Limit_Union_eq)
 done
 
 lemma oadd_eq_0_iff: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> (i ++ j) = 0 \<longleftrightarrow> i=0 \<and> j=0"
 apply (erule trans_induct3 [of j])
 apply (simp_all add: oadd_Limit)
 apply (simp add: Union_empty_iff Limit_def lt_def, blast)
 done
 
 lemma oadd_eq_lt_iff: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> 0 < (i ++ j) \<longleftrightarrow> 0<i | 0<j"
 by (simp add: Ord_0_lt_iff [symmetric] oadd_eq_0_iff)
 
 lemma oadd_LimitI: "\<lbrakk>Ord(i); Limit(j)\<rbrakk> \<Longrightarrow> Limit(i ++ j)"
 apply (simp add: oadd_Limit)
 apply (frule Limit_has_1 [THEN ltD])
 apply (rule increasing_LimitI)
  apply (rule Ord_0_lt)
   apply (blast intro: Ord_in_Ord [OF Limit_is_Ord])
  apply (force simp add: Union_empty_iff oadd_eq_0_iff
                         Limit_is_Ord [of j, THEN Ord_in_Ord], auto)
 apply (rule_tac x="succ(y)" in bexI)
  apply (simp add: ltI Limit_is_Ord [of j, THEN Ord_in_Ord])
 apply (simp add: Limit_def lt_def)
 done
 
 text\<open>Order/monotonicity properties of ordinal addition\<close>
 
 lemma oadd_le_self2: "Ord(i) \<Longrightarrow> i \<le> j++i"
 proof (induct i rule: trans_induct3)
   case 0 thus ?case by (simp add: Ord_0_le)
 next
   case (succ i) thus ?case by (simp add: oadd_succ succ_leI)
 next
   case (limit l)
   hence "l = (\<Union>x\<in>l. x)"
     by (simp add: Union_eq_UN [symmetric] Limit_Union_eq)
   also have "... \<le> (\<Union>x\<in>l. j++x)"
     by (rule le_implies_UN_le_UN) (rule limit.hyps)
   finally have "l \<le> (\<Union>x\<in>l. j++x)" .
   thus ?case using limit.hyps by (simp add: oadd_Limit)
 qed
 
 lemma oadd_le_mono1: "k \<le> j \<Longrightarrow> k++i \<le> j++i"
 apply (frule lt_Ord)
 apply (frule le_Ord2)
 apply (simp add: oadd_eq_if_raw_oadd, clarify)
 apply (simp add: raw_oadd_eq_oadd)
 apply (erule_tac i = i in trans_induct3)
 apply (simp (no_asm_simp))
 apply (simp (no_asm_simp) add: oadd_succ succ_le_iff)
 apply (simp (no_asm_simp) add: oadd_Limit)
 apply (rule le_implies_UN_le_UN, blast)
 done
 
 lemma oadd_lt_mono: "\<lbrakk>i' \<le> i;  j'<j\<rbrakk> \<Longrightarrow> i'++j' < i++j"
 by (blast intro: lt_trans1 oadd_le_mono1 oadd_lt_mono2 Ord_succD elim: ltE)
 
 lemma oadd_le_mono: "\<lbrakk>i' \<le> i;  j' \<le> j\<rbrakk> \<Longrightarrow> i'++j' \<le> i++j"
 by (simp del: oadd_succ add: oadd_succ [symmetric] le_Ord2 oadd_lt_mono)
 
 lemma oadd_le_iff2: "\<lbrakk>Ord(j); Ord(k)\<rbrakk> \<Longrightarrow> i++j \<le> i++k \<longleftrightarrow> j \<le> k"
 by (simp del: oadd_succ add: oadd_lt_iff2 oadd_succ [symmetric] Ord_succ)
 
 lemma oadd_lt_self: "\<lbrakk>Ord(i);  0<j\<rbrakk> \<Longrightarrow> i < i++j"
 apply (rule lt_trans2)
 apply (erule le_refl)
 apply (simp only: lt_Ord2  oadd_1 [of i, symmetric])
 apply (blast intro: succ_leI oadd_le_mono)
 done
 
 text\<open>Every ordinal is exceeded by some limit ordinal.\<close>
 lemma Ord_imp_greater_Limit: "Ord(i) \<Longrightarrow> \<exists>k. i<k \<and> Limit(k)"
 apply (rule_tac x="i ++ nat" in exI)
 apply (blast intro: oadd_LimitI  oadd_lt_self  Limit_nat [THEN Limit_has_0])
 done
 
 lemma Ord2_imp_greater_Limit: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> \<exists>k. i<k \<and> j<k \<and> Limit(k)"
 apply (insert Ord_Un [of i j, THEN Ord_imp_greater_Limit])
 apply (simp add: Un_least_lt_iff)
 done
 
 
 subsection\<open>Ordinal Subtraction\<close>
 
 text\<open>The difference is \<^term>\<open>ordertype(j-i, Memrel(j))\<close>.
     It's probably simpler to define the difference recursively!\<close>
 
 lemma bij_sum_Diff:
      "A<=B \<Longrightarrow> (\<lambda>y\<in>B. if(y \<in> A, Inl(y), Inr(y))) \<in> bij(B, A+(B-A))"
 apply (rule_tac d = "case (\<lambda>x. x, \<lambda>y. y) " in lam_bijective)
 apply (blast intro!: if_type)
 apply (fast intro!: case_type)
 apply (erule_tac [2] sumE)
 apply (simp_all (no_asm_simp))
 done
 
 lemma ordertype_sum_Diff:
      "i \<le> j \<Longrightarrow>
             ordertype(i+(j-i), radd(i,Memrel(j),j-i,Memrel(j))) =
             ordertype(j, Memrel(j))"
 apply (safe dest!: le_subset_iff [THEN iffD1])
 apply (rule bij_sum_Diff [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
 apply (erule_tac [3] well_ord_Memrel, assumption)
 apply (simp (no_asm_simp))
 apply (frule_tac j = y in Ord_in_Ord, assumption)
 apply (frule_tac j = x in Ord_in_Ord, assumption)
 apply (simp (no_asm_simp) add: Ord_mem_iff_lt lt_Ord not_lt_iff_le)
 apply (blast intro: lt_trans2 lt_trans)
 done
 
 lemma Ord_odiff [simp,TC]:
     "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> Ord(i--j)"
   unfolding odiff_def
 apply (blast intro: Ord_ordertype Diff_subset well_ord_subset well_ord_Memrel)
 done
 
 
 lemma raw_oadd_ordertype_Diff:
    "i \<le> j
     \<Longrightarrow> raw_oadd(i,j--i) = ordertype(i+(j-i), radd(i,Memrel(j),j-i,Memrel(j)))"
 apply (simp add: raw_oadd_def odiff_def)
 apply (safe dest!: le_subset_iff [THEN iffD1])
 apply (rule sum_ord_iso_cong [THEN ordertype_eq])
 apply (erule id_ord_iso_Memrel)
 apply (rule ordertype_ord_iso [THEN ord_iso_sym])
 apply (blast intro: well_ord_radd Diff_subset well_ord_subset well_ord_Memrel)+
 done
 
 lemma oadd_odiff_inverse: "i \<le> j \<Longrightarrow> i ++ (j--i) = j"
 by (simp add: lt_Ord le_Ord2 oadd_def ordify_def raw_oadd_ordertype_Diff
               ordertype_sum_Diff ordertype_Memrel lt_Ord2 [THEN Ord_succD])
 
 (*By oadd_inject, the difference between i and j is unique.  Note that we get
   i++j = k  \<Longrightarrow>  j = k--i.  *)
 lemma odiff_oadd_inverse: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> (i++j) -- i = j"
 apply (rule oadd_inject)
 apply (blast intro: oadd_odiff_inverse oadd_le_self)
 apply (blast intro: Ord_ordertype Ord_oadd Ord_odiff)+
 done
 
 lemma odiff_lt_mono2: "\<lbrakk>i<j;  k \<le> i\<rbrakk> \<Longrightarrow> i--k < j--k"
 apply (rule_tac i = k in oadd_lt_cancel2)
 apply (simp add: oadd_odiff_inverse)
 apply (subst oadd_odiff_inverse)
 apply (blast intro: le_trans leI, assumption)
 apply (simp (no_asm_simp) add: lt_Ord le_Ord2)
 done
 
 
 subsection\<open>Ordinal Multiplication\<close>
 
 lemma Ord_omult [simp,TC]:
     "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> Ord(i**j)"
   unfolding omult_def
 apply (blast intro: Ord_ordertype well_ord_rmult well_ord_Memrel)
 done
 
 subsubsection\<open>A useful unfolding law\<close>
 
 lemma pred_Pair_eq:
  "\<lbrakk>a \<in> A;  b \<in> B\<rbrakk> \<Longrightarrow> pred(A*B, \<langle>a,b\<rangle>, rmult(A,r,B,s)) =
                       pred(A,a,r)*B \<union> ({a} * pred(B,b,s))"
 apply (unfold pred_def, blast)
 done
 
 lemma ordertype_pred_Pair_eq:
      "\<lbrakk>a \<in> A;  b \<in> B;  well_ord(A,r);  well_ord(B,s)\<rbrakk> \<Longrightarrow>
          ordertype(pred(A*B, \<langle>a,b\<rangle>, rmult(A,r,B,s)), rmult(A,r,B,s)) =
          ordertype(pred(A,a,r)*B + pred(B,b,s),
                   radd(A*B, rmult(A,r,B,s), B, s))"
 apply (simp (no_asm_simp) add: pred_Pair_eq)
 apply (rule ordertype_eq [symmetric])
 apply (rule prod_sum_singleton_ord_iso)
 apply (simp_all add: pred_subset well_ord_rmult [THEN well_ord_subset])
 apply (blast intro: pred_subset well_ord_rmult [THEN well_ord_subset]
              elim!: predE)
 done
 
 lemma ordertype_pred_Pair_lemma:
     "\<lbrakk>i'<i;  j'<j\<rbrakk>
      \<Longrightarrow> ordertype(pred(i*j, <i',j'>, rmult(i,Memrel(i),j,Memrel(j))),
                    rmult(i,Memrel(i),j,Memrel(j))) =
          raw_oadd (j**i', j')"
-apply (unfold raw_oadd_def omult_def)
+  unfolding raw_oadd_def omult_def
 apply (simp add: ordertype_pred_Pair_eq lt_pred_Memrel ltD lt_Ord2
                  well_ord_Memrel)
 apply (rule trans)
  apply (rule_tac [2] ordertype_ord_iso
                       [THEN sum_ord_iso_cong, THEN ordertype_eq])
   apply (rule_tac [3] ord_iso_refl)
 apply (rule id_bij [THEN ord_isoI, THEN ordertype_eq])
 apply (elim SigmaE sumE ltE ssubst)
 apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                      Ord_ordertype lt_Ord lt_Ord2)
 apply (blast intro: Ord_trans)+
 done
 
 lemma lt_omult:
  "\<lbrakk>Ord(i);  Ord(j);  k<j**i\<rbrakk>
   \<Longrightarrow> \<exists>j' i'. k = j**i' ++ j' \<and> j'<j \<and> i'<i"
   unfolding omult_def
 apply (simp add: ordertype_pred_unfold well_ord_rmult well_ord_Memrel)
 apply (safe elim!: ltE)
 apply (simp add: ordertype_pred_Pair_lemma ltI raw_oadd_eq_oadd
             omult_def [symmetric] Ord_in_Ord' [of _ i] Ord_in_Ord' [of _ j])
 apply (blast intro: ltI)
 done
 
 lemma omult_oadd_lt:
      "\<lbrakk>j'<j;  i'<i\<rbrakk> \<Longrightarrow> j**i' ++ j'  <  j**i"
   unfolding omult_def
 apply (rule ltI)
  prefer 2
  apply (simp add: Ord_ordertype well_ord_rmult well_ord_Memrel lt_Ord2)
 apply (simp add: ordertype_pred_unfold well_ord_rmult well_ord_Memrel lt_Ord2)
 apply (rule bexI [of _ i'])
 apply (rule bexI [of _ j'])
 apply (simp add: ordertype_pred_Pair_lemma ltI omult_def [symmetric])
 apply (simp add: lt_Ord lt_Ord2 raw_oadd_eq_oadd)
 apply (simp_all add: lt_def)
 done
 
 lemma omult_unfold:
      "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> j**i = (\<Union>j'\<in>j. \<Union>i'\<in>i. {j**i' ++ j'})"
 apply (rule subsetI [THEN equalityI])
 apply (rule lt_omult [THEN exE])
 apply (erule_tac [3] ltI)
 apply (simp_all add: Ord_omult)
 apply (blast elim!: ltE)
 apply (blast intro: omult_oadd_lt [THEN ltD] ltI)
 done
 
 subsubsection\<open>Basic laws for ordinal multiplication\<close>
 
 text\<open>Ordinal multiplication by zero\<close>
 
 lemma omult_0 [simp]: "i**0 = 0"
   unfolding omult_def
 apply (simp (no_asm_simp))
 done
 
 lemma omult_0_left [simp]: "0**i = 0"
   unfolding omult_def
 apply (simp (no_asm_simp))
 done
 
 text\<open>Ordinal multiplication by 1\<close>
 
 lemma omult_1 [simp]: "Ord(i) \<Longrightarrow> i**1 = i"
   unfolding omult_def
 apply (rule_tac s1="Memrel(i)"
        in ord_isoI [THEN ordertype_eq, THEN trans])
 apply (rule_tac c = snd and d = "\<lambda>z.\<langle>0,z\<rangle>"  in lam_bijective)
 apply (auto elim!: snd_type well_ord_Memrel ordertype_Memrel)
 done
 
 lemma omult_1_left [simp]: "Ord(i) \<Longrightarrow> 1**i = i"
   unfolding omult_def
 apply (rule_tac s1="Memrel(i)"
        in ord_isoI [THEN ordertype_eq, THEN trans])
 apply (rule_tac c = fst and d = "\<lambda>z.\<langle>z,0\<rangle>" in lam_bijective)
 apply (auto elim!: fst_type well_ord_Memrel ordertype_Memrel)
 done
 
 text\<open>Distributive law for ordinal multiplication and addition\<close>
 
 lemma oadd_omult_distrib:
      "\<lbrakk>Ord(i);  Ord(j);  Ord(k)\<rbrakk> \<Longrightarrow> i**(j++k) = (i**j)++(i**k)"
 apply (simp add: oadd_eq_if_raw_oadd)
 apply (simp add: omult_def raw_oadd_def)
 apply (rule ordertype_eq [THEN trans])
 apply (rule prod_ord_iso_cong [OF ordertype_ord_iso [THEN ord_iso_sym]
                                   ord_iso_refl])
 apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                      Ord_ordertype)
 apply (rule sum_prod_distrib_ord_iso [THEN ordertype_eq, THEN trans])
 apply (rule_tac [2] ordertype_eq)
 apply (rule_tac [2] sum_ord_iso_cong [OF ordertype_ord_iso ordertype_ord_iso])
 apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                      Ord_ordertype)
 done
 
 lemma omult_succ: "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> i**succ(j) = (i**j)++i"
 by (simp del: oadd_succ add: oadd_1 [of j, symmetric] oadd_omult_distrib)
 
 text\<open>Associative law\<close>
 
 lemma omult_assoc:
     "\<lbrakk>Ord(i);  Ord(j);  Ord(k)\<rbrakk> \<Longrightarrow> (i**j)**k = i**(j**k)"
   unfolding omult_def
 apply (rule ordertype_eq [THEN trans])
 apply (rule prod_ord_iso_cong [OF ord_iso_refl
                                   ordertype_ord_iso [THEN ord_iso_sym]])
 apply (blast intro: well_ord_rmult well_ord_Memrel)+
 apply (rule prod_assoc_ord_iso
              [THEN ord_iso_sym, THEN ordertype_eq, THEN trans])
 apply (rule_tac [2] ordertype_eq)
 apply (rule_tac [2] prod_ord_iso_cong [OF ordertype_ord_iso ord_iso_refl])
 apply (blast intro: well_ord_rmult well_ord_Memrel Ord_ordertype)+
 done
 
 
 text\<open>Ordinal multiplication with limit ordinals\<close>
 
 lemma omult_UN:
      "\<lbrakk>Ord(i);  \<And>x. x \<in> A \<Longrightarrow> Ord(j(x))\<rbrakk>
       \<Longrightarrow> i ** (\<Union>x\<in>A. j(x)) = (\<Union>x\<in>A. i**j(x))"
 by (simp (no_asm_simp) add: Ord_UN omult_unfold, blast)
 
 lemma omult_Limit: "\<lbrakk>Ord(i);  Limit(j)\<rbrakk> \<Longrightarrow> i**j = (\<Union>k\<in>j. i**k)"
 by (simp add: Limit_is_Ord [THEN Ord_in_Ord] omult_UN [symmetric]
               Union_eq_UN [symmetric] Limit_Union_eq)
 
 
 subsubsection\<open>Ordering/monotonicity properties of ordinal multiplication\<close>
 
 (*As a special case we have "\<lbrakk>0<i;  0<j\<rbrakk> \<Longrightarrow> 0 < i**j" *)
 lemma lt_omult1: "\<lbrakk>k<i;  0<j\<rbrakk> \<Longrightarrow> k < i**j"
 apply (safe elim!: ltE intro!: ltI Ord_omult)
 apply (force simp add: omult_unfold)
 done
 
 lemma omult_le_self: "\<lbrakk>Ord(i);  0<j\<rbrakk> \<Longrightarrow> i \<le> i**j"
 by (blast intro: all_lt_imp_le Ord_omult lt_omult1 lt_Ord2)
 
 lemma omult_le_mono1:
   assumes kj: "k \<le> j" and i: "Ord(i)" shows "k**i \<le> j**i"
 proof -
   have o: "Ord(k)" "Ord(j)" by (rule lt_Ord [OF kj] le_Ord2 [OF kj])+
   show ?thesis using i
   proof (induct i rule: trans_induct3)
     case 0 thus ?case
       by simp
   next
     case (succ i) thus ?case
       by (simp add: o kj omult_succ oadd_le_mono)
   next
     case (limit l)
     thus ?case
       by (auto simp add: o kj omult_Limit le_implies_UN_le_UN)
   qed
 qed
 
 lemma omult_lt_mono2: "\<lbrakk>k<j;  0<i\<rbrakk> \<Longrightarrow> i**k < i**j"
 apply (rule ltI)
 apply (simp (no_asm_simp) add: omult_unfold lt_Ord2)
 apply (safe elim!: ltE intro!: Ord_omult)
 apply (force simp add: Ord_omult)
 done
 
 lemma omult_le_mono2: "\<lbrakk>k \<le> j;  Ord(i)\<rbrakk> \<Longrightarrow> i**k \<le> i**j"
 apply (rule subset_imp_le)
 apply (safe elim!: ltE dest!: Ord_succD intro!: Ord_omult)
 apply (simp add: omult_unfold)
 apply (blast intro: Ord_trans)
 done
 
 lemma omult_le_mono: "\<lbrakk>i' \<le> i;  j' \<le> j\<rbrakk> \<Longrightarrow> i'**j' \<le> i**j"
 by (blast intro: le_trans omult_le_mono1 omult_le_mono2 Ord_succD elim: ltE)
 
 lemma omult_lt_mono: "\<lbrakk>i' \<le> i;  j'<j;  0<i\<rbrakk> \<Longrightarrow> i'**j' < i**j"
 by (blast intro: lt_trans1 omult_le_mono1 omult_lt_mono2 Ord_succD elim: ltE)
 
 lemma omult_le_self2:
   assumes i: "Ord(i)" and j: "0<j" shows "i \<le> j**i"
 proof -
   have oj: "Ord(j)" by (rule lt_Ord2 [OF j])
   show ?thesis using i
   proof (induct i rule: trans_induct3)
     case 0 thus ?case
       by simp
   next
     case (succ i)
     have "j ** i ++ 0 < j ** i ++ j"
       by (rule oadd_lt_mono2 [OF j])
     with succ.hyps show ?case
       by (simp add: oj j omult_succ ) (rule lt_trans1)
   next
     case (limit l)
     hence "l = (\<Union>x\<in>l. x)"
       by (simp add: Union_eq_UN [symmetric] Limit_Union_eq)
     also have "... \<le> (\<Union>x\<in>l. j**x)"
       by (rule le_implies_UN_le_UN) (rule limit.hyps)
     finally have "l \<le> (\<Union>x\<in>l. j**x)" .
     thus ?case using limit.hyps by (simp add: oj omult_Limit)
   qed
 qed
 
 
 text\<open>Further properties of ordinal multiplication\<close>
 
 lemma omult_inject: "\<lbrakk>i**j = i**k;  0<i;  Ord(j);  Ord(k)\<rbrakk> \<Longrightarrow> j=k"
 apply (rule Ord_linear_lt)
 prefer 4 apply assumption
 apply auto
 apply (force dest: omult_lt_mono2 simp add: lt_not_refl)+
 done
 
 subsection\<open>The Relation \<^term>\<open>Lt\<close>\<close>
 
 lemma wf_Lt: "wf(Lt)"
 apply (rule wf_subset)
 apply (rule wf_Memrel)
 apply (auto simp add: Lt_def Memrel_def lt_def)
 done
 
 lemma irrefl_Lt: "irrefl(A,Lt)"
 by (auto simp add: Lt_def irrefl_def)
 
 lemma trans_Lt: "trans[A](Lt)"
 apply (simp add: Lt_def trans_on_def)
 apply (blast intro: lt_trans)
 done
 
 lemma part_ord_Lt: "part_ord(A,Lt)"
 by (simp add: part_ord_def irrefl_Lt trans_Lt)
 
 lemma linear_Lt: "linear(nat,Lt)"
 apply (auto dest!: not_lt_imp_le simp add: Lt_def linear_def le_iff)
 apply (drule lt_asym, auto)
 done
 
 lemma tot_ord_Lt: "tot_ord(nat,Lt)"
 by (simp add: tot_ord_def linear_Lt part_ord_Lt)
 
 lemma well_ord_Lt: "well_ord(nat,Lt)"
 by (simp add: well_ord_def wf_Lt wf_imp_wf_on tot_ord_Lt)
 
 end
diff --git a/src/ZF/Perm.thy b/src/ZF/Perm.thy
--- a/src/ZF/Perm.thy
+++ b/src/ZF/Perm.thy
@@ -1,554 +1,554 @@
 (*  Title:      ZF/Perm.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1991  University of Cambridge
 
 The theory underlying permutation groups
   -- Composition of relations, the identity relation
   -- Injections, surjections, bijections
   -- Lemmas for the Schroeder-Bernstein Theorem
 *)
 
 section\<open>Injections, Surjections, Bijections, Composition\<close>
 
 theory Perm imports func begin
 
 definition
   (*composition of relations and functions; NOT Suppes's relative product*)
   comp     :: "[i,i]\<Rightarrow>i"      (infixr \<open>O\<close> 60)  where
     "r O s \<equiv> {xz \<in> domain(s)*range(r) .
                \<exists>x y z. xz=\<langle>x,z\<rangle> \<and> \<langle>x,y\<rangle>:s \<and> \<langle>y,z\<rangle>:r}"
 
 definition
   (*the identity function for A*)
   id    :: "i\<Rightarrow>i"  where
     "id(A) \<equiv> (\<lambda>x\<in>A. x)"
 
 definition
   (*one-to-one functions from A to B*)
   inj   :: "[i,i]\<Rightarrow>i"  where
     "inj(A,B) \<equiv> { f \<in> A->B. \<forall>w\<in>A. \<forall>x\<in>A. f`w=f`x \<longrightarrow> w=x}"
 
 definition
   (*onto functions from A to B*)
   surj  :: "[i,i]\<Rightarrow>i"  where
     "surj(A,B) \<equiv> { f \<in> A->B . \<forall>y\<in>B. \<exists>x\<in>A. f`x=y}"
 
 definition
   (*one-to-one and onto functions*)
   bij   :: "[i,i]\<Rightarrow>i"  where
     "bij(A,B) \<equiv> inj(A,B) \<inter> surj(A,B)"
 
 
 subsection\<open>Surjective Function Space\<close>
 
 lemma surj_is_fun: "f \<in> surj(A,B) \<Longrightarrow> f \<in> A->B"
   unfolding surj_def
 apply (erule CollectD1)
 done
 
 lemma fun_is_surj: "f \<in> Pi(A,B) \<Longrightarrow> f \<in> surj(A,range(f))"
   unfolding surj_def
 apply (blast intro: apply_equality range_of_fun domain_type)
 done
 
 lemma surj_range: "f \<in> surj(A,B) \<Longrightarrow> range(f)=B"
   unfolding surj_def
 apply (best intro: apply_Pair elim: range_type)
 done
 
 text\<open>A function with a right inverse is a surjection\<close>
 
 lemma f_imp_surjective:
     "\<lbrakk>f \<in> A->B;  \<And>y. y \<in> B \<Longrightarrow> d(y): A;  \<And>y. y \<in> B \<Longrightarrow> f`d(y) = y\<rbrakk>
      \<Longrightarrow> f \<in> surj(A,B)"
   by (simp add: surj_def, blast)
 
 lemma lam_surjective:
     "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> c(x): B;
         \<And>y. y \<in> B \<Longrightarrow> d(y): A;
         \<And>y. y \<in> B \<Longrightarrow> c(d(y)) = y
 \<rbrakk> \<Longrightarrow> (\<lambda>x\<in>A. c(x)) \<in> surj(A,B)"
 apply (rule_tac d = d in f_imp_surjective)
 apply (simp_all add: lam_type)
 done
 
 text\<open>Cantor's theorem revisited\<close>
 lemma cantor_surj: "f \<notin> surj(A,Pow(A))"
 apply (unfold surj_def, safe)
 apply (cut_tac cantor)
 apply (best del: subsetI)
 done
 
 
 subsection\<open>Injective Function Space\<close>
 
 lemma inj_is_fun: "f \<in> inj(A,B) \<Longrightarrow> f \<in> A->B"
   unfolding inj_def
 apply (erule CollectD1)
 done
 
 text\<open>Good for dealing with sets of pairs, but a bit ugly in use [used in AC]\<close>
 lemma inj_equality:
     "\<lbrakk>\<langle>a,b\<rangle>:f;  \<langle>c,b\<rangle>:f;  f \<in> inj(A,B)\<rbrakk> \<Longrightarrow> a=c"
   unfolding inj_def
 apply (blast dest: Pair_mem_PiD)
 done
 
 lemma inj_apply_equality: "\<lbrakk>f \<in> inj(A,B);  f`a=f`b;  a \<in> A;  b \<in> A\<rbrakk> \<Longrightarrow> a=b"
 by (unfold inj_def, blast)
 
 text\<open>A function with a left inverse is an injection\<close>
 
 lemma f_imp_injective: "\<lbrakk>f \<in> A->B;  \<forall>x\<in>A. d(f`x)=x\<rbrakk> \<Longrightarrow> f \<in> inj(A,B)"
 apply (simp (no_asm_simp) add: inj_def)
 apply (blast intro: subst_context [THEN box_equals])
 done
 
 lemma lam_injective:
     "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> c(x): B;
         \<And>x. x \<in> A \<Longrightarrow> d(c(x)) = x\<rbrakk>
      \<Longrightarrow> (\<lambda>x\<in>A. c(x)) \<in> inj(A,B)"
 apply (rule_tac d = d in f_imp_injective)
 apply (simp_all add: lam_type)
 done
 
 subsection\<open>Bijections\<close>
 
 lemma bij_is_inj: "f \<in> bij(A,B) \<Longrightarrow> f \<in> inj(A,B)"
   unfolding bij_def
 apply (erule IntD1)
 done
 
 lemma bij_is_surj: "f \<in> bij(A,B) \<Longrightarrow> f \<in> surj(A,B)"
   unfolding bij_def
 apply (erule IntD2)
 done
 
 lemma bij_is_fun: "f \<in> bij(A,B) \<Longrightarrow> f \<in> A->B"
   by (rule bij_is_inj [THEN inj_is_fun])
 
 lemma lam_bijective:
     "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> c(x): B;
         \<And>y. y \<in> B \<Longrightarrow> d(y): A;
         \<And>x. x \<in> A \<Longrightarrow> d(c(x)) = x;
         \<And>y. y \<in> B \<Longrightarrow> c(d(y)) = y
 \<rbrakk> \<Longrightarrow> (\<lambda>x\<in>A. c(x)) \<in> bij(A,B)"
   unfolding bij_def
 apply (blast intro!: lam_injective lam_surjective)
 done
 
 lemma RepFun_bijective: "(\<forall>y\<in>x. \<exists>!y'. f(y') = f(y))
       \<Longrightarrow> (\<lambda>z\<in>{f(y). y \<in> x}. THE y. f(y) = z) \<in> bij({f(y). y \<in> x}, x)"
 apply (rule_tac d = f in lam_bijective)
 apply (auto simp add: the_equality2)
 done
 
 
 subsection\<open>Identity Function\<close>
 
 lemma idI [intro!]: "a \<in> A \<Longrightarrow> \<langle>a,a\<rangle> \<in> id(A)"
   unfolding id_def
 apply (erule lamI)
 done
 
 lemma idE [elim!]: "\<lbrakk>p \<in> id(A);  \<And>x.\<lbrakk>x \<in> A; p=\<langle>x,x\<rangle>\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow>  P"
 by (simp add: id_def lam_def, blast)
 
 lemma id_type: "id(A) \<in> A->A"
   unfolding id_def
 apply (rule lam_type, assumption)
 done
 
 lemma id_conv [simp]: "x \<in> A \<Longrightarrow> id(A)`x = x"
   unfolding id_def
 apply (simp (no_asm_simp))
 done
 
 lemma id_mono: "A<=B \<Longrightarrow> id(A) \<subseteq> id(B)"
   unfolding id_def
 apply (erule lam_mono)
 done
 
 lemma id_subset_inj: "A<=B \<Longrightarrow> id(A): inj(A,B)"
 apply (simp add: inj_def id_def)
 apply (blast intro: lam_type)
 done
 
 lemmas id_inj = subset_refl [THEN id_subset_inj]
 
 lemma id_surj: "id(A): surj(A,A)"
-apply (unfold id_def surj_def)
+  unfolding id_def surj_def
 apply (simp (no_asm_simp))
 done
 
 lemma id_bij: "id(A): bij(A,A)"
   unfolding bij_def
 apply (blast intro: id_inj id_surj)
 done
 
 lemma subset_iff_id: "A \<subseteq> B \<longleftrightarrow> id(A) \<in> A->B"
   unfolding id_def
 apply (force intro!: lam_type dest: apply_type)
 done
 
 text\<open>\<^term>\<open>id\<close> as the identity relation\<close>
 lemma id_iff [simp]: "\<langle>x,y\<rangle> \<in> id(A) \<longleftrightarrow> x=y \<and> y \<in> A"
 by auto
 
 
 subsection\<open>Converse of a Function\<close>
 
 lemma inj_converse_fun: "f \<in> inj(A,B) \<Longrightarrow> converse(f) \<in> range(f)->A"
   unfolding inj_def
 apply (simp (no_asm_simp) add: Pi_iff function_def)
 apply (erule CollectE)
 apply (simp (no_asm_simp) add: apply_iff)
 apply (blast dest: fun_is_rel)
 done
 
 text\<open>Equations for converse(f)\<close>
 
 text\<open>The premises are equivalent to saying that f is injective...\<close>
 lemma left_inverse_lemma:
      "\<lbrakk>f \<in> A->B;  converse(f): C->A;  a \<in> A\<rbrakk> \<Longrightarrow> converse(f)`(f`a) = a"
 by (blast intro: apply_Pair apply_equality converseI)
 
 lemma left_inverse [simp]: "\<lbrakk>f \<in> inj(A,B);  a \<in> A\<rbrakk> \<Longrightarrow> converse(f)`(f`a) = a"
 by (blast intro: left_inverse_lemma inj_converse_fun inj_is_fun)
 
 lemma left_inverse_eq:
      "\<lbrakk>f \<in> inj(A,B); f ` x = y; x \<in> A\<rbrakk> \<Longrightarrow> converse(f) ` y = x"
 by auto
 
 lemmas left_inverse_bij = bij_is_inj [THEN left_inverse]
 
 lemma right_inverse_lemma:
      "\<lbrakk>f \<in> A->B;  converse(f): C->A;  b \<in> C\<rbrakk> \<Longrightarrow> f`(converse(f)`b) = b"
 by (rule apply_Pair [THEN converseD [THEN apply_equality]], auto)
 
 (*Should the premises be f \<in> surj(A,B), b \<in> B for symmetry with left_inverse?
   No: they would not imply that converse(f) was a function! *)
 lemma right_inverse [simp]:
      "\<lbrakk>f \<in> inj(A,B);  b \<in> range(f)\<rbrakk> \<Longrightarrow> f`(converse(f)`b) = b"
 by (blast intro: right_inverse_lemma inj_converse_fun inj_is_fun)
 
 lemma right_inverse_bij: "\<lbrakk>f \<in> bij(A,B);  b \<in> B\<rbrakk> \<Longrightarrow> f`(converse(f)`b) = b"
 by (force simp add: bij_def surj_range)
 
 subsection\<open>Converses of Injections, Surjections, Bijections\<close>
 
 lemma inj_converse_inj: "f \<in> inj(A,B) \<Longrightarrow> converse(f): inj(range(f), A)"
 apply (rule f_imp_injective)
 apply (erule inj_converse_fun, clarify)
 apply (rule right_inverse)
  apply assumption
 apply blast
 done
 
 lemma inj_converse_surj: "f \<in> inj(A,B) \<Longrightarrow> converse(f): surj(range(f), A)"
 by (blast intro: f_imp_surjective inj_converse_fun left_inverse inj_is_fun
                  range_of_fun [THEN apply_type])
 
 text\<open>Adding this as an intro! rule seems to cause looping\<close>
 lemma bij_converse_bij [TC]: "f \<in> bij(A,B) \<Longrightarrow> converse(f): bij(B,A)"
   unfolding bij_def
 apply (fast elim: surj_range [THEN subst] inj_converse_inj inj_converse_surj)
 done
 
 
 
 subsection\<open>Composition of Two Relations\<close>
 
 text\<open>The inductive definition package could derive these theorems for \<^term>\<open>r O s\<close>\<close>
 
 lemma compI [intro]: "\<lbrakk>\<langle>a,b\<rangle>:s; \<langle>b,c\<rangle>:r\<rbrakk> \<Longrightarrow> \<langle>a,c\<rangle> \<in> r O s"
 by (unfold comp_def, blast)
 
 lemma compE [elim!]:
     "\<lbrakk>xz \<in> r O s;
         \<And>x y z. \<lbrakk>xz=\<langle>x,z\<rangle>;  \<langle>x,y\<rangle>:s;  \<langle>y,z\<rangle>:r\<rbrakk> \<Longrightarrow> P\<rbrakk>
      \<Longrightarrow> P"
 by (unfold comp_def, blast)
 
 lemma compEpair:
     "\<lbrakk>\<langle>a,c\<rangle> \<in> r O s;
         \<And>y. \<lbrakk>\<langle>a,y\<rangle>:s;  \<langle>y,c\<rangle>:r\<rbrakk> \<Longrightarrow> P\<rbrakk>
      \<Longrightarrow> P"
 by (erule compE, simp)
 
 lemma converse_comp: "converse(R O S) = converse(S) O converse(R)"
 by blast
 
 
 subsection\<open>Domain and Range -- see Suppes, Section 3.1\<close>
 
 text\<open>Boyer et al., Set Theory in First-Order Logic, JAR 2 (1986), 287-327\<close>
 lemma range_comp: "range(r O s) \<subseteq> range(r)"
 by blast
 
 lemma range_comp_eq: "domain(r) \<subseteq> range(s) \<Longrightarrow> range(r O s) = range(r)"
 by (rule range_comp [THEN equalityI], blast)
 
 lemma domain_comp: "domain(r O s) \<subseteq> domain(s)"
 by blast
 
 lemma domain_comp_eq: "range(s) \<subseteq> domain(r) \<Longrightarrow> domain(r O s) = domain(s)"
 by (rule domain_comp [THEN equalityI], blast)
 
 lemma image_comp: "(r O s)``A = r``(s``A)"
 by blast
 
 lemma inj_inj_range: "f \<in> inj(A,B) \<Longrightarrow> f \<in> inj(A,range(f))"
   by (auto simp add: inj_def Pi_iff function_def)
 
 lemma inj_bij_range: "f \<in> inj(A,B) \<Longrightarrow> f \<in> bij(A,range(f))"
   by (auto simp add: bij_def intro: inj_inj_range inj_is_fun fun_is_surj)
 
 
 subsection\<open>Other Results\<close>
 
 lemma comp_mono: "\<lbrakk>r'<=r; s'<=s\<rbrakk> \<Longrightarrow> (r' O s') \<subseteq> (r O s)"
 by blast
 
 text\<open>composition preserves relations\<close>
 lemma comp_rel: "\<lbrakk>s<=A*B;  r<=B*C\<rbrakk> \<Longrightarrow> (r O s) \<subseteq> A*C"
 by blast
 
 text\<open>associative law for composition\<close>
 lemma comp_assoc: "(r O s) O t = r O (s O t)"
 by blast
 
 (*left identity of composition; provable inclusions are
         id(A) O r \<subseteq> r
   and   \<lbrakk>r<=A*B; B<=C\<rbrakk> \<Longrightarrow> r \<subseteq> id(C) O r *)
 lemma left_comp_id: "r<=A*B \<Longrightarrow> id(B) O r = r"
 by blast
 
 (*right identity of composition; provable inclusions are
         r O id(A) \<subseteq> r
   and   \<lbrakk>r<=A*B; A<=C\<rbrakk> \<Longrightarrow> r \<subseteq> r O id(C) *)
 lemma right_comp_id: "r<=A*B \<Longrightarrow> r O id(A) = r"
 by blast
 
 
 subsection\<open>Composition Preserves Functions, Injections, and Surjections\<close>
 
 lemma comp_function: "\<lbrakk>function(g);  function(f)\<rbrakk> \<Longrightarrow> function(f O g)"
 by (unfold function_def, blast)
 
 text\<open>Don't think the premises can be weakened much\<close>
 lemma comp_fun: "\<lbrakk>g \<in> A->B;  f \<in> B->C\<rbrakk> \<Longrightarrow> (f O g) \<in> A->C"
 apply (auto simp add: Pi_def comp_function Pow_iff comp_rel)
 apply (subst range_rel_subset [THEN domain_comp_eq], auto)
 done
 
 (*Thanks to the new definition of "apply", the premise f \<in> B->C is gone!*)
 lemma comp_fun_apply [simp]:
      "\<lbrakk>g \<in> A->B;  a \<in> A\<rbrakk> \<Longrightarrow> (f O g)`a = f`(g`a)"
 apply (frule apply_Pair, assumption)
 apply (simp add: apply_def image_comp)
 apply (blast dest: apply_equality)
 done
 
 text\<open>Simplifies compositions of lambda-abstractions\<close>
 lemma comp_lam:
     "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> b(x): B\<rbrakk>
      \<Longrightarrow> (\<lambda>y\<in>B. c(y)) O (\<lambda>x\<in>A. b(x)) = (\<lambda>x\<in>A. c(b(x)))"
 apply (subgoal_tac "(\<lambda>x\<in>A. b(x)) \<in> A -> B")
  apply (rule fun_extension)
    apply (blast intro: comp_fun lam_funtype)
   apply (rule lam_funtype)
  apply simp
 apply (simp add: lam_type)
 done
 
 lemma comp_inj:
      "\<lbrakk>g \<in> inj(A,B);  f \<in> inj(B,C)\<rbrakk> \<Longrightarrow> (f O g) \<in> inj(A,C)"
 apply (frule inj_is_fun [of g])
 apply (frule inj_is_fun [of f])
 apply (rule_tac d = "\<lambda>y. converse (g) ` (converse (f) ` y)" in f_imp_injective)
  apply (blast intro: comp_fun, simp)
 done
 
 lemma comp_surj:
     "\<lbrakk>g \<in> surj(A,B);  f \<in> surj(B,C)\<rbrakk> \<Longrightarrow> (f O g) \<in> surj(A,C)"
   unfolding surj_def
 apply (blast intro!: comp_fun comp_fun_apply)
 done
 
 lemma comp_bij:
     "\<lbrakk>g \<in> bij(A,B);  f \<in> bij(B,C)\<rbrakk> \<Longrightarrow> (f O g) \<in> bij(A,C)"
   unfolding bij_def
 apply (blast intro: comp_inj comp_surj)
 done
 
 
 subsection\<open>Dual Properties of \<^term>\<open>inj\<close> and \<^term>\<open>surj\<close>\<close>
 
 text\<open>Useful for proofs from
     D Pastre.  Automatic theorem proving in set theory.
     Artificial Intelligence, 10:1--27, 1978.\<close>
 
 lemma comp_mem_injD1:
     "\<lbrakk>(f O g): inj(A,C);  g \<in> A->B;  f \<in> B->C\<rbrakk> \<Longrightarrow> g \<in> inj(A,B)"
 by (unfold inj_def, force)
 
 lemma comp_mem_injD2:
     "\<lbrakk>(f O g): inj(A,C);  g \<in> surj(A,B);  f \<in> B->C\<rbrakk> \<Longrightarrow> f \<in> inj(B,C)"
 apply (unfold inj_def surj_def, safe)
 apply (rule_tac x1 = x in bspec [THEN bexE])
 apply (erule_tac [3] x1 = w in bspec [THEN bexE], assumption+, safe)
 apply (rule_tac t = "(`) (g) " in subst_context)
 apply (erule asm_rl bspec [THEN bspec, THEN mp])+
 apply (simp (no_asm_simp))
 done
 
 lemma comp_mem_surjD1:
     "\<lbrakk>(f O g): surj(A,C);  g \<in> A->B;  f \<in> B->C\<rbrakk> \<Longrightarrow> f \<in> surj(B,C)"
   unfolding surj_def
 apply (blast intro!: comp_fun_apply [symmetric] apply_funtype)
 done
 
 
 lemma comp_mem_surjD2:
     "\<lbrakk>(f O g): surj(A,C);  g \<in> A->B;  f \<in> inj(B,C)\<rbrakk> \<Longrightarrow> g \<in> surj(A,B)"
 apply (unfold inj_def surj_def, safe)
 apply (drule_tac x = "f`y" in bspec, auto)
 apply (blast intro: apply_funtype)
 done
 
 subsubsection\<open>Inverses of Composition\<close>
 
 text\<open>left inverse of composition; one inclusion is
         \<^term>\<open>f \<in> A->B \<Longrightarrow> id(A) \<subseteq> converse(f) O f\<close>\<close>
 lemma left_comp_inverse: "f \<in> inj(A,B) \<Longrightarrow> converse(f) O f = id(A)"
 apply (unfold inj_def, clarify)
 apply (rule equalityI)
  apply (auto simp add: apply_iff, blast)
 done
 
 text\<open>right inverse of composition; one inclusion is
                 \<^term>\<open>f \<in> A->B \<Longrightarrow> f O converse(f) \<subseteq> id(B)\<close>\<close>
 lemma right_comp_inverse:
     "f \<in> surj(A,B) \<Longrightarrow> f O converse(f) = id(B)"
 apply (simp add: surj_def, clarify)
 apply (rule equalityI)
 apply (best elim: domain_type range_type dest: apply_equality2)
 apply (blast intro: apply_Pair)
 done
 
 
 subsubsection\<open>Proving that a Function is a Bijection\<close>
 
 lemma comp_eq_id_iff:
     "\<lbrakk>f \<in> A->B;  g \<in> B->A\<rbrakk> \<Longrightarrow> f O g = id(B) \<longleftrightarrow> (\<forall>y\<in>B. f`(g`y)=y)"
 apply (unfold id_def, safe)
  apply (drule_tac t = "\<lambda>h. h`y " in subst_context)
  apply simp
 apply (rule fun_extension)
   apply (blast intro: comp_fun lam_type)
  apply auto
 done
 
 lemma fg_imp_bijective:
     "\<lbrakk>f \<in> A->B;  g \<in> B->A;  f O g = id(B);  g O f = id(A)\<rbrakk> \<Longrightarrow> f \<in> bij(A,B)"
   unfolding bij_def
 apply (simp add: comp_eq_id_iff)
 apply (blast intro: f_imp_injective f_imp_surjective apply_funtype)
 done
 
 lemma nilpotent_imp_bijective: "\<lbrakk>f \<in> A->A;  f O f = id(A)\<rbrakk> \<Longrightarrow> f \<in> bij(A,A)"
 by (blast intro: fg_imp_bijective)
 
 lemma invertible_imp_bijective:
      "\<lbrakk>converse(f): B->A;  f \<in> A->B\<rbrakk> \<Longrightarrow> f \<in> bij(A,B)"
 by (simp add: fg_imp_bijective comp_eq_id_iff
               left_inverse_lemma right_inverse_lemma)
 
 subsubsection\<open>Unions of Functions\<close>
 
 text\<open>See similar theorems in func.thy\<close>
 
 text\<open>Theorem by KG, proof by LCP\<close>
 lemma inj_disjoint_Un:
      "\<lbrakk>f \<in> inj(A,B);  g \<in> inj(C,D);  B \<inter> D = 0\<rbrakk>
       \<Longrightarrow> (\<lambda>a\<in>A \<union> C. if a \<in> A then f`a else g`a) \<in> inj(A \<union> C, B \<union> D)"
 apply (rule_tac d = "\<lambda>z. if z \<in> B then converse (f) `z else converse (g) `z"
        in lam_injective)
 apply (auto simp add: inj_is_fun [THEN apply_type])
 done
 
 lemma surj_disjoint_Un:
     "\<lbrakk>f \<in> surj(A,B);  g \<in> surj(C,D);  A \<inter> C = 0\<rbrakk>
      \<Longrightarrow> (f \<union> g) \<in> surj(A \<union> C, B \<union> D)"
 apply (simp add: surj_def fun_disjoint_Un)
 apply (blast dest!: domain_of_fun
              intro!: fun_disjoint_apply1 fun_disjoint_apply2)
 done
 
 text\<open>A simple, high-level proof; the version for injections follows from it,
   using  \<^term>\<open>f \<in> inj(A,B) \<longleftrightarrow> f \<in> bij(A,range(f))\<close>\<close>
 lemma bij_disjoint_Un:
      "\<lbrakk>f \<in> bij(A,B);  g \<in> bij(C,D);  A \<inter> C = 0;  B \<inter> D = 0\<rbrakk>
       \<Longrightarrow> (f \<union> g) \<in> bij(A \<union> C, B \<union> D)"
 apply (rule invertible_imp_bijective)
 apply (subst converse_Un)
 apply (auto intro: fun_disjoint_Un bij_is_fun bij_converse_bij)
 done
 
 
 subsubsection\<open>Restrictions as Surjections and Bijections\<close>
 
 lemma surj_image:
     "f \<in> Pi(A,B) \<Longrightarrow> f \<in> surj(A, f``A)"
 apply (simp add: surj_def)
 apply (blast intro: apply_equality apply_Pair Pi_type)
 done
 
 lemma surj_image_eq: "f \<in> surj(A, B) \<Longrightarrow> f``A = B"
   by (auto simp add: surj_def image_fun) (blast dest: apply_type) 
 
 lemma restrict_image [simp]: "restrict(f,A) `` B = f `` (A \<inter> B)"
 by (auto simp add: restrict_def)
 
 lemma restrict_inj:
     "\<lbrakk>f \<in> inj(A,B);  C<=A\<rbrakk> \<Longrightarrow> restrict(f,C): inj(C,B)"
   unfolding inj_def
 apply (safe elim!: restrict_type2, auto)
 done
 
 lemma restrict_surj: "\<lbrakk>f \<in> Pi(A,B);  C<=A\<rbrakk> \<Longrightarrow> restrict(f,C): surj(C, f``C)"
 apply (insert restrict_type2 [THEN surj_image])
 apply (simp add: restrict_image)
 done
 
 lemma restrict_bij:
     "\<lbrakk>f \<in> inj(A,B);  C<=A\<rbrakk> \<Longrightarrow> restrict(f,C): bij(C, f``C)"
 apply (simp add: inj_def bij_def)
 apply (blast intro: restrict_surj surj_is_fun)
 done
 
 
 subsubsection\<open>Lemmas for Ramsey's Theorem\<close>
 
 lemma inj_weaken_type: "\<lbrakk>f \<in> inj(A,B);  B<=D\<rbrakk> \<Longrightarrow> f \<in> inj(A,D)"
   unfolding inj_def
 apply (blast intro: fun_weaken_type)
 done
 
 lemma inj_succ_restrict:
      "\<lbrakk>f \<in> inj(succ(m), A)\<rbrakk> \<Longrightarrow> restrict(f,m) \<in> inj(m, A-{f`m})"
 apply (rule restrict_bij [THEN bij_is_inj, THEN inj_weaken_type], assumption, blast)
   unfolding inj_def
 apply (fast elim: range_type mem_irrefl dest: apply_equality)
 done
 
 
 lemma inj_extend:
     "\<lbrakk>f \<in> inj(A,B);  a\<notin>A;  b\<notin>B\<rbrakk>
      \<Longrightarrow> cons(\<langle>a,b\<rangle>,f) \<in> inj(cons(a,A), cons(b,B))"
   unfolding inj_def
 apply (force intro: apply_type  simp add: fun_extend)
 done
 
 end
diff --git a/src/ZF/QUniv.thy b/src/ZF/QUniv.thy
--- a/src/ZF/QUniv.thy
+++ b/src/ZF/QUniv.thy
@@ -1,203 +1,203 @@
 (*  Title:      ZF/QUniv.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1993  University of Cambridge
 *)
 
 section\<open>A Small Universe for Lazy Recursive Types\<close>
 
 theory QUniv imports Univ QPair begin
 
 (*Disjoint sums as a datatype*)
 rep_datatype
   elimination   sumE
   induction     TrueI
   case_eqns     case_Inl case_Inr
 
 (*Variant disjoint sums as a datatype*)
 rep_datatype
   elimination   qsumE
   induction     TrueI
   case_eqns     qcase_QInl qcase_QInr
 
 definition
   quniv :: "i \<Rightarrow> i"  where
    "quniv(A) \<equiv> Pow(univ(eclose(A)))"
 
 
 subsection\<open>Properties involving Transset and Sum\<close>
 
 lemma Transset_includes_summands:
      "\<lbrakk>Transset(C); A+B \<subseteq> C\<rbrakk> \<Longrightarrow> A \<subseteq> C \<and> B \<subseteq> C"
 apply (simp add: sum_def Un_subset_iff)
 apply (blast dest: Transset_includes_range)
 done
 
 lemma Transset_sum_Int_subset:
      "Transset(C) \<Longrightarrow> (A+B) \<inter> C \<subseteq> (A \<inter> C) + (B \<inter> C)"
 apply (simp add: sum_def Int_Un_distrib2)
 apply (blast dest: Transset_Pair_D)
 done
 
 subsection\<open>Introduction and Elimination Rules\<close>
 
 lemma qunivI: "X \<subseteq> univ(eclose(A)) \<Longrightarrow> X \<in> quniv(A)"
 by (simp add: quniv_def)
 
 lemma qunivD: "X \<in> quniv(A) \<Longrightarrow> X \<subseteq> univ(eclose(A))"
 by (simp add: quniv_def)
 
 lemma quniv_mono: "A<=B \<Longrightarrow> quniv(A) \<subseteq> quniv(B)"
   unfolding quniv_def
 apply (erule eclose_mono [THEN univ_mono, THEN Pow_mono])
 done
 
 subsection\<open>Closure Properties\<close>
 
 lemma univ_eclose_subset_quniv: "univ(eclose(A)) \<subseteq> quniv(A)"
 apply (simp add: quniv_def Transset_iff_Pow [symmetric])
 apply (rule Transset_eclose [THEN Transset_univ])
 done
 
 (*Key property for proving A_subset_quniv; requires eclose in definition of quniv*)
 lemma univ_subset_quniv: "univ(A) \<subseteq> quniv(A)"
 apply (rule arg_subset_eclose [THEN univ_mono, THEN subset_trans])
 apply (rule univ_eclose_subset_quniv)
 done
 
 lemmas univ_into_quniv = univ_subset_quniv [THEN subsetD]
 
 lemma Pow_univ_subset_quniv: "Pow(univ(A)) \<subseteq> quniv(A)"
   unfolding quniv_def
 apply (rule arg_subset_eclose [THEN univ_mono, THEN Pow_mono])
 done
 
 lemmas univ_subset_into_quniv =
     PowI [THEN Pow_univ_subset_quniv [THEN subsetD]]
 
 lemmas zero_in_quniv = zero_in_univ [THEN univ_into_quniv]
 lemmas one_in_quniv = one_in_univ [THEN univ_into_quniv]
 lemmas two_in_quniv = two_in_univ [THEN univ_into_quniv]
 
 lemmas A_subset_quniv =  subset_trans [OF A_subset_univ univ_subset_quniv]
 
 lemmas A_into_quniv = A_subset_quniv [THEN subsetD]
 
 (*** univ(A) closure for Quine-inspired pairs and injections ***)
 
 (*Quine ordered pairs*)
 lemma QPair_subset_univ:
     "\<lbrakk>a \<subseteq> univ(A);  b \<subseteq> univ(A)\<rbrakk> \<Longrightarrow> <a;b> \<subseteq> univ(A)"
 by (simp add: QPair_def sum_subset_univ)
 
 subsection\<open>Quine Disjoint Sum\<close>
 
 lemma QInl_subset_univ: "a \<subseteq> univ(A) \<Longrightarrow> QInl(a) \<subseteq> univ(A)"
   unfolding QInl_def
 apply (erule empty_subsetI [THEN QPair_subset_univ])
 done
 
 lemmas naturals_subset_nat =
     Ord_nat [THEN Ord_is_Transset, unfolded Transset_def, THEN bspec]
 
 lemmas naturals_subset_univ =
     subset_trans [OF naturals_subset_nat nat_subset_univ]
 
 lemma QInr_subset_univ: "a \<subseteq> univ(A) \<Longrightarrow> QInr(a) \<subseteq> univ(A)"
   unfolding QInr_def
 apply (erule nat_1I [THEN naturals_subset_univ, THEN QPair_subset_univ])
 done
 
 subsection\<open>Closure for Quine-Inspired Products and Sums\<close>
 
 (*Quine ordered pairs*)
 lemma QPair_in_quniv:
     "\<lbrakk>a: quniv(A);  b: quniv(A)\<rbrakk> \<Longrightarrow> <a;b> \<in> quniv(A)"
 by (simp add: quniv_def QPair_def sum_subset_univ)
 
 lemma QSigma_quniv: "quniv(A) <*> quniv(A) \<subseteq> quniv(A)"
 by (blast intro: QPair_in_quniv)
 
 lemmas QSigma_subset_quniv =  subset_trans [OF QSigma_mono QSigma_quniv]
 
 (*The opposite inclusion*)
 lemma quniv_QPair_D:
     "<a;b> \<in> quniv(A) \<Longrightarrow> a: quniv(A) \<and> b: quniv(A)"
-apply (unfold quniv_def QPair_def)
+  unfolding quniv_def QPair_def
 apply (rule Transset_includes_summands [THEN conjE])
 apply (rule Transset_eclose [THEN Transset_univ])
 apply (erule PowD, blast)
 done
 
 lemmas quniv_QPair_E = quniv_QPair_D [THEN conjE]
 
 lemma quniv_QPair_iff: "<a;b> \<in> quniv(A) \<longleftrightarrow> a: quniv(A) \<and> b: quniv(A)"
 by (blast intro: QPair_in_quniv dest: quniv_QPair_D)
 
 
 subsection\<open>Quine Disjoint Sum\<close>
 
 lemma QInl_in_quniv: "a: quniv(A) \<Longrightarrow> QInl(a) \<in> quniv(A)"
 by (simp add: QInl_def zero_in_quniv QPair_in_quniv)
 
 lemma QInr_in_quniv: "b: quniv(A) \<Longrightarrow> QInr(b) \<in> quniv(A)"
 by (simp add: QInr_def one_in_quniv QPair_in_quniv)
 
 lemma qsum_quniv: "quniv(C) <+> quniv(C) \<subseteq> quniv(C)"
 by (blast intro: QInl_in_quniv QInr_in_quniv)
 
 lemmas qsum_subset_quniv = subset_trans [OF qsum_mono qsum_quniv]
 
 
 subsection\<open>The Natural Numbers\<close>
 
 lemmas nat_subset_quniv =  subset_trans [OF nat_subset_univ univ_subset_quniv]
 
 (* n:nat \<Longrightarrow> n:quniv(A) *)
 lemmas nat_into_quniv = nat_subset_quniv [THEN subsetD]
 
 lemmas bool_subset_quniv = subset_trans [OF bool_subset_univ univ_subset_quniv]
 
 lemmas bool_into_quniv = bool_subset_quniv [THEN subsetD]
 
 
 (*Intersecting <a;b> with Vfrom...*)
 
 lemma QPair_Int_Vfrom_succ_subset:
  "Transset(X) \<Longrightarrow>
        <a;b> \<inter> Vfrom(X, succ(i))  \<subseteq>  <a \<inter> Vfrom(X,i);  b \<inter> Vfrom(X,i)>"
 by (simp add: QPair_def sum_def Int_Un_distrib2 Un_mono
               product_Int_Vfrom_subset [THEN subset_trans]
               Sigma_mono [OF Int_lower1 subset_refl])
 
 subsection\<open>"Take-Lemma" Rules\<close>
 
 (*for proving a=b by coinduction and c: quniv(A)*)
 
 (*Rule for level i -- preserving the level, not decreasing it*)
 
 lemma QPair_Int_Vfrom_subset:
  "Transset(X) \<Longrightarrow>
        <a;b> \<inter> Vfrom(X,i)  \<subseteq>  <a \<inter> Vfrom(X,i);  b \<inter> Vfrom(X,i)>"
   unfolding QPair_def
 apply (erule Transset_Vfrom [THEN Transset_sum_Int_subset])
 done
 
 (*@{term"\<lbrakk>a \<inter> Vset(i) \<subseteq> c; b \<inter> Vset(i) \<subseteq> d\<rbrakk> \<Longrightarrow> <a;b> \<inter> Vset(i) \<subseteq> <c;d>"}*)
 lemmas QPair_Int_Vset_subset_trans =
      subset_trans [OF Transset_0 [THEN QPair_Int_Vfrom_subset] QPair_mono]
 
 lemma QPair_Int_Vset_subset_UN:
      "Ord(i) \<Longrightarrow> <a;b> \<inter> Vset(i) \<subseteq> (\<Union>j\<in>i. <a \<inter> Vset(j); b \<inter> Vset(j)>)"
 apply (erule Ord_cases)
 (*0 case*)
 apply (simp add: Vfrom_0)
 (*succ(j) case*)
 apply (erule ssubst)
 apply (rule Transset_0 [THEN QPair_Int_Vfrom_succ_subset, THEN subset_trans])
 apply (rule succI1 [THEN UN_upper])
 (*Limit(i) case*)
 apply (simp del: UN_simps
         add: Limit_Vfrom_eq Int_UN_distrib UN_mono QPair_Int_Vset_subset_trans)
 done
 
 end
diff --git a/src/ZF/Resid/Confluence.thy b/src/ZF/Resid/Confluence.thy
--- a/src/ZF/Resid/Confluence.thy
+++ b/src/ZF/Resid/Confluence.thy
@@ -1,118 +1,118 @@
 (*  Title:      ZF/Resid/Confluence.thy
     Author:     Ole Rasmussen
     Copyright   1995  University of Cambridge
 *)
 
 theory Confluence imports Reduction begin
 
 definition
   confluence    :: "i\<Rightarrow>o"  where
     "confluence(R) \<equiv>   
        \<forall>x y. \<langle>x,y\<rangle> \<in> R \<longrightarrow> (\<forall>z.\<langle>x,z\<rangle> \<in> R \<longrightarrow> (\<exists>u.\<langle>y,u\<rangle> \<in> R \<and> \<langle>z,u\<rangle> \<in> R))"
 
 definition
   strip         :: "o"  where
     "strip \<equiv> \<forall>x y. (x =\<Longrightarrow> y) \<longrightarrow> 
                     (\<forall>z.(x =1\<Rightarrow> z) \<longrightarrow> (\<exists>u.(y =1\<Rightarrow> u) \<and> (z=\<Longrightarrow>u)))" 
 
 
 (* ------------------------------------------------------------------------- *)
 (*        strip lemmas                                                       *)
 (* ------------------------------------------------------------------------- *)
 
 lemma strip_lemma_r: 
     "\<lbrakk>confluence(Spar_red1)\<rbrakk>\<Longrightarrow> strip"
-apply (unfold confluence_def strip_def)
+  unfolding confluence_def strip_def
 apply (rule impI [THEN allI, THEN allI])
 apply (erule Spar_red.induct, fast)
 apply (fast intro: Spar_red.trans)
 done
 
 
 lemma strip_lemma_l: 
     "strip\<Longrightarrow> confluence(Spar_red)"
-apply (unfold confluence_def strip_def)
+  unfolding confluence_def strip_def
 apply (rule impI [THEN allI, THEN allI])
 apply (erule Spar_red.induct, blast)
 apply clarify
 apply (blast intro: Spar_red.trans)
 done
 
 (* ------------------------------------------------------------------------- *)
 (*      Confluence                                                           *)
 (* ------------------------------------------------------------------------- *)
 
 
 lemma parallel_moves: "confluence(Spar_red1)"
 apply (unfold confluence_def, clarify)
 apply (frule simulation)
 apply (frule_tac n = z in simulation, clarify)
 apply (frule_tac v = va in paving)
 apply (force intro: completeness)+
 done
 
 lemmas confluence_parallel_reduction =
       parallel_moves [THEN strip_lemma_r, THEN strip_lemma_l]
 
 lemma lemma1: "\<lbrakk>confluence(Spar_red)\<rbrakk>\<Longrightarrow> confluence(Sred)"
 by (unfold confluence_def, blast intro: par_red_red red_par_red)
 
 lemmas confluence_beta_reduction =
        confluence_parallel_reduction [THEN lemma1]
 
 
 (**** Conversion ****)
 
 consts
   Sconv1        :: "i"
   Sconv         :: "i"
 
 abbreviation
   Sconv1_rel (infixl \<open><-1->\<close> 50) where
   "a<-1->b \<equiv> \<langle>a,b\<rangle> \<in> Sconv1"
 
 abbreviation
   Sconv_rel (infixl \<open><-\<longrightarrow>\<close> 50) where
   "a<-\<longrightarrow>b \<equiv> \<langle>a,b\<rangle> \<in> Sconv"
   
 inductive
   domains       "Sconv1" \<subseteq> "lambda*lambda"
   intros
     red1:        "m -1-> n \<Longrightarrow> m<-1->n"
     expl:        "n -1-> m \<Longrightarrow> m<-1->n"
   type_intros    red1D1 red1D2 lambda.intros bool_typechecks
 
 declare Sconv1.intros [intro]
 
 inductive
   domains       "Sconv" \<subseteq> "lambda*lambda"
   intros
     one_step:    "m<-1->n  \<Longrightarrow> m<-\<longrightarrow>n"
     refl:        "m \<in> lambda \<Longrightarrow> m<-\<longrightarrow>m"
     trans:       "\<lbrakk>m<-\<longrightarrow>n; n<-\<longrightarrow>p\<rbrakk> \<Longrightarrow> m<-\<longrightarrow>p"
   type_intros    Sconv1.dom_subset [THEN subsetD] lambda.intros bool_typechecks
 
 declare Sconv.intros [intro]
 
 lemma conv_sym: "m<-\<longrightarrow>n \<Longrightarrow> n<-\<longrightarrow>m"
 apply (erule Sconv.induct)
 apply (erule Sconv1.induct, blast+)
 done
 
 (* ------------------------------------------------------------------------- *)
 (*      Church_Rosser Theorem                                                *)
 (* ------------------------------------------------------------------------- *)
 
 lemma Church_Rosser: "m<-\<longrightarrow>n \<Longrightarrow> \<exists>p.(m -\<longrightarrow>p) \<and> (n -\<longrightarrow> p)"
 apply (erule Sconv.induct)
 apply (erule Sconv1.induct)
 apply (blast intro: red1D1 redD2)
 apply (blast intro: red1D1 redD2)
 apply (blast intro: red1D1 redD2)
 apply (cut_tac confluence_beta_reduction)
   unfolding confluence_def
 apply (blast intro: Sred.trans)
 done
 
 end
 
diff --git a/src/ZF/Trancl.thy b/src/ZF/Trancl.thy
--- a/src/ZF/Trancl.thy
+++ b/src/ZF/Trancl.thy
@@ -1,374 +1,374 @@
 (*  Title:      ZF/Trancl.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1992  University of Cambridge
 *)
 
 section\<open>Relations: Their General Properties and Transitive Closure\<close>
 
 theory Trancl imports Fixedpt Perm begin
 
 definition
   refl     :: "[i,i]\<Rightarrow>o"  where
     "refl(A,r) \<equiv> (\<forall>x\<in>A. \<langle>x,x\<rangle> \<in> r)"
 
 definition
   irrefl   :: "[i,i]\<Rightarrow>o"  where
     "irrefl(A,r) \<equiv> \<forall>x\<in>A. \<langle>x,x\<rangle> \<notin> r"
 
 definition
   sym      :: "i\<Rightarrow>o"  where
     "sym(r) \<equiv> \<forall>x y. \<langle>x,y\<rangle>: r \<longrightarrow> \<langle>y,x\<rangle>: r"
 
 definition
   asym     :: "i\<Rightarrow>o"  where
     "asym(r) \<equiv> \<forall>x y. \<langle>x,y\<rangle>:r \<longrightarrow> \<not> \<langle>y,x\<rangle>:r"
 
 definition
   antisym  :: "i\<Rightarrow>o"  where
     "antisym(r) \<equiv> \<forall>x y.\<langle>x,y\<rangle>:r \<longrightarrow> \<langle>y,x\<rangle>:r \<longrightarrow> x=y"
 
 definition
   trans    :: "i\<Rightarrow>o"  where
     "trans(r) \<equiv> \<forall>x y z. \<langle>x,y\<rangle>: r \<longrightarrow> \<langle>y,z\<rangle>: r \<longrightarrow> \<langle>x,z\<rangle>: r"
 
 definition
   trans_on :: "[i,i]\<Rightarrow>o"  (\<open>trans[_]'(_')\<close>)  where
     "trans[A](r) \<equiv> \<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A.
                           \<langle>x,y\<rangle>: r \<longrightarrow> \<langle>y,z\<rangle>: r \<longrightarrow> \<langle>x,z\<rangle>: r"
 
 definition
   rtrancl :: "i\<Rightarrow>i"  (\<open>(_^*)\<close> [100] 100)  (*refl/transitive closure*)  where
     "r^* \<equiv> lfp(field(r)*field(r), \<lambda>s. id(field(r)) \<union> (r O s))"
 
 definition
   trancl  :: "i\<Rightarrow>i"  (\<open>(_^+)\<close> [100] 100)  (*transitive closure*)  where
     "r^+ \<equiv> r O r^*"
 
 definition
   equiv    :: "[i,i]\<Rightarrow>o"  where
     "equiv(A,r) \<equiv> r \<subseteq> A*A \<and> refl(A,r) \<and> sym(r) \<and> trans(r)"
 
 
 subsection\<open>General properties of relations\<close>
 
 subsubsection\<open>irreflexivity\<close>
 
 lemma irreflI:
     "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> \<langle>x,x\<rangle> \<notin> r\<rbrakk> \<Longrightarrow> irrefl(A,r)"
 by (simp add: irrefl_def)
 
 lemma irreflE: "\<lbrakk>irrefl(A,r);  x \<in> A\<rbrakk> \<Longrightarrow>  \<langle>x,x\<rangle> \<notin> r"
 by (simp add: irrefl_def)
 
 subsubsection\<open>symmetry\<close>
 
 lemma symI:
      "\<lbrakk>\<And>x y.\<langle>x,y\<rangle>: r \<Longrightarrow> \<langle>y,x\<rangle>: r\<rbrakk> \<Longrightarrow> sym(r)"
 by (unfold sym_def, blast)
 
 lemma symE: "\<lbrakk>sym(r); \<langle>x,y\<rangle>: r\<rbrakk>  \<Longrightarrow>  \<langle>y,x\<rangle>: r"
 by (unfold sym_def, blast)
 
 subsubsection\<open>antisymmetry\<close>
 
 lemma antisymI:
      "\<lbrakk>\<And>x y.\<lbrakk>\<langle>x,y\<rangle>: r;  \<langle>y,x\<rangle>: r\<rbrakk> \<Longrightarrow> x=y\<rbrakk> \<Longrightarrow> antisym(r)"
 by (simp add: antisym_def, blast)
 
 lemma antisymE: "\<lbrakk>antisym(r); \<langle>x,y\<rangle>: r;  \<langle>y,x\<rangle>: r\<rbrakk>  \<Longrightarrow>  x=y"
 by (simp add: antisym_def, blast)
 
 subsubsection\<open>transitivity\<close>
 
 lemma transD: "\<lbrakk>trans(r);  \<langle>a,b\<rangle>:r;  \<langle>b,c\<rangle>:r\<rbrakk> \<Longrightarrow> \<langle>a,c\<rangle>:r"
 by (unfold trans_def, blast)
 
 lemma trans_onD:
     "\<lbrakk>trans[A](r);  \<langle>a,b\<rangle>:r;  \<langle>b,c\<rangle>:r;  a \<in> A;  b \<in> A;  c \<in> A\<rbrakk> \<Longrightarrow> \<langle>a,c\<rangle>:r"
 by (unfold trans_on_def, blast)
 
 lemma trans_imp_trans_on: "trans(r) \<Longrightarrow> trans[A](r)"
 by (unfold trans_def trans_on_def, blast)
 
 lemma trans_on_imp_trans: "\<lbrakk>trans[A](r); r \<subseteq> A*A\<rbrakk> \<Longrightarrow> trans(r)"
 by (simp add: trans_on_def trans_def, blast)
 
 
 subsection\<open>Transitive closure of a relation\<close>
 
 lemma rtrancl_bnd_mono:
      "bnd_mono(field(r)*field(r), \<lambda>s. id(field(r)) \<union> (r O s))"
 by (rule bnd_monoI, blast+)
 
 lemma rtrancl_mono: "r<=s \<Longrightarrow> r^* \<subseteq> s^*"
   unfolding rtrancl_def
 apply (rule lfp_mono)
 apply (rule rtrancl_bnd_mono)+
 apply blast
 done
 
 (* @{term"r^* = id(field(r)) \<union> ( r O r^* )"}    *)
 lemmas rtrancl_unfold =
      rtrancl_bnd_mono [THEN rtrancl_def [THEN def_lfp_unfold]]
 
 (** The relation rtrancl **)
 
 (*  @{term"r^* \<subseteq> field(r) * field(r)"}  *)
 lemmas rtrancl_type = rtrancl_def [THEN def_lfp_subset]
 
 lemma relation_rtrancl: "relation(r^*)"
 apply (simp add: relation_def)
 apply (blast dest: rtrancl_type [THEN subsetD])
 done
 
 (*Reflexivity of rtrancl*)
 lemma rtrancl_refl: "\<lbrakk>a \<in> field(r)\<rbrakk> \<Longrightarrow> \<langle>a,a\<rangle> \<in> r^*"
 apply (rule rtrancl_unfold [THEN ssubst])
 apply (erule idI [THEN UnI1])
 done
 
 (*Closure under composition with r  *)
 lemma rtrancl_into_rtrancl: "\<lbrakk>\<langle>a,b\<rangle> \<in> r^*;  \<langle>b,c\<rangle> \<in> r\<rbrakk> \<Longrightarrow> \<langle>a,c\<rangle> \<in> r^*"
 apply (rule rtrancl_unfold [THEN ssubst])
 apply (rule compI [THEN UnI2], assumption, assumption)
 done
 
 (*rtrancl of r contains all pairs in r  *)
 lemma r_into_rtrancl: "\<langle>a,b\<rangle> \<in> r \<Longrightarrow> \<langle>a,b\<rangle> \<in> r^*"
 by (rule rtrancl_refl [THEN rtrancl_into_rtrancl], blast+)
 
 (*The premise ensures that r consists entirely of pairs*)
 lemma r_subset_rtrancl: "relation(r) \<Longrightarrow> r \<subseteq> r^*"
 by (simp add: relation_def, blast intro: r_into_rtrancl)
 
 lemma rtrancl_field: "field(r^*) = field(r)"
 by (blast intro: r_into_rtrancl dest!: rtrancl_type [THEN subsetD])
 
 
 (** standard induction rule **)
 
 lemma rtrancl_full_induct [case_names initial step, consumes 1]:
   "\<lbrakk>\<langle>a,b\<rangle> \<in> r^*;
       \<And>x. x \<in> field(r) \<Longrightarrow> P(\<langle>x,x\<rangle>);
       \<And>x y z.\<lbrakk>P(\<langle>x,y\<rangle>); \<langle>x,y\<rangle>: r^*; \<langle>y,z\<rangle>: r\<rbrakk>  \<Longrightarrow>  P(\<langle>x,z\<rangle>)\<rbrakk>
    \<Longrightarrow>  P(\<langle>a,b\<rangle>)"
 by (erule def_induct [OF rtrancl_def rtrancl_bnd_mono], blast)
 
 (*nice induction rule.
   Tried adding the typing hypotheses y,z \<in> field(r), but these
   caused expensive case splits!*)
 lemma rtrancl_induct [case_names initial step, induct set: rtrancl]:
   "\<lbrakk>\<langle>a,b\<rangle> \<in> r^*;
       P(a);
       \<And>y z.\<lbrakk>\<langle>a,y\<rangle> \<in> r^*;  \<langle>y,z\<rangle> \<in> r;  P(y)\<rbrakk> \<Longrightarrow> P(z)
 \<rbrakk> \<Longrightarrow> P(b)"
 (*by induction on this formula*)
 apply (subgoal_tac "\<forall>y. \<langle>a,b\<rangle> = \<langle>a,y\<rangle> \<longrightarrow> P (y) ")
 (*now solve first subgoal: this formula is sufficient*)
 apply (erule spec [THEN mp], rule refl)
 (*now do the induction*)
 apply (erule rtrancl_full_induct, blast+)
 done
 
 (*transitivity of transitive closure\<And>-- by induction.*)
 lemma trans_rtrancl: "trans(r^*)"
   unfolding trans_def
 apply (intro allI impI)
 apply (erule_tac b = z in rtrancl_induct, assumption)
 apply (blast intro: rtrancl_into_rtrancl)
 done
 
 lemmas rtrancl_trans = trans_rtrancl [THEN transD]
 
 (*elimination of rtrancl -- by induction on a special formula*)
 lemma rtranclE:
     "\<lbrakk>\<langle>a,b\<rangle> \<in> r^*;  (a=b) \<Longrightarrow> P;
         \<And>y.\<lbrakk>\<langle>a,y\<rangle> \<in> r^*;   \<langle>y,b\<rangle> \<in> r\<rbrakk> \<Longrightarrow> P\<rbrakk>
      \<Longrightarrow> P"
 apply (subgoal_tac "a = b | (\<exists>y. \<langle>a,y\<rangle> \<in> r^* \<and> \<langle>y,b\<rangle> \<in> r) ")
 (*see HOL/trancl*)
 apply blast
 apply (erule rtrancl_induct, blast+)
 done
 
 
 (**** The relation trancl ****)
 
 (*Transitivity of r^+ is proved by transitivity of r^*  *)
 lemma trans_trancl: "trans(r^+)"
-apply (unfold trans_def trancl_def)
+  unfolding trans_def trancl_def
 apply (blast intro: rtrancl_into_rtrancl
                     trans_rtrancl [THEN transD, THEN compI])
 done
 
 lemmas trans_on_trancl = trans_trancl [THEN trans_imp_trans_on]
 
 lemmas trancl_trans = trans_trancl [THEN transD]
 
 (** Conversions between trancl and rtrancl **)
 
 lemma trancl_into_rtrancl: "\<langle>a,b\<rangle> \<in> r^+ \<Longrightarrow> \<langle>a,b\<rangle> \<in> r^*"
   unfolding trancl_def
 apply (blast intro: rtrancl_into_rtrancl)
 done
 
 (*r^+ contains all pairs in r  *)
 lemma r_into_trancl: "\<langle>a,b\<rangle> \<in> r \<Longrightarrow> \<langle>a,b\<rangle> \<in> r^+"
   unfolding trancl_def
 apply (blast intro!: rtrancl_refl)
 done
 
 (*The premise ensures that r consists entirely of pairs*)
 lemma r_subset_trancl: "relation(r) \<Longrightarrow> r \<subseteq> r^+"
 by (simp add: relation_def, blast intro: r_into_trancl)
 
 
 (*intro rule by definition: from r^* and r  *)
 lemma rtrancl_into_trancl1: "\<lbrakk>\<langle>a,b\<rangle> \<in> r^*;  \<langle>b,c\<rangle> \<in> r\<rbrakk>   \<Longrightarrow>  \<langle>a,c\<rangle> \<in> r^+"
 by (unfold trancl_def, blast)
 
 (*intro rule from r and r^*  *)
 lemma rtrancl_into_trancl2:
     "\<lbrakk>\<langle>a,b\<rangle> \<in> r;  \<langle>b,c\<rangle> \<in> r^*\<rbrakk>   \<Longrightarrow>  \<langle>a,c\<rangle> \<in> r^+"
 apply (erule rtrancl_induct)
  apply (erule r_into_trancl)
 apply (blast intro: r_into_trancl trancl_trans)
 done
 
 (*Nice induction rule for trancl*)
 lemma trancl_induct [case_names initial step, induct set: trancl]:
   "\<lbrakk>\<langle>a,b\<rangle> \<in> r^+;
       \<And>y.  \<lbrakk>\<langle>a,y\<rangle> \<in> r\<rbrakk> \<Longrightarrow> P(y);
       \<And>y z.\<lbrakk>\<langle>a,y\<rangle> \<in> r^+;  \<langle>y,z\<rangle> \<in> r;  P(y)\<rbrakk> \<Longrightarrow> P(z)
 \<rbrakk> \<Longrightarrow> P(b)"
 apply (rule compEpair)
 apply (unfold trancl_def, assumption)
 (*by induction on this formula*)
 apply (subgoal_tac "\<forall>z. \<langle>y,z\<rangle> \<in> r \<longrightarrow> P (z) ")
 (*now solve first subgoal: this formula is sufficient*)
  apply blast
 apply (erule rtrancl_induct)
 apply (blast intro: rtrancl_into_trancl1)+
 done
 
 (*elimination of r^+ -- NOT an induction rule*)
 lemma tranclE:
     "\<lbrakk>\<langle>a,b\<rangle> \<in> r^+;
         \<langle>a,b\<rangle> \<in> r \<Longrightarrow> P;
         \<And>y.\<lbrakk>\<langle>a,y\<rangle> \<in> r^+; \<langle>y,b\<rangle> \<in> r\<rbrakk> \<Longrightarrow> P
 \<rbrakk> \<Longrightarrow> P"
 apply (subgoal_tac "\<langle>a,b\<rangle> \<in> r | (\<exists>y. \<langle>a,y\<rangle> \<in> r^+ \<and> \<langle>y,b\<rangle> \<in> r) ")
 apply blast
 apply (rule compEpair)
 apply (unfold trancl_def, assumption)
 apply (erule rtranclE)
 apply (blast intro: rtrancl_into_trancl1)+
 done
 
 lemma trancl_type: "r^+ \<subseteq> field(r)*field(r)"
   unfolding trancl_def
 apply (blast elim: rtrancl_type [THEN subsetD, THEN SigmaE2])
 done
 
 lemma relation_trancl: "relation(r^+)"
 apply (simp add: relation_def)
 apply (blast dest: trancl_type [THEN subsetD])
 done
 
 lemma trancl_subset_times: "r \<subseteq> A * A \<Longrightarrow> r^+ \<subseteq> A * A"
 by (insert trancl_type [of r], blast)
 
 lemma trancl_mono: "r<=s \<Longrightarrow> r^+ \<subseteq> s^+"
 by (unfold trancl_def, intro comp_mono rtrancl_mono)
 
 lemma trancl_eq_r: "\<lbrakk>relation(r); trans(r)\<rbrakk> \<Longrightarrow> r^+ = r"
 apply (rule equalityI)
  prefer 2 apply (erule r_subset_trancl, clarify)
 apply (frule trancl_type [THEN subsetD], clarify)
 apply (erule trancl_induct, assumption)
 apply (blast dest: transD)
 done
 
 
 (** Suggested by Sidi Ould Ehmety **)
 
 lemma rtrancl_idemp [simp]: "(r^*)^* = r^*"
 apply (rule equalityI, auto)
  prefer 2
  apply (frule rtrancl_type [THEN subsetD])
  apply (blast intro: r_into_rtrancl )
 txt\<open>converse direction\<close>
 apply (frule rtrancl_type [THEN subsetD], clarify)
 apply (erule rtrancl_induct)
 apply (simp add: rtrancl_refl rtrancl_field)
 apply (blast intro: rtrancl_trans)
 done
 
 lemma rtrancl_subset: "\<lbrakk>R \<subseteq> S; S \<subseteq> R^*\<rbrakk> \<Longrightarrow> S^* = R^*"
 apply (drule rtrancl_mono)
 apply (drule rtrancl_mono, simp_all, blast)
 done
 
 lemma rtrancl_Un_rtrancl:
      "\<lbrakk>relation(r); relation(s)\<rbrakk> \<Longrightarrow> (r^* \<union> s^*)^* = (r \<union> s)^*"
 apply (rule rtrancl_subset)
 apply (blast dest: r_subset_rtrancl)
 apply (blast intro: rtrancl_mono [THEN subsetD])
 done
 
 (*** "converse" laws by Sidi Ould Ehmety ***)
 
 (** rtrancl **)
 
 lemma rtrancl_converseD: "\<langle>x,y\<rangle>:converse(r)^* \<Longrightarrow> \<langle>x,y\<rangle>:converse(r^*)"
 apply (rule converseI)
 apply (frule rtrancl_type [THEN subsetD])
 apply (erule rtrancl_induct)
 apply (blast intro: rtrancl_refl)
 apply (blast intro: r_into_rtrancl rtrancl_trans)
 done
 
 lemma rtrancl_converseI: "\<langle>x,y\<rangle>:converse(r^*) \<Longrightarrow> \<langle>x,y\<rangle>:converse(r)^*"
 apply (drule converseD)
 apply (frule rtrancl_type [THEN subsetD])
 apply (erule rtrancl_induct)
 apply (blast intro: rtrancl_refl)
 apply (blast intro: r_into_rtrancl rtrancl_trans)
 done
 
 lemma rtrancl_converse: "converse(r)^* = converse(r^*)"
 apply (safe intro!: equalityI)
 apply (frule rtrancl_type [THEN subsetD])
 apply (safe dest!: rtrancl_converseD intro!: rtrancl_converseI)
 done
 
 (** trancl **)
 
 lemma trancl_converseD: "\<langle>a, b\<rangle>:converse(r)^+ \<Longrightarrow> \<langle>a, b\<rangle>:converse(r^+)"
 apply (erule trancl_induct)
 apply (auto intro: r_into_trancl trancl_trans)
 done
 
 lemma trancl_converseI: "\<langle>x,y\<rangle>:converse(r^+) \<Longrightarrow> \<langle>x,y\<rangle>:converse(r)^+"
 apply (drule converseD)
 apply (erule trancl_induct)
 apply (auto intro: r_into_trancl trancl_trans)
 done
 
 lemma trancl_converse: "converse(r)^+ = converse(r^+)"
 apply (safe intro!: equalityI)
 apply (frule trancl_type [THEN subsetD])
 apply (safe dest!: trancl_converseD intro!: trancl_converseI)
 done
 
 lemma converse_trancl_induct [case_names initial step, consumes 1]:
 "\<lbrakk>\<langle>a, b\<rangle>:r^+; \<And>y. \<langle>y, b\<rangle> :r \<Longrightarrow> P(y);
       \<And>y z. \<lbrakk>\<langle>y, z\<rangle> \<in> r; \<langle>z, b\<rangle> \<in> r^+; P(z)\<rbrakk> \<Longrightarrow> P(y)\<rbrakk>
        \<Longrightarrow> P(a)"
 apply (drule converseI)
 apply (simp (no_asm_use) add: trancl_converse [symmetric])
 apply (erule trancl_induct)
 apply (auto simp add: trancl_converse)
 done
 
 end
diff --git a/src/ZF/UNITY/AllocBase.thy b/src/ZF/UNITY/AllocBase.thy
--- a/src/ZF/UNITY/AllocBase.thy
+++ b/src/ZF/UNITY/AllocBase.thy
@@ -1,398 +1,398 @@
 (*  Title:      ZF/UNITY/AllocBase.thy
     Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
     Copyright   2001  University of Cambridge
 *)
 
 section\<open>Common declarations for Chandy and Charpentier's Allocator\<close>
 
 theory AllocBase imports Follows MultisetSum Guar begin
 
 abbreviation (input)
   tokbag   :: i  (* tokbags could be multisets...or any ordered type?*)
 where
   "tokbag \<equiv> nat"
 
 axiomatization
   NbT :: i and  (* Number of tokens in system *)
   Nclients :: i  (* Number of clients *)
 where
   NbT_pos: "NbT \<in> nat-{0}" and
   Nclients_pos: "Nclients \<in> nat-{0}"
   
 text\<open>This function merely sums the elements of a list\<close>
 consts tokens :: "i \<Rightarrow>i"
        item :: i (* Items to be merged/distributed *)
 primrec 
   "tokens(Nil) = 0"
   "tokens (Cons(x,xs)) = x #+ tokens(xs)"
 
 consts bag_of :: "i \<Rightarrow> i"
 primrec
   "bag_of(Nil)    = 0"
   "bag_of(Cons(x,xs)) = {#x#} +# bag_of(xs)"
 
 
 text\<open>Definitions needed in Client.thy.  We define a recursive predicate
 using 0 and 1 to code the truth values.\<close>
 consts all_distinct0 :: "i\<Rightarrow>i"
 primrec
   "all_distinct0(Nil) = 1"
   "all_distinct0(Cons(a, l)) =
      (if a \<in> set_of_list(l) then 0 else all_distinct0(l))"
 
 definition
   all_distinct  :: "i\<Rightarrow>o"  where
    "all_distinct(l) \<equiv> all_distinct0(l)=1"
   
 definition  
   state_of :: "i \<Rightarrow>i" \<comment> \<open>coersion from anyting to state\<close>  where
    "state_of(s) \<equiv> if s \<in> state then s else st0"
 
 definition
   lift :: "i \<Rightarrow>(i\<Rightarrow>i)" \<comment> \<open>simplifies the expression of programs\<close>  where
    "lift(x) \<equiv> \<lambda>s. s`x"
 
 text\<open>function to show that the set of variables is infinite\<close>
 consts
   nat_list_inj :: "i\<Rightarrow>i"
   var_inj      :: "i\<Rightarrow>i"
 
 primrec
   "nat_list_inj(0) = Nil"
   "nat_list_inj(succ(n)) = Cons(n, nat_list_inj(n))"
 
 primrec
   "var_inj(Var(l)) = length(l)"
 
 definition
   nat_var_inj  :: "i\<Rightarrow>i"  where
   "nat_var_inj(n) \<equiv> Var(nat_list_inj(n))"
 
 
 subsection\<open>Various simple lemmas\<close>
 
 lemma Nclients_NbT_gt_0 [simp]: "0 < Nclients \<and> 0 < NbT"
 apply (cut_tac Nclients_pos NbT_pos)
 apply (auto intro: Ord_0_lt)
 done
 
 lemma Nclients_NbT_not_0 [simp]: "Nclients \<noteq> 0 \<and> NbT \<noteq> 0"
 by (cut_tac Nclients_pos NbT_pos, auto)
 
 lemma Nclients_type [simp,TC]: "Nclients\<in>nat"
 by (cut_tac Nclients_pos NbT_pos, auto)
 
 lemma NbT_type [simp,TC]: "NbT\<in>nat"
 by (cut_tac Nclients_pos NbT_pos, auto)
 
 lemma INT_Nclient_iff [iff]:
      "b\<in>\<Inter>(RepFun(Nclients, B)) \<longleftrightarrow> (\<forall>x\<in>Nclients. b\<in>B(x))"
 by (force simp add: INT_iff)
 
 lemma setsum_fun_mono [rule_format]:
      "n\<in>nat \<Longrightarrow>  
       (\<forall>i\<in>nat. i<n \<longrightarrow> f(i) $\<le> g(i)) \<longrightarrow>  
       setsum(f, n) $\<le> setsum(g,n)"
 apply (induct_tac "n", simp_all)
 apply (subgoal_tac "Finite(x) \<and> x\<notin>x")
  prefer 2 apply (simp add: nat_into_Finite mem_not_refl, clarify)
 apply (simp (no_asm_simp) add: succ_def)
 apply (subgoal_tac "\<forall>i\<in>nat. i<x\<longrightarrow> f(i) $\<le> g(i) ")
  prefer 2 apply (force dest: leI) 
 apply (rule zadd_zle_mono, simp_all)
 done
 
 lemma tokens_type [simp,TC]: "l\<in>list(A) \<Longrightarrow> tokens(l)\<in>nat"
 by (erule list.induct, auto)
 
 lemma tokens_mono_aux [rule_format]:
      "xs\<in>list(A) \<Longrightarrow> \<forall>ys\<in>list(A). \<langle>xs, ys\<rangle>\<in>prefix(A)  
    \<longrightarrow> tokens(xs) \<le> tokens(ys)"
 apply (induct_tac "xs")
 apply (auto dest: gen_prefix.dom_subset [THEN subsetD] simp add: prefix_def)
 done
 
 lemma tokens_mono: "\<langle>xs, ys\<rangle>\<in>prefix(A) \<Longrightarrow> tokens(xs) \<le> tokens(ys)"
 apply (cut_tac prefix_type)
 apply (blast intro: tokens_mono_aux)
 done
 
 lemma mono_tokens [iff]: "mono1(list(A), prefix(A), nat, Le,tokens)"
   unfolding mono1_def
 apply (auto intro: tokens_mono simp add: Le_def)
 done
 
 lemma tokens_append [simp]: 
 "\<lbrakk>xs\<in>list(A); ys\<in>list(A)\<rbrakk> \<Longrightarrow> tokens(xs@ys) = tokens(xs) #+ tokens(ys)"
 apply (induct_tac "xs", auto)
 done
 
 subsection\<open>The function \<^term>\<open>bag_of\<close>\<close>
 
 lemma bag_of_type [simp,TC]: "l\<in>list(A) \<Longrightarrow>bag_of(l)\<in>Mult(A)"
 apply (induct_tac "l")
 apply (auto simp add: Mult_iff_multiset)
 done
 
 lemma bag_of_multiset:
      "l\<in>list(A) \<Longrightarrow> multiset(bag_of(l)) \<and> mset_of(bag_of(l))<=A"
 apply (drule bag_of_type)
 apply (auto simp add: Mult_iff_multiset)
 done
 
 lemma bag_of_append [simp]:
     "\<lbrakk>xs\<in>list(A); ys\<in>list(A)\<rbrakk> \<Longrightarrow> bag_of(xs@ys) = bag_of(xs) +# bag_of(ys)"
 apply (induct_tac "xs")
 apply (auto simp add: bag_of_multiset munion_assoc)
 done
 
 lemma bag_of_mono_aux [rule_format]:
      "xs\<in>list(A) \<Longrightarrow> \<forall>ys\<in>list(A). \<langle>xs, ys\<rangle>\<in>prefix(A)  
       \<longrightarrow> <bag_of(xs), bag_of(ys)>\<in>MultLe(A, r)"
 apply (induct_tac "xs", simp_all, clarify) 
 apply (frule_tac l = ys in bag_of_multiset)
 apply (auto intro: empty_le_MultLe simp add: prefix_def)
 apply (rule munion_mono)
 apply (force simp add: MultLe_def Mult_iff_multiset)
 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
 done
 
 lemma bag_of_mono [intro]:
      "\<lbrakk>\<langle>xs, ys\<rangle>\<in>prefix(A); xs\<in>list(A); ys\<in>list(A)\<rbrakk>
       \<Longrightarrow> <bag_of(xs), bag_of(ys)>\<in>MultLe(A, r)"
 apply (blast intro: bag_of_mono_aux)
 done
 
 lemma mono_bag_of [simp]: 
      "mono1(list(A), prefix(A), Mult(A), MultLe(A,r), bag_of)"
 by (auto simp add:  mono1_def bag_of_type)
 
 
 subsection\<open>The function \<^term>\<open>msetsum\<close>\<close>
 
 lemmas nat_into_Fin = eqpoll_refl [THEN [2] Fin_lemma]
 
 lemma list_Int_length_Fin: "l \<in> list(A) \<Longrightarrow> C \<inter> length(l) \<in> Fin(length(l))"
 apply (drule length_type)
 apply (rule Fin_subset)
 apply (rule Int_lower2)
 apply (erule nat_into_Fin)
 done
 
 
 
 lemma mem_Int_imp_lt_length:
      "\<lbrakk>xs \<in> list(A); k \<in> C \<inter> length(xs)\<rbrakk> \<Longrightarrow> k < length(xs)"
 by (simp add: ltI)
 
 lemma Int_succ_right:
      "A \<inter> succ(k) = (if k \<in> A then cons(k, A \<inter> k) else A \<inter> k)"
 by auto
 
 
 lemma bag_of_sublist_lemma:
      "\<lbrakk>C \<subseteq> nat; x \<in> A; xs \<in> list(A)\<rbrakk>   
   \<Longrightarrow>  msetsum(\<lambda>i. {#nth(i, xs @ [x])#}, C \<inter> succ(length(xs)), A) =  
        (if length(xs) \<in> C then  
           {#x#} +# msetsum(\<lambda>x. {#nth(x, xs)#}, C \<inter> length(xs), A)  
         else msetsum(\<lambda>x. {#nth(x, xs)#}, C \<inter> length(xs), A))"
 apply (simp add: subsetD nth_append lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong)
 apply (simp add: Int_succ_right)
 apply (simp add: lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong, clarify)
 apply (subst msetsum_cons)
 apply (rule_tac [3] succI1)
 apply (blast intro: list_Int_length_Fin subset_succI [THEN Fin_mono, THEN subsetD])
 apply (simp add: mem_not_refl)
 apply (simp add: nth_type lt_not_refl)
 apply (blast intro: nat_into_Ord ltI length_type)
 apply (simp add: lt_not_refl mem_Int_imp_lt_length cong add: msetsum_cong)
 done
 
 lemma bag_of_sublist_lemma2:
      "l\<in>list(A) \<Longrightarrow>  
   C \<subseteq> nat \<Longrightarrow>  
   bag_of(sublist(l, C)) =  
       msetsum(\<lambda>i. {#nth(i, l)#}, C \<inter> length(l), A)"
 apply (erule list_append_induct)
 apply (simp (no_asm))
 apply (simp (no_asm_simp) add: sublist_append nth_append bag_of_sublist_lemma munion_commute bag_of_sublist_lemma msetsum_multiset munion_0)
 done
 
 
 lemma nat_Int_length_eq: "l \<in> list(A) \<Longrightarrow> nat \<inter> length(l) = length(l)"
 apply (rule Int_absorb1)
 apply (rule OrdmemD, auto)
 done
 
 (*eliminating the assumption C<=nat*)
 lemma bag_of_sublist:
      "l\<in>list(A) \<Longrightarrow>  
   bag_of(sublist(l, C)) = msetsum(\<lambda>i. {#nth(i, l)#}, C \<inter> length(l), A)"
 apply (subgoal_tac " bag_of (sublist (l, C \<inter> nat)) = msetsum (\<lambda>i. {#nth (i, l) #}, C \<inter> length (l), A) ")
 apply (simp add: sublist_Int_eq)
 apply (simp add: bag_of_sublist_lemma2 Int_lower2 Int_assoc nat_Int_length_eq)
 done
 
 lemma bag_of_sublist_Un_Int: 
 "l\<in>list(A) \<Longrightarrow>  
   bag_of(sublist(l, B \<union> C)) +# bag_of(sublist(l, B \<inter> C)) =  
       bag_of(sublist(l, B)) +# bag_of(sublist(l, C))"
 apply (subgoal_tac "B \<inter> C \<inter> length (l) = (B \<inter> length (l)) \<inter> (C \<inter> length (l))")
 prefer 2 apply blast
 apply (simp (no_asm_simp) add: bag_of_sublist Int_Un_distrib2 msetsum_Un_Int)
 apply (rule msetsum_Un_Int)
 apply (erule list_Int_length_Fin)+
  apply (simp add: ltI nth_type)
 done
 
 
 lemma bag_of_sublist_Un_disjoint:
      "\<lbrakk>l\<in>list(A); B \<inter> C = 0\<rbrakk> 
       \<Longrightarrow> bag_of(sublist(l, B \<union> C)) =  
           bag_of(sublist(l, B)) +# bag_of(sublist(l, C))"
 by (simp add: bag_of_sublist_Un_Int [symmetric] bag_of_multiset)
 
 
 lemma bag_of_sublist_UN_disjoint [rule_format]:
      "\<lbrakk>Finite(I); \<forall>i\<in>I. \<forall>j\<in>I. i\<noteq>j \<longrightarrow> A(i) \<inter> A(j) = 0;  
         l\<in>list(B)\<rbrakk>  
       \<Longrightarrow> bag_of(sublist(l, \<Union>i\<in>I. A(i))) =   
           (msetsum(\<lambda>i. bag_of(sublist(l, A(i))), I, B)) "
 apply (simp (no_asm_simp) del: UN_simps
            add: UN_simps [symmetric] bag_of_sublist)
 apply (subst  msetsum_UN_disjoint [of _ _ _ "length (l)"])
 apply (drule Finite_into_Fin, assumption)
 prefer 3 apply force
 apply (auto intro!: Fin_IntI2 Finite_into_Fin simp add: ltI nth_type length_type nat_into_Finite)
 done
 
 
 lemma part_ord_Lt [simp]: "part_ord(nat, Lt)"
-apply (unfold part_ord_def Lt_def irrefl_def trans_on_def)
+  unfolding part_ord_def Lt_def irrefl_def trans_on_def
 apply (auto intro: lt_trans)
 done
 
 subsubsection\<open>The function \<^term>\<open>all_distinct\<close>\<close>
 
 lemma all_distinct_Nil [simp]: "all_distinct(Nil)"
 by (unfold all_distinct_def, auto)
 
 lemma all_distinct_Cons [simp]: 
     "all_distinct(Cons(a,l)) \<longleftrightarrow>  
       (a\<in>set_of_list(l) \<longrightarrow> False) \<and> (a \<notin> set_of_list(l) \<longrightarrow> all_distinct(l))"
   unfolding all_distinct_def
 apply (auto elim: list.cases)
 done
 
 subsubsection\<open>The function \<^term>\<open>state_of\<close>\<close>
 
 lemma state_of_state: "s\<in>state \<Longrightarrow> state_of(s)=s"
 by (unfold state_of_def, auto)
 declare state_of_state [simp]
 
 
 lemma state_of_idem: "state_of(state_of(s))=state_of(s)"
 
 apply (unfold state_of_def, auto)
 done
 declare state_of_idem [simp]
 
 
 lemma state_of_type [simp,TC]: "state_of(s)\<in>state"
 by (unfold state_of_def, auto)
 
 lemma lift_apply [simp]: "lift(x, s)=s`x"
 by (simp add: lift_def)
 
 
 (** Used in ClientImp **)
 
 lemma gen_Increains_state_of_eq: 
      "Increasing(A, r, \<lambda>s. f(state_of(s))) = Increasing(A, r, f)"
 apply (unfold Increasing_def, auto)
 done
 
 lemmas Increasing_state_ofD1 =  
       gen_Increains_state_of_eq [THEN equalityD1, THEN subsetD]
 lemmas Increasing_state_ofD2 =  
       gen_Increains_state_of_eq [THEN equalityD2, THEN subsetD]
 
 lemma Follows_state_of_eq: 
      "Follows(A, r, \<lambda>s. f(state_of(s)), \<lambda>s. g(state_of(s))) =   
       Follows(A, r, f, g)"
 apply (unfold Follows_def Increasing_def, auto)
 done
 
 lemmas Follows_state_ofD1 =
       Follows_state_of_eq [THEN equalityD1, THEN subsetD]
 lemmas Follows_state_ofD2 =
       Follows_state_of_eq [THEN equalityD2, THEN subsetD]
 
 lemma nat_list_inj_type: "n\<in>nat \<Longrightarrow> nat_list_inj(n)\<in>list(nat)"
 by (induct_tac "n", auto)
 
 lemma length_nat_list_inj: "n\<in>nat \<Longrightarrow> length(nat_list_inj(n)) = n"
 by (induct_tac "n", auto)
 
 lemma var_infinite_lemma: 
   "(\<lambda>x\<in>nat. nat_var_inj(x))\<in>inj(nat, var)"
   unfolding nat_var_inj_def
 apply (rule_tac d = var_inj in lam_injective)
 apply (auto simp add: var.intros nat_list_inj_type)
 apply (simp add: length_nat_list_inj)
 done
 
 lemma nat_lepoll_var: "nat \<lesssim> var"
   unfolding lepoll_def
 apply (rule_tac x = " (\<lambda>x\<in>nat. nat_var_inj (x))" in exI)
 apply (rule var_infinite_lemma)
 done
 
 lemma var_not_Finite: "\<not>Finite(var)"
 apply (insert nat_not_Finite) 
 apply (blast intro: lepoll_Finite [OF nat_lepoll_var]) 
 done
 
 lemma not_Finite_imp_exist: "\<not>Finite(A) \<Longrightarrow> \<exists>x. x\<in>A"
 apply (subgoal_tac "A\<noteq>0")
 apply (auto simp add: Finite_0)
 done
 
 lemma Inter_Diff_var_iff:
      "Finite(A) \<Longrightarrow> b\<in>(\<Inter>(RepFun(var-A, B))) \<longleftrightarrow> (\<forall>x\<in>var-A. b\<in>B(x))"
 apply (subgoal_tac "\<exists>x. x\<in>var-A", auto)
 apply (subgoal_tac "\<not>Finite (var-A) ")
 apply (drule not_Finite_imp_exist, auto)
 apply (cut_tac var_not_Finite)
 apply (erule swap)
 apply (rule_tac B = A in Diff_Finite, auto)
 done
 
 lemma Inter_var_DiffD:
      "\<lbrakk>b\<in>\<Inter>(RepFun(var-A, B)); Finite(A); x\<in>var-A\<rbrakk> \<Longrightarrow> b\<in>B(x)"
 by (simp add: Inter_Diff_var_iff)
 
 (* \<lbrakk>Finite(A); (\<forall>x\<in>var-A. b\<in>B(x))\<rbrakk> \<Longrightarrow> b\<in>\<Inter>(RepFun(var-A, B)) *)
 lemmas Inter_var_DiffI = Inter_Diff_var_iff [THEN iffD2]
 
 declare Inter_var_DiffI [intro!]
 
 lemma Acts_subset_Int_Pow_simp [simp]:
      "Acts(F)<= A \<inter> Pow(state*state)  \<longleftrightarrow> Acts(F)<=A"
 by (insert Acts_type [of F], auto)
 
 lemma setsum_nsetsum_eq: 
      "\<lbrakk>Finite(A); \<forall>x\<in>A. g(x)\<in>nat\<rbrakk> 
       \<Longrightarrow> setsum(\<lambda>x. $#(g(x)), A) = $# nsetsum(\<lambda>x. g(x), A)"
 apply (erule Finite_induct)
 apply (auto simp add: int_of_add)
 done
 
 lemma nsetsum_cong: 
      "\<lbrakk>A=B;  \<forall>x\<in>A. f(x)=g(x);  \<forall>x\<in>A. g(x)\<in>nat;  Finite(A)\<rbrakk>  
       \<Longrightarrow> nsetsum(f, A) = nsetsum(g, B)"
 apply (subgoal_tac "$# nsetsum (f, A) = $# nsetsum (g, B)", simp)
 apply (simp add: setsum_nsetsum_eq [symmetric] cong: setsum_cong) 
 done
 
 end
diff --git a/src/ZF/UNITY/ClientImpl.thy b/src/ZF/UNITY/ClientImpl.thy
--- a/src/ZF/UNITY/ClientImpl.thy
+++ b/src/ZF/UNITY/ClientImpl.thy
@@ -1,307 +1,307 @@
 (*  Title:      ZF/UNITY/ClientImpl.thy
     Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
     Copyright   2002  University of Cambridge
 
 Distributed Resource Management System:  Client Implementation.
 *)
 
 theory ClientImpl imports AllocBase Guar begin
 
 abbreviation "ask \<equiv> Var(Nil)" (* input history:  tokens requested *)
 abbreviation "giv \<equiv> Var([0])" (* output history: tokens granted *)
 abbreviation "rel \<equiv> Var([1])" (* input history: tokens released *)
 abbreviation "tok \<equiv> Var([2])" (* the number of available tokens *)
 
 axiomatization where
   type_assumes:
   "type_of(ask) = list(tokbag) \<and> type_of(giv) = list(tokbag) \<and>
    type_of(rel) = list(tokbag) \<and> type_of(tok) = nat" and
   default_val_assumes:
   "default_val(ask) = Nil \<and> default_val(giv) = Nil \<and>
    default_val(rel) = Nil \<and> default_val(tok) = 0"
 
 
 (*Array indexing is translated to list indexing as A[n] \<equiv> nth(n-1,A). *)
 
 definition
  (** Release some client_tokens **)
     "client_rel_act \<equiv>
      {\<langle>s,t\<rangle> \<in> state*state.
       \<exists>nrel \<in> nat. nrel = length(s`rel) \<and>
                    t = s(rel:=(s`rel)@[nth(nrel, s`giv)]) \<and>
                    nrel < length(s`giv) \<and>
                    nth(nrel, s`ask) \<le> nth(nrel, s`giv)}"
 
   (** Choose a new token requirement **)
   (** Including t=s suppresses fairness, allowing the non-trivial part
       of the action to be ignored **)
 definition
   "client_tok_act \<equiv> {\<langle>s,t\<rangle> \<in> state*state. t=s |
                      t = s(tok:=succ(s`tok mod NbT))}"
 
 definition
   "client_ask_act \<equiv> {\<langle>s,t\<rangle> \<in> state*state. t=s | (t=s(ask:=s`ask@[s`tok]))}"
 
 definition
   "client_prog \<equiv>
    mk_program({s \<in> state. s`tok \<le> NbT \<and> s`giv = Nil \<and>
                        s`ask = Nil \<and> s`rel = Nil},
                     {client_rel_act, client_tok_act, client_ask_act},
                    \<Union>G \<in> preserves(lift(rel)) Int
                          preserves(lift(ask)) Int
                          preserves(lift(tok)).  Acts(G))"
 
 
 declare type_assumes [simp] default_val_assumes [simp]
 (* This part should be automated *)
 
 lemma ask_value_type [simp,TC]: "s \<in> state \<Longrightarrow> s`ask \<in> list(nat)"
   unfolding state_def
 apply (drule_tac a = ask in apply_type, auto)
 done
 
 lemma giv_value_type [simp,TC]: "s \<in> state \<Longrightarrow> s`giv \<in> list(nat)"
   unfolding state_def
 apply (drule_tac a = giv in apply_type, auto)
 done
 
 lemma rel_value_type [simp,TC]: "s \<in> state \<Longrightarrow> s`rel \<in> list(nat)"
   unfolding state_def
 apply (drule_tac a = rel in apply_type, auto)
 done
 
 lemma tok_value_type [simp,TC]: "s \<in> state \<Longrightarrow> s`tok \<in> nat"
   unfolding state_def
 apply (drule_tac a = tok in apply_type, auto)
 done
 
 (** The Client Program **)
 
 lemma client_type [simp,TC]: "client_prog \<in> program"
   unfolding client_prog_def
 apply (simp (no_asm))
 done
 
 declare client_prog_def [THEN def_prg_Init, simp]
 declare client_prog_def [THEN def_prg_AllowedActs, simp]
 declare client_prog_def [program]
 
 declare  client_rel_act_def [THEN def_act_simp, simp]
 declare  client_tok_act_def [THEN def_act_simp, simp]
 declare  client_ask_act_def [THEN def_act_simp, simp]
 
 lemma client_prog_ok_iff:
   "\<forall>G \<in> program. (client_prog ok G) \<longleftrightarrow>
    (G \<in> preserves(lift(rel)) \<and> G \<in> preserves(lift(ask)) \<and>
     G \<in> preserves(lift(tok)) \<and>  client_prog \<in> Allowed(G))"
 by (auto simp add: ok_iff_Allowed client_prog_def [THEN def_prg_Allowed])
 
 lemma client_prog_preserves:
     "client_prog:(\<Inter>x \<in> var-{ask, rel, tok}. preserves(lift(x)))"
 apply (rule Inter_var_DiffI, force)
 apply (rule ballI)
 apply (rule preservesI, safety, auto)
 done
 
 
 lemma preserves_lift_imp_stable:
      "G \<in> preserves(lift(ff)) \<Longrightarrow> G \<in> stable({s \<in> state. P(s`ff)})"
 apply (drule preserves_imp_stable)
 apply (simp add: lift_def)
 done
 
 lemma preserves_imp_prefix:
      "G \<in> preserves(lift(ff))
       \<Longrightarrow> G \<in> stable({s \<in> state. \<langle>k, s`ff\<rangle> \<in> prefix(nat)})"
 by (erule preserves_lift_imp_stable)
 
 (*Safety property 1 \<in> ask, rel are increasing: (24) *)
 lemma client_prog_Increasing_ask_rel:
 "client_prog: program guarantees Incr(lift(ask)) \<inter> Incr(lift(rel))"
   unfolding guar_def
 apply (auto intro!: increasing_imp_Increasing
             simp add: client_prog_ok_iff Increasing.increasing_def preserves_imp_prefix)
 apply (safety, force, force)+
 done
 
 declare nth_append [simp] append_one_prefix [simp]
 
 lemma NbT_pos2: "0<NbT"
 apply (cut_tac NbT_pos)
 apply (rule Ord_0_lt, auto)
 done
 
 (*Safety property 2 \<in> the client never requests too many tokens.
 With no Substitution Axiom, we must prove the two invariants simultaneously. *)
 
 lemma ask_Bounded_lemma:
 "\<lbrakk>client_prog ok G; G \<in> program\<rbrakk>
       \<Longrightarrow> client_prog \<squnion> G \<in>
               Always({s \<in> state. s`tok \<le> NbT}  \<inter>
                       {s \<in> state. \<forall>elt \<in> set_of_list(s`ask). elt \<le> NbT})"
 apply (rotate_tac -1)
 apply (auto simp add: client_prog_ok_iff)
 apply (rule invariantI [THEN stable_Join_Always2], force)
  prefer 2
  apply (fast intro: stable_Int preserves_lift_imp_stable, safety)
 apply (auto dest: ActsD)
 apply (cut_tac NbT_pos)
 apply (rule NbT_pos2 [THEN mod_less_divisor])
 apply (auto dest: ActsD preserves_imp_eq simp add: set_of_list_append)
 done
 
 (* Export version, with no mention of tok in the postcondition, but
   unfortunately tok must be declared local.*)
 lemma client_prog_ask_Bounded:
     "client_prog \<in> program guarantees
                    Always({s \<in> state. \<forall>elt \<in> set_of_list(s`ask). elt \<le> NbT})"
 apply (rule guaranteesI)
 apply (erule ask_Bounded_lemma [THEN Always_weaken], auto)
 done
 
 (*** Towards proving the liveness property ***)
 
 lemma client_prog_stable_rel_le_giv:
     "client_prog \<in> stable({s \<in> state. <s`rel, s`giv> \<in> prefix(nat)})"
 by (safety, auto)
 
 lemma client_prog_Join_Stable_rel_le_giv:
 "\<lbrakk>client_prog \<squnion> G \<in> Incr(lift(giv)); G \<in> preserves(lift(rel))\<rbrakk>
     \<Longrightarrow> client_prog \<squnion> G \<in> Stable({s \<in> state. <s`rel, s`giv> \<in> prefix(nat)})"
 apply (rule client_prog_stable_rel_le_giv [THEN Increasing_preserves_Stable])
 apply (auto simp add: lift_def)
 done
 
 lemma client_prog_Join_Always_rel_le_giv:
      "\<lbrakk>client_prog \<squnion> G \<in> Incr(lift(giv)); G \<in> preserves(lift(rel))\<rbrakk>
     \<Longrightarrow> client_prog \<squnion> G  \<in> Always({s \<in> state. <s`rel, s`giv> \<in> prefix(nat)})"
 by (force intro!: AlwaysI client_prog_Join_Stable_rel_le_giv)
 
 lemma def_act_eq:
      "A \<equiv> {\<langle>s, t\<rangle> \<in> state*state. P(s, t)} \<Longrightarrow> A={\<langle>s, t\<rangle> \<in> state*state. P(s, t)}"
 by auto
 
 lemma act_subset: "A={\<langle>s,t\<rangle> \<in> state*state. P(s, t)} \<Longrightarrow> A<=state*state"
 by auto
 
 lemma transient_lemma:
 "client_prog \<in>
   transient({s \<in> state. s`rel = k \<and> \<langle>k, h\<rangle> \<in> strict_prefix(nat)
    \<and> <h, s`giv> \<in> prefix(nat) \<and> h pfixGe s`ask})"
 apply (rule_tac act = client_rel_act in transientI)
 apply (simp (no_asm) add: client_prog_def [THEN def_prg_Acts])
 apply (simp (no_asm) add: client_rel_act_def [THEN def_act_eq, THEN act_subset])
 apply (auto simp add: client_prog_def [THEN def_prg_Acts] domain_def)
 apply (rule ReplaceI)
 apply (rule_tac x = "x (rel:= x`rel @ [nth (length (x`rel), x`giv) ]) " in exI)
 apply (auto intro!: state_update_type app_type length_type nth_type, auto)
 apply (blast intro: lt_trans2 prefix_length_le strict_prefix_length_lt)
 apply (blast intro: lt_trans2 prefix_length_le strict_prefix_length_lt)
 apply (simp (no_asm_use) add: gen_prefix_iff_nth)
 apply (subgoal_tac "h \<in> list(nat)")
  apply (simp_all (no_asm_simp) add: prefix_type [THEN subsetD, THEN SigmaD1])
 apply (auto simp add: prefix_def Ge_def)
 apply (drule strict_prefix_length_lt)
 apply (drule_tac x = "length (x`rel) " in spec)
 apply auto
 apply (simp (no_asm_use) add: gen_prefix_iff_nth)
 apply (auto simp add: id_def lam_def)
 done
 
 lemma strict_prefix_is_prefix:
     "\<langle>xs, ys\<rangle> \<in> strict_prefix(A) \<longleftrightarrow>  \<langle>xs, ys\<rangle> \<in> prefix(A) \<and> xs\<noteq>ys"
-apply (unfold strict_prefix_def id_def lam_def)
+  unfolding strict_prefix_def id_def lam_def
 apply (auto dest: prefix_type [THEN subsetD])
 done
 
 lemma induct_lemma:
 "\<lbrakk>client_prog \<squnion> G \<in> Incr(lift(giv)); client_prog ok G; G \<in> program\<rbrakk>
   \<Longrightarrow> client_prog \<squnion> G \<in>
   {s \<in> state. s`rel = k \<and> \<langle>k,h\<rangle> \<in> strict_prefix(nat)
    \<and> <h, s`giv> \<in> prefix(nat) \<and> h pfixGe s`ask}
         \<longmapsto>w {s \<in> state. <k, s`rel> \<in> strict_prefix(nat)
                           \<and> <s`rel, s`giv> \<in> prefix(nat) \<and>
                                   <h, s`giv> \<in> prefix(nat) \<and>
                 h pfixGe s`ask}"
 apply (rule single_LeadsTo_I)
  prefer 2 apply simp
 apply (frule client_prog_Increasing_ask_rel [THEN guaranteesD])
 apply (rotate_tac [3] 2)
 apply (auto simp add: client_prog_ok_iff)
 apply (rule transient_lemma [THEN Join_transient_I1, THEN transient_imp_leadsTo, THEN leadsTo_imp_LeadsTo, THEN PSP_Stable, THEN LeadsTo_weaken])
 apply (rule Stable_Int [THEN Stable_Int, THEN Stable_Int])
 apply (erule_tac f = "lift (giv) " and a = "s`giv" in Increasing_imp_Stable)
 apply (simp (no_asm_simp))
 apply (erule_tac f = "lift (ask) " and a = "s`ask" in Increasing_imp_Stable)
 apply (simp (no_asm_simp))
 apply (erule_tac f = "lift (rel) " and a = "s`rel" in Increasing_imp_Stable)
 apply (simp (no_asm_simp))
 apply (erule client_prog_Join_Stable_rel_le_giv, blast, simp_all)
  prefer 2
  apply (blast intro: sym strict_prefix_is_prefix [THEN iffD2] prefix_trans prefix_imp_pfixGe pfixGe_trans)
 apply (auto intro: strict_prefix_is_prefix [THEN iffD1, THEN conjunct1]
                    prefix_trans)
 done
 
 lemma rel_progress_lemma:
 "\<lbrakk>client_prog \<squnion> G  \<in> Incr(lift(giv)); client_prog ok G; G \<in> program\<rbrakk>
   \<Longrightarrow> client_prog \<squnion> G  \<in>
      {s \<in> state. <s`rel, h> \<in> strict_prefix(nat)
            \<and> <h, s`giv> \<in> prefix(nat) \<and> h pfixGe s`ask}
                       \<longmapsto>w {s \<in> state. <h, s`rel> \<in> prefix(nat)}"
 apply (rule_tac f = "\<lambda>x \<in> state. length(h) #- length(x`rel)"
        in LessThan_induct)
 apply (auto simp add: vimage_def)
  prefer 2 apply (force simp add: lam_def)
 apply (rule single_LeadsTo_I)
  prefer 2 apply simp
 apply (subgoal_tac "h \<in> list(nat)")
  prefer 2 apply (blast dest: prefix_type [THEN subsetD])
 apply (rule induct_lemma [THEN LeadsTo_weaken])
     apply (simp add: length_type lam_def)
 apply (auto intro: strict_prefix_is_prefix [THEN iffD2]
             dest: common_prefix_linear  prefix_type [THEN subsetD])
 apply (erule swap)
 apply (rule imageI)
  apply (force dest!: simp add: lam_def)
 apply (simp add: length_type lam_def, clarify)
 apply (drule strict_prefix_length_lt)+
 apply (drule less_imp_succ_add, simp)+
 apply clarify
 apply simp
 apply (erule diff_le_self [THEN ltD])
 done
 
 lemma progress_lemma:
 "\<lbrakk>client_prog \<squnion> G \<in> Incr(lift(giv)); client_prog ok G; G \<in> program\<rbrakk>
  \<Longrightarrow> client_prog \<squnion> G
        \<in> {s \<in> state. <h, s`giv> \<in> prefix(nat) \<and> h pfixGe s`ask}
          \<longmapsto>w  {s \<in> state. <h, s`rel> \<in> prefix(nat)}"
 apply (rule client_prog_Join_Always_rel_le_giv [THEN Always_LeadsToI],
        assumption)
 apply (force simp add: client_prog_ok_iff)
 apply (rule LeadsTo_weaken_L)
 apply (rule LeadsTo_Un [OF rel_progress_lemma
                            subset_refl [THEN subset_imp_LeadsTo]])
 apply (auto intro: strict_prefix_is_prefix [THEN iffD2]
             dest: common_prefix_linear prefix_type [THEN subsetD])
 done
 
 (*Progress property: all tokens that are given will be released*)
 lemma client_prog_progress:
 "client_prog \<in> Incr(lift(giv))  guarantees
       (\<Inter>h \<in> list(nat). {s \<in> state. <h, s`giv> \<in> prefix(nat) \<and>
               h pfixGe s`ask} \<longmapsto>w {s \<in> state. <h, s`rel> \<in> prefix(nat)})"
 apply (rule guaranteesI)
 apply (blast intro: progress_lemma, auto)
 done
 
 lemma client_prog_Allowed:
      "Allowed(client_prog) =
       preserves(lift(rel)) \<inter> preserves(lift(ask)) \<inter> preserves(lift(tok))"
 apply (cut_tac v = "lift (ask)" in preserves_type)
 apply (auto simp add: Allowed_def client_prog_def [THEN def_prg_Allowed]
                       cons_Int_distrib safety_prop_Acts_iff)
 done
 
 end
diff --git a/src/ZF/UNITY/Comp.thy b/src/ZF/UNITY/Comp.thy
--- a/src/ZF/UNITY/Comp.thy
+++ b/src/ZF/UNITY/Comp.thy
@@ -1,342 +1,342 @@
 (*  Title:      ZF/UNITY/Comp.thy
     Author:     Sidi O Ehmety, Computer Laboratory
     Copyright   1998  University of Cambridge
 
 From Chandy and Sanders, "Reasoning About Program Composition",
 Technical Report 2000-003, University of Florida, 2000.
 
 Revised by Sidi Ehmety on January  2001 
 
 Added: a strong form of the order relation over component and localize 
 
 Theory ported from HOL.
   
 *)
 
 section\<open>Composition\<close>
 
 theory Comp imports Union Increasing begin
 
 definition
   component :: "[i,i]\<Rightarrow>o"  (infixl \<open>component\<close> 65)  where
   "F component H \<equiv> (\<exists>G. F \<squnion> G = H)"
 
 definition
   strict_component :: "[i,i]\<Rightarrow>o" (infixl \<open>strict'_component\<close> 65)  where
   "F strict_component H \<equiv> F component H \<and> F\<noteq>H"
 
 definition
   (* A stronger form of the component relation *)
   component_of :: "[i,i]\<Rightarrow>o"   (infixl \<open>component'_of\<close> 65)  where
   "F component_of H  \<equiv> (\<exists>G. F ok G \<and> F \<squnion> G = H)"
   
 definition
   strict_component_of :: "[i,i]\<Rightarrow>o" (infixl \<open>strict'_component'_of\<close> 65)  where
   "F strict_component_of H  \<equiv> F component_of H  \<and> F\<noteq>H"
 
 definition
   (* Preserves a state function f, in particular a variable *)
   preserves :: "(i\<Rightarrow>i)\<Rightarrow>i"  where
   "preserves(f) \<equiv> {F:program. \<forall>z. F: stable({s:state. f(s) = z})}"
 
 definition
   fun_pair :: "[i\<Rightarrow>i, i \<Rightarrow>i] \<Rightarrow>(i\<Rightarrow>i)"  where
   "fun_pair(f, g) \<equiv> \<lambda>x. <f(x), g(x)>"
 
 definition
   localize  :: "[i\<Rightarrow>i, i] \<Rightarrow> i"  where
   "localize(f,F) \<equiv> mk_program(Init(F), Acts(F),
                        AllowedActs(F) \<inter> (\<Union>G\<in>preserves(f). Acts(G)))"
 
   
 (*** component and strict_component relations ***)
 
 lemma componentI: 
      "H component F | H component G \<Longrightarrow> H component (F \<squnion> G)"
 apply (unfold component_def, auto)
 apply (rule_tac x = "Ga \<squnion> G" in exI)
 apply (rule_tac [2] x = "G \<squnion> F" in exI)
 apply (auto simp add: Join_ac)
 done
 
 lemma component_eq_subset: 
      "G \<in> program \<Longrightarrow> (F component G) \<longleftrightarrow>  
    (Init(G) \<subseteq> Init(F) \<and> Acts(F) \<subseteq> Acts(G) \<and> AllowedActs(G) \<subseteq> AllowedActs(F))"
 apply (unfold component_def, auto)
 apply (rule exI)
 apply (rule program_equalityI, auto)
 done
 
 lemma component_SKIP [simp]: "F \<in> program \<Longrightarrow> SKIP component F"
   unfolding component_def
 apply (rule_tac x = F in exI)
 apply (force intro: Join_SKIP_left)
 done
 
 lemma component_refl [simp]: "F \<in> program \<Longrightarrow> F component F"
   unfolding component_def
 apply (rule_tac x = F in exI)
 apply (force intro: Join_SKIP_right)
 done
 
 lemma SKIP_minimal: "F component SKIP \<Longrightarrow> programify(F) = SKIP"
 apply (rule program_equalityI)
 apply (simp_all add: component_eq_subset, blast)
 done
 
 lemma component_Join1: "F component (F \<squnion> G)"
 by (unfold component_def, blast)
 
 lemma component_Join2: "G component (F \<squnion> G)"
   unfolding component_def
 apply (simp (no_asm) add: Join_commute)
 apply blast
 done
 
 lemma Join_absorb1: "F component G \<Longrightarrow> F \<squnion> G = G"
 by (auto simp add: component_def Join_left_absorb)
 
 lemma Join_absorb2: "G component F \<Longrightarrow> F \<squnion> G = F"
 by (auto simp add: Join_ac component_def)
 
 lemma JOIN_component_iff:
      "H \<in> program\<Longrightarrow>(JOIN(I,F) component H) \<longleftrightarrow> (\<forall>i \<in> I. F(i) component H)"
 apply (case_tac "I=0", force)
 apply (simp (no_asm_simp) add: component_eq_subset)
 apply auto
 apply blast
 apply (rename_tac "y")
 apply (drule_tac c = y and A = "AllowedActs (H)" in subsetD)
 apply (blast elim!: not_emptyE)+
 done
 
 lemma component_JOIN: "i \<in> I \<Longrightarrow> F(i) component (\<Squnion>i \<in> I. (F(i)))"
   unfolding component_def
 apply (blast intro: JOIN_absorb)
 done
 
 lemma component_trans: "\<lbrakk>F component G; G component H\<rbrakk> \<Longrightarrow> F component H"
   unfolding component_def
 apply (blast intro: Join_assoc [symmetric])
 done
 
 lemma component_antisym:
      "\<lbrakk>F \<in> program; G \<in> program\<rbrakk> \<Longrightarrow>(F component G \<and> G  component F) \<longrightarrow> F = G"
 apply (simp (no_asm_simp) add: component_eq_subset)
 apply clarify
 apply (rule program_equalityI, auto)
 done
 
 lemma Join_component_iff:
      "H \<in> program \<Longrightarrow> 
       ((F \<squnion> G) component H) \<longleftrightarrow> (F component H \<and> G component H)"
 apply (simp (no_asm_simp) add: component_eq_subset)
 apply blast
 done
 
 lemma component_constrains:
      "\<lbrakk>F component G; G \<in> A co B; F \<in> program\<rbrakk> \<Longrightarrow> F \<in> A co B"
 apply (frule constrainsD2)
 apply (auto simp add: constrains_def component_eq_subset)
 done
 
 
 (*** preserves ***)
 
 lemma preserves_is_safety_prop [simp]: "safety_prop(preserves(f))"
-apply (unfold preserves_def safety_prop_def)
+  unfolding preserves_def safety_prop_def
 apply (auto dest: ActsD simp add: stable_def constrains_def)
 apply (drule_tac c = act in subsetD, auto)
 done
 
 lemma preservesI [rule_format]: 
      "\<forall>z. F \<in> stable({s \<in> state. f(s) = z})  \<Longrightarrow> F \<in> preserves(f)"
 apply (auto simp add: preserves_def)
 apply (blast dest: stableD2)
 done
 
 lemma preserves_imp_eq: 
      "\<lbrakk>F \<in> preserves(f);  act \<in> Acts(F);  \<langle>s,t\<rangle> \<in> act\<rbrakk> \<Longrightarrow> f(s) = f(t)"
-apply (unfold preserves_def stable_def constrains_def)
+  unfolding preserves_def stable_def constrains_def
 apply (subgoal_tac "s \<in> state \<and> t \<in> state")
  prefer 2 apply (blast dest!: Acts_type [THEN subsetD], force) 
 done
 
 lemma Join_preserves [iff]: 
 "(F \<squnion> G \<in> preserves(v)) \<longleftrightarrow>   
       (programify(F) \<in> preserves(v) \<and> programify(G) \<in> preserves(v))"
 by (auto simp add: preserves_def INT_iff)
  
 lemma JOIN_preserves [iff]:
      "(JOIN(I,F): preserves(v)) \<longleftrightarrow> (\<forall>i \<in> I. programify(F(i)):preserves(v))"
 by (auto simp add: JOIN_stable preserves_def INT_iff)
 
 lemma SKIP_preserves [iff]: "SKIP \<in> preserves(v)"
 by (auto simp add: preserves_def INT_iff)
 
 lemma fun_pair_apply [simp]: "fun_pair(f,g,x) = <f(x), g(x)>"
   unfolding fun_pair_def
 apply (simp (no_asm))
 done
 
 lemma preserves_fun_pair:
      "preserves(fun_pair(v,w)) = preserves(v) \<inter> preserves(w)"
 apply (rule equalityI)
 apply (auto simp add: preserves_def stable_def constrains_def, blast+)
 done
 
 lemma preserves_fun_pair_iff [iff]:
      "F \<in> preserves(fun_pair(v, w))  \<longleftrightarrow> F \<in> preserves(v) \<inter> preserves(w)"
 by (simp add: preserves_fun_pair)
 
 lemma fun_pair_comp_distrib:
      "(fun_pair(f, g) comp h)(x) = fun_pair(f comp h, g comp h, x)"
 by (simp add: fun_pair_def metacomp_def)
 
 lemma comp_apply [simp]: "(f comp g)(x) = f(g(x))"
 by (simp add: metacomp_def)
 
 lemma preserves_type: "preserves(v)<=program"
 by (unfold preserves_def, auto)
 
 lemma preserves_into_program [TC]: "F \<in> preserves(f) \<Longrightarrow> F \<in> program"
 by (blast intro: preserves_type [THEN subsetD])
 
 lemma subset_preserves_comp: "preserves(f) \<subseteq> preserves(g comp f)"
 apply (auto simp add: preserves_def stable_def constrains_def)
 apply (drule_tac x = "f (xb)" in spec)
 apply (drule_tac x = act in bspec, auto)
 done
 
 lemma imp_preserves_comp: "F \<in> preserves(f) \<Longrightarrow> F \<in> preserves(g comp f)"
 by (blast intro: subset_preserves_comp [THEN subsetD])
 
 lemma preserves_subset_stable: "preserves(f) \<subseteq> stable({s \<in> state. P(f(s))})"
 apply (auto simp add: preserves_def stable_def constrains_def)
 apply (rename_tac s' s)
 apply (subgoal_tac "f (s) = f (s') ")
 apply (force+)
 done
 
 lemma preserves_imp_stable:
      "F \<in> preserves(f) \<Longrightarrow> F \<in> stable({s \<in> state. P(f(s))})"
 by (blast intro: preserves_subset_stable [THEN subsetD])
 
 lemma preserves_imp_increasing: 
  "\<lbrakk>F \<in> preserves(f); \<forall>x \<in> state. f(x):A\<rbrakk> \<Longrightarrow> F \<in> Increasing.increasing(A, r, f)"
-apply (unfold Increasing.increasing_def)
+  unfolding Increasing.increasing_def
 apply (auto intro: preserves_into_program)
 apply (rule_tac P = "\<lambda>x. \<langle>k, x\<rangle>:r" in preserves_imp_stable, auto)
 done
 
 lemma preserves_id_subset_stable: 
  "st_set(A) \<Longrightarrow> preserves(\<lambda>x. x) \<subseteq> stable(A)"
 apply (unfold preserves_def stable_def constrains_def, auto)
 apply (drule_tac x = xb in spec)
 apply (drule_tac x = act in bspec)
 apply (auto dest: ActsD)
 done
 
 lemma preserves_id_imp_stable:
      "\<lbrakk>F \<in> preserves(\<lambda>x. x); st_set(A)\<rbrakk> \<Longrightarrow> F \<in> stable(A)"
 by (blast intro: preserves_id_subset_stable [THEN subsetD])
 
 (** Added by Sidi **)
 (** component_of **)
 
 (*  component_of is stronger than component *)
 lemma component_of_imp_component: 
 "F component_of H \<Longrightarrow> F component H"
 apply (unfold component_def component_of_def, blast)
 done
 
 (* component_of satisfies many of component's properties *)
 lemma component_of_refl [simp]: "F \<in> program \<Longrightarrow> F component_of F"
   unfolding component_of_def
 apply (rule_tac x = SKIP in exI, auto)
 done
 
 lemma component_of_SKIP [simp]: "F \<in> program \<Longrightarrow>SKIP component_of F"
 apply (unfold component_of_def, auto)
 apply (rule_tac x = F in exI, auto)
 done
 
 lemma component_of_trans: 
      "\<lbrakk>F component_of G; G component_of H\<rbrakk> \<Longrightarrow> F component_of H"
   unfolding component_of_def
 apply (blast intro: Join_assoc [symmetric])
 done
 
 (** localize **)
 lemma localize_Init_eq [simp]: "Init(localize(v,F)) = Init(F)"
 by (unfold localize_def, simp)
 
 lemma localize_Acts_eq [simp]: "Acts(localize(v,F)) = Acts(F)"
 by (unfold localize_def, simp)
 
 lemma localize_AllowedActs_eq [simp]: 
  "AllowedActs(localize(v,F)) = AllowedActs(F) \<inter> (\<Union>G \<in> preserves(v). Acts(G))"
   unfolding localize_def
 apply (rule equalityI)
 apply (auto dest: Acts_type [THEN subsetD])
 done
 
 
 (** Theorems used in ClientImpl **)
 
 lemma stable_localTo_stable2: 
  "\<lbrakk>F \<in> stable({s \<in> state. P(f(s), g(s))});  G \<in> preserves(f);  G \<in> preserves(g)\<rbrakk>  
       \<Longrightarrow> F \<squnion> G \<in> stable({s \<in> state. P(f(s), g(s))})"
 apply (auto dest: ActsD preserves_into_program simp add: stable_def constrains_def)
 apply (case_tac "act \<in> Acts (F) ")
 apply auto
 apply (drule preserves_imp_eq)
 apply (drule_tac [3] preserves_imp_eq, auto)
 done
 
 lemma Increasing_preserves_Stable:
      "\<lbrakk>F \<in> stable({s \<in> state. <f(s), g(s)>:r});  G \<in> preserves(f);    
          F \<squnion> G \<in> Increasing(A, r, g);  
          \<forall>x \<in> state. f(x):A \<and> g(x):A\<rbrakk>      
       \<Longrightarrow> F \<squnion> G \<in> Stable({s \<in> state. <f(s), g(s)>:r})"
 apply (auto simp add: stable_def Stable_def Increasing_def Constrains_def all_conj_distrib)
 apply (simp_all add: constrains_type [THEN subsetD] preserves_type [THEN subsetD])
 apply (blast intro: constrains_weaken)
 (*The G case remains*)
 apply (auto dest: ActsD simp add: preserves_def stable_def constrains_def ball_conj_distrib all_conj_distrib)
 (*We have a G-action, so delete assumptions about F-actions*)
 apply (erule_tac V = "\<forall>act \<in> Acts (F). P (act)" for P in thin_rl)
 apply (erule_tac V = "\<forall>k\<in>A. \<forall>act \<in> Acts (F) . P (k,act)" for P in thin_rl)
 apply (subgoal_tac "f (x) = f (xa) ")
 apply (auto dest!: bspec)
 done
 
 
 (** Lemma used in AllocImpl **)
 
 lemma Constrains_UN_left: 
      "\<lbrakk>\<forall>x \<in> I. F \<in> A(x) Co B; F \<in> program\<rbrakk> \<Longrightarrow> F:(\<Union>x \<in> I. A(x)) Co B"
 by (unfold Constrains_def constrains_def, auto)
 
 
 lemma stable_Join_Stable: 
  "\<lbrakk>F \<in> stable({s \<in> state. P(f(s), g(s))});  
      \<forall>k \<in> A. F \<squnion> G \<in> Stable({s \<in> state. P(k, g(s))});  
      G \<in> preserves(f); \<forall>s \<in> state. f(s):A\<rbrakk>
   \<Longrightarrow> F \<squnion> G \<in> Stable({s \<in> state. P(f(s), g(s))})"
-apply (unfold stable_def Stable_def preserves_def)
+  unfolding stable_def Stable_def preserves_def
 apply (rule_tac A = "(\<Union>k \<in> A. {s \<in> state. f(s)=k} \<inter> {s \<in> state. P (f (s), g (s))})" in Constrains_weaken_L)
 prefer 2 apply blast
 apply (rule Constrains_UN_left, auto)
 apply (rule_tac A = "{s \<in> state. f(s)=k} \<inter> {s \<in> state. P (f (s), g (s))} \<inter> {s \<in> state. P (k, g (s))}" and A' = "({s \<in> state. f(s)=k} \<union> {s \<in> state. P (f (s), g (s))}) \<inter> {s \<in> state. P (k, g (s))}" in Constrains_weaken)
  prefer 2 apply blast 
  prefer 2 apply blast 
 apply (rule Constrains_Int)
 apply (rule constrains_imp_Constrains)
 apply (auto simp add: constrains_type [THEN subsetD])
 apply (blast intro: constrains_weaken) 
 apply (drule_tac x = k in spec)
 apply (blast intro: constrains_weaken) 
 done
 
 end
diff --git a/src/ZF/UNITY/Constrains.thy b/src/ZF/UNITY/Constrains.thy
--- a/src/ZF/UNITY/Constrains.thy
+++ b/src/ZF/UNITY/Constrains.thy
@@ -1,507 +1,507 @@
 (*  Title:      ZF/UNITY/Constrains.thy
     Author:     Sidi O Ehmety, Computer Laboratory
     Copyright   2001  University of Cambridge
 *)
 
 section\<open>Weak Safety Properties\<close>
 
 theory Constrains
 imports UNITY
 begin
 
 consts traces :: "[i, i] \<Rightarrow> i"
   (* Initial states and program \<Rightarrow> (final state, reversed trace to it)... 
       the domain may also be state*list(state) *)
 inductive 
   domains 
      "traces(init, acts)" <=
          "(init \<union> (\<Union>act\<in>acts. field(act)))*list(\<Union>act\<in>acts. field(act))"
   intros 
          (*Initial trace is empty*)
     Init: "s: init \<Longrightarrow> <s,[]> \<in> traces(init,acts)"
 
     Acts: "\<lbrakk>act:acts;  \<langle>s,evs\<rangle> \<in> traces(init,acts);  <s,s'>: act\<rbrakk>
            \<Longrightarrow> <s', Cons(s,evs)> \<in> traces(init, acts)"
   
   type_intros list.intros UnI1 UnI2 UN_I fieldI2 fieldI1
 
 
 consts reachable :: "i\<Rightarrow>i"
 inductive
   domains
   "reachable(F)" \<subseteq> "Init(F) \<union> (\<Union>act\<in>Acts(F). field(act))"
   intros 
     Init: "s:Init(F) \<Longrightarrow> s:reachable(F)"
 
     Acts: "\<lbrakk>act: Acts(F);  s:reachable(F);  <s,s'>: act\<rbrakk>
            \<Longrightarrow> s':reachable(F)"
 
   type_intros UnI1 UnI2 fieldI2 UN_I
 
   
 definition
   Constrains :: "[i,i] \<Rightarrow> i"  (infixl \<open>Co\<close> 60)  where
   "A Co B \<equiv> {F:program. F:(reachable(F) \<inter> A) co B}"
 
 definition
   op_Unless  :: "[i, i] \<Rightarrow> i"  (infixl \<open>Unless\<close> 60)  where
   "A Unless B \<equiv> (A-B) Co (A \<union> B)"
 
 definition
   Stable     :: "i \<Rightarrow> i"  where
   "Stable(A) \<equiv> A Co A"
 
 definition
   (*Always is the weak form of "invariant"*)
   Always :: "i \<Rightarrow> i"  where
   "Always(A) \<equiv> initially(A) \<inter> Stable(A)"
 
 
 (*** traces and reachable ***)
 
 lemma reachable_type: "reachable(F) \<subseteq> state"
 apply (cut_tac F = F in Init_type)
 apply (cut_tac F = F in Acts_type)
 apply (cut_tac F = F in reachable.dom_subset, blast)
 done
 
 lemma st_set_reachable: "st_set(reachable(F))"
   unfolding st_set_def
 apply (rule reachable_type)
 done
 declare st_set_reachable [iff]
 
 lemma reachable_Int_state: "reachable(F) \<inter> state = reachable(F)"
 by (cut_tac reachable_type, auto)
 declare reachable_Int_state [iff]
 
 lemma state_Int_reachable: "state \<inter> reachable(F) = reachable(F)"
 by (cut_tac reachable_type, auto)
 declare state_Int_reachable [iff]
 
 lemma reachable_equiv_traces: 
 "F \<in> program \<Longrightarrow> reachable(F)={s \<in> state. \<exists>evs. \<langle>s,evs\<rangle>:traces(Init(F), Acts(F))}"
 apply (rule equalityI, safe)
 apply (blast dest: reachable_type [THEN subsetD])
 apply (erule_tac [2] traces.induct)
 apply (erule reachable.induct)
 apply (blast intro: reachable.intros traces.intros)+
 done
 
 lemma Init_into_reachable: "Init(F) \<subseteq> reachable(F)"
 by (blast intro: reachable.intros)
 
 lemma stable_reachable: "\<lbrakk>F \<in> program; G \<in> program;  
     Acts(G) \<subseteq> Acts(F)\<rbrakk> \<Longrightarrow> G \<in> stable(reachable(F))"
 apply (blast intro: stableI constrainsI st_setI
              reachable_type [THEN subsetD] reachable.intros)
 done
 
 declare stable_reachable [intro!]
 declare stable_reachable [simp]
 
 (*The set of all reachable states is an invariant...*)
 lemma invariant_reachable: 
    "F \<in> program \<Longrightarrow> F \<in> invariant(reachable(F))"
-apply (unfold invariant_def initially_def)
+  unfolding invariant_def initially_def
 apply (blast intro: reachable_type [THEN subsetD] reachable.intros)
 done
 
 (*...in fact the strongest invariant!*)
 lemma invariant_includes_reachable: "F \<in> invariant(A) \<Longrightarrow> reachable(F) \<subseteq> A"
 apply (cut_tac F = F in Acts_type)
 apply (cut_tac F = F in Init_type)
 apply (cut_tac F = F in reachable_type)
 apply (simp (no_asm_use) add: stable_def constrains_def invariant_def initially_def)
 apply (rule subsetI)
 apply (erule reachable.induct)
 apply (blast intro: reachable.intros)+
 done
 
 (*** Co ***)
 
 lemma constrains_reachable_Int: "F \<in> B co B'\<Longrightarrow>F:(reachable(F) \<inter> B) co (reachable(F) \<inter> B')"
 apply (frule constrains_type [THEN subsetD])
 apply (frule stable_reachable [OF _ _ subset_refl])
 apply (simp_all add: stable_def constrains_Int)
 done
 
 (*Resembles the previous definition of Constrains*)
 lemma Constrains_eq_constrains: 
 "A Co B = {F \<in> program. F:(reachable(F) \<inter> A) co (reachable(F)  \<inter>  B)}"
   unfolding Constrains_def
 apply (blast dest: constrains_reachable_Int constrains_type [THEN subsetD]
              intro: constrains_weaken)
 done
 
 lemmas Constrains_def2 = Constrains_eq_constrains [THEN eq_reflection]
 
 lemma constrains_imp_Constrains: "F \<in> A co A' \<Longrightarrow> F \<in> A Co A'"
   unfolding Constrains_def
 apply (blast intro: constrains_weaken_L dest: constrainsD2)
 done
 
 lemma ConstrainsI: 
     "\<lbrakk>\<And>act s s'. \<lbrakk>act \<in> Acts(F); <s,s'>:act; s \<in> A\<rbrakk> \<Longrightarrow> s':A'; 
        F \<in> program\<rbrakk>
      \<Longrightarrow> F \<in> A Co A'"
 apply (auto simp add: Constrains_def constrains_def st_set_def)
 apply (blast dest: reachable_type [THEN subsetD])
 done
 
 lemma Constrains_type: 
  "A Co B \<subseteq> program"
 apply (unfold Constrains_def, blast)
 done
 
 lemma Constrains_empty: "F \<in> 0 Co B \<longleftrightarrow> F \<in> program"
 by (auto dest: Constrains_type [THEN subsetD]
             intro: constrains_imp_Constrains)
 declare Constrains_empty [iff]
 
 lemma Constrains_state: "F \<in> A Co state \<longleftrightarrow> F \<in> program"
   unfolding Constrains_def
 apply (auto dest: Constrains_type [THEN subsetD] intro: constrains_imp_Constrains)
 done
 declare Constrains_state [iff]
 
 lemma Constrains_weaken_R: 
         "\<lbrakk>F \<in> A Co A'; A'<=B'\<rbrakk> \<Longrightarrow> F \<in> A Co B'"
   unfolding Constrains_def2
 apply (blast intro: constrains_weaken_R)
 done
 
 lemma Constrains_weaken_L: 
     "\<lbrakk>F \<in> A Co A'; B<=A\<rbrakk> \<Longrightarrow> F \<in> B Co A'"
   unfolding Constrains_def2
 apply (blast intro: constrains_weaken_L st_set_subset)
 done
 
 lemma Constrains_weaken: 
    "\<lbrakk>F \<in> A Co A'; B<=A; A'<=B'\<rbrakk> \<Longrightarrow> F \<in> B Co B'"
   unfolding Constrains_def2
 apply (blast intro: constrains_weaken st_set_subset)
 done
 
 (** Union **)
 lemma Constrains_Un: 
     "\<lbrakk>F \<in> A Co A'; F \<in> B Co B'\<rbrakk> \<Longrightarrow> F \<in> (A \<union> B) Co (A' \<union> B')"
 apply (unfold Constrains_def2, auto)
 apply (simp add: Int_Un_distrib)
 apply (blast intro: constrains_Un)
 done
 
 lemma Constrains_UN: 
     "\<lbrakk>(\<And>i. i \<in> I\<Longrightarrow>F \<in> A(i) Co A'(i)); F \<in> program\<rbrakk> 
      \<Longrightarrow> F:(\<Union>i \<in> I. A(i)) Co (\<Union>i \<in> I. A'(i))"
 by (auto intro: constrains_UN simp del: UN_simps 
          simp add: Constrains_def2 Int_UN_distrib)
 
 
 (** Intersection **)
 
 lemma Constrains_Int: 
     "\<lbrakk>F \<in> A Co A'; F \<in> B Co B'\<rbrakk>\<Longrightarrow> F:(A \<inter> B) Co (A' \<inter> B')"
   unfolding Constrains_def
 apply (subgoal_tac "reachable (F) \<inter> (A \<inter> B) = (reachable (F) \<inter> A) \<inter> (reachable (F) \<inter> B) ")
 apply (auto intro: constrains_Int)
 done
 
 lemma Constrains_INT: 
     "\<lbrakk>(\<And>i. i \<in> I \<Longrightarrow>F \<in> A(i) Co A'(i)); F \<in> program\<rbrakk>  
      \<Longrightarrow> F:(\<Inter>i \<in> I. A(i)) Co (\<Inter>i \<in> I. A'(i))"
 apply (simp (no_asm_simp) del: INT_simps add: Constrains_def INT_extend_simps)
 apply (rule constrains_INT)
 apply (auto simp add: Constrains_def)
 done
 
 lemma Constrains_imp_subset: "F \<in> A Co A' \<Longrightarrow> reachable(F) \<inter> A \<subseteq> A'"
   unfolding Constrains_def
 apply (blast dest: constrains_imp_subset)
 done
 
 lemma Constrains_trans: 
  "\<lbrakk>F \<in> A Co B; F \<in> B Co C\<rbrakk> \<Longrightarrow> F \<in> A Co C"
   unfolding Constrains_def2
 apply (blast intro: constrains_trans constrains_weaken)
 done
 
 lemma Constrains_cancel: 
 "\<lbrakk>F \<in> A Co (A' \<union> B); F \<in> B Co B'\<rbrakk> \<Longrightarrow> F \<in> A Co (A' \<union> B')"
   unfolding Constrains_def2
 apply (simp (no_asm_use) add: Int_Un_distrib)
 apply (blast intro: constrains_cancel)
 done
 
 (*** Stable ***)
 (* Useful because there's no Stable_weaken.  [Tanja Vos] *)
 
 lemma stable_imp_Stable: 
 "F \<in> stable(A) \<Longrightarrow> F \<in> Stable(A)"
 
-apply (unfold stable_def Stable_def)
+  unfolding stable_def Stable_def
 apply (erule constrains_imp_Constrains)
 done
 
 lemma Stable_eq: "\<lbrakk>F \<in> Stable(A); A = B\<rbrakk> \<Longrightarrow> F \<in> Stable(B)"
 by blast
 
 lemma Stable_eq_stable: 
 "F \<in> Stable(A) \<longleftrightarrow>  (F \<in> stable(reachable(F) \<inter> A))"
 apply (auto dest: constrainsD2 simp add: Stable_def stable_def Constrains_def2)
 done
 
 lemma StableI: "F \<in> A Co A \<Longrightarrow> F \<in> Stable(A)"
 by (unfold Stable_def, assumption)
 
 lemma StableD: "F \<in> Stable(A) \<Longrightarrow> F \<in> A Co A"
 by (unfold Stable_def, assumption)
 
 lemma Stable_Un: 
     "\<lbrakk>F \<in> Stable(A); F \<in> Stable(A')\<rbrakk> \<Longrightarrow> F \<in> Stable(A \<union> A')"
   unfolding Stable_def
 apply (blast intro: Constrains_Un)
 done
 
 lemma Stable_Int: 
     "\<lbrakk>F \<in> Stable(A); F \<in> Stable(A')\<rbrakk> \<Longrightarrow> F \<in> Stable (A \<inter> A')"
   unfolding Stable_def
 apply (blast intro: Constrains_Int)
 done
 
 lemma Stable_Constrains_Un: 
     "\<lbrakk>F \<in> Stable(C); F \<in> A Co (C \<union> A')\<rbrakk>    
      \<Longrightarrow> F \<in> (C \<union> A) Co (C \<union> A')"
   unfolding Stable_def
 apply (blast intro: Constrains_Un [THEN Constrains_weaken_R])
 done
 
 lemma Stable_Constrains_Int: 
     "\<lbrakk>F \<in> Stable(C); F \<in> (C \<inter> A) Co A'\<rbrakk>    
      \<Longrightarrow> F \<in> (C \<inter> A) Co (C \<inter> A')"
   unfolding Stable_def
 apply (blast intro: Constrains_Int [THEN Constrains_weaken])
 done
 
 lemma Stable_UN: 
     "\<lbrakk>(\<And>i. i \<in> I \<Longrightarrow> F \<in> Stable(A(i))); F \<in> program\<rbrakk>
      \<Longrightarrow> F \<in> Stable (\<Union>i \<in> I. A(i))"
 apply (simp add: Stable_def)
 apply (blast intro: Constrains_UN)
 done
 
 lemma Stable_INT: 
     "\<lbrakk>(\<And>i. i \<in> I \<Longrightarrow> F \<in> Stable(A(i))); F \<in> program\<rbrakk>
      \<Longrightarrow> F \<in> Stable (\<Inter>i \<in> I. A(i))"
 apply (simp add: Stable_def)
 apply (blast intro: Constrains_INT)
 done
 
 lemma Stable_reachable: "F \<in> program \<Longrightarrow>F \<in> Stable (reachable(F))"
 apply (simp (no_asm_simp) add: Stable_eq_stable Int_absorb)
 done
 
 lemma Stable_type: "Stable(A) \<subseteq> program"
   unfolding Stable_def
 apply (rule Constrains_type)
 done
 
 (*** The Elimination Theorem.  The "free" m has become universally quantified!
      Should the premise be \<And>m instead of \<forall>m ?  Would make it harder to use
      in forward proof. ***)
 
 lemma Elimination: 
     "\<lbrakk>\<forall>m \<in> M. F \<in> ({s \<in> A. x(s) = m}) Co (B(m)); F \<in> program\<rbrakk>  
      \<Longrightarrow> F \<in> ({s \<in> A. x(s):M}) Co (\<Union>m \<in> M. B(m))"
 apply (unfold Constrains_def, auto)
 apply (rule_tac A1 = "reachable (F) \<inter> A" 
         in UNITY.elimination [THEN constrains_weaken_L])
 apply (auto intro: constrains_weaken_L)
 done
 
 (* As above, but for the special case of A=state *)
 lemma Elimination2: 
  "\<lbrakk>\<forall>m \<in> M. F \<in> {s \<in> state. x(s) = m} Co B(m); F \<in> program\<rbrakk>  
      \<Longrightarrow> F \<in> {s \<in> state. x(s):M} Co (\<Union>m \<in> M. B(m))"
 apply (blast intro: Elimination)
 done
 
 (** Unless **)
 
 lemma Unless_type: "A Unless B <=program"
   unfolding op_Unless_def
 apply (rule Constrains_type)
 done
 
 (*** Specialized laws for handling Always ***)
 
 (** Natural deduction rules for "Always A" **)
 
 lemma AlwaysI: 
 "\<lbrakk>Init(F)<=A;  F \<in> Stable(A)\<rbrakk> \<Longrightarrow> F \<in> Always(A)"
 
-apply (unfold Always_def initially_def)
+  unfolding Always_def initially_def
 apply (frule Stable_type [THEN subsetD], auto)
 done
 
 lemma AlwaysD: "F \<in> Always(A) \<Longrightarrow> Init(F)<=A \<and> F \<in> Stable(A)"
 by (simp add: Always_def initially_def)
 
 lemmas AlwaysE = AlwaysD [THEN conjE]
 lemmas Always_imp_Stable = AlwaysD [THEN conjunct2]
 
 (*The set of all reachable states is Always*)
 lemma Always_includes_reachable: "F \<in> Always(A) \<Longrightarrow> reachable(F) \<subseteq> A"
 apply (simp (no_asm_use) add: Stable_def Constrains_def constrains_def Always_def initially_def)
 apply (rule subsetI)
 apply (erule reachable.induct)
 apply (blast intro: reachable.intros)+
 done
 
 lemma invariant_imp_Always: 
      "F \<in> invariant(A) \<Longrightarrow> F \<in> Always(A)"
-apply (unfold Always_def invariant_def Stable_def stable_def)
+  unfolding Always_def invariant_def Stable_def stable_def
 apply (blast intro: constrains_imp_Constrains)
 done
 
 lemmas Always_reachable = invariant_reachable [THEN invariant_imp_Always]
 
 lemma Always_eq_invariant_reachable: "Always(A) = {F \<in> program. F \<in> invariant(reachable(F) \<inter> A)}"
 apply (simp (no_asm) add: Always_def invariant_def Stable_def Constrains_def2 stable_def initially_def)
 apply (rule equalityI, auto) 
 apply (blast intro: reachable.intros reachable_type)
 done
 
 (*the RHS is the traditional definition of the "always" operator*)
 lemma Always_eq_includes_reachable: "Always(A) = {F \<in> program. reachable(F) \<subseteq> A}"
 apply (rule equalityI, safe)
 apply (auto dest: invariant_includes_reachable 
    simp add: subset_Int_iff invariant_reachable Always_eq_invariant_reachable)
 done
 
 lemma Always_type: "Always(A) \<subseteq> program"
 by (unfold Always_def initially_def, auto)
 
 lemma Always_state_eq: "Always(state) = program"
 apply (rule equalityI)
 apply (auto dest: Always_type [THEN subsetD] reachable_type [THEN subsetD]
             simp add: Always_eq_includes_reachable)
 done
 declare Always_state_eq [simp]
 
 lemma state_AlwaysI: "F \<in> program \<Longrightarrow> F \<in> Always(state)"
 by (auto dest: reachable_type [THEN subsetD]
             simp add: Always_eq_includes_reachable)
 
 lemma Always_eq_UN_invariant: "st_set(A) \<Longrightarrow> Always(A) = (\<Union>I \<in> Pow(A). invariant(I))"
 apply (simp (no_asm) add: Always_eq_includes_reachable)
 apply (rule equalityI, auto) 
 apply (blast intro: invariantI rev_subsetD [OF _ Init_into_reachable] 
                     rev_subsetD [OF _ invariant_includes_reachable]  
              dest: invariant_type [THEN subsetD])+
 done
 
 lemma Always_weaken: "\<lbrakk>F \<in> Always(A); A \<subseteq> B\<rbrakk> \<Longrightarrow> F \<in> Always(B)"
 by (auto simp add: Always_eq_includes_reachable)
 
 
 (*** "Co" rules involving Always ***)
 lemmas Int_absorb2 = subset_Int_iff [unfolded iff_def, THEN conjunct1, THEN mp]
 
 lemma Always_Constrains_pre: "F \<in> Always(I) \<Longrightarrow> (F:(I \<inter> A) Co A') \<longleftrightarrow> (F \<in> A Co A')"
 apply (simp (no_asm_simp) add: Always_includes_reachable [THEN Int_absorb2] Constrains_def Int_assoc [symmetric])
 done
 
 lemma Always_Constrains_post: "F \<in> Always(I) \<Longrightarrow> (F \<in> A Co (I \<inter> A')) \<longleftrightarrow>(F \<in> A Co A')"
 apply (simp (no_asm_simp) add: Always_includes_reachable [THEN Int_absorb2] Constrains_eq_constrains Int_assoc [symmetric])
 done
 
 lemma Always_ConstrainsI: "\<lbrakk>F \<in> Always(I);  F \<in> (I \<inter> A) Co A'\<rbrakk> \<Longrightarrow> F \<in> A Co A'"
 by (blast intro: Always_Constrains_pre [THEN iffD1])
 
 (* \<lbrakk>F \<in> Always(I);  F \<in> A Co A'\<rbrakk> \<Longrightarrow> F \<in> A Co (I \<inter> A') *)
 lemmas Always_ConstrainsD = Always_Constrains_post [THEN iffD2]
 
 (*The analogous proof of Always_LeadsTo_weaken doesn't terminate*)
 lemma Always_Constrains_weaken: 
 "\<lbrakk>F \<in> Always(C); F \<in> A Co A'; C \<inter> B<=A; C \<inter> A'<=B'\<rbrakk>\<Longrightarrow>F \<in> B Co B'"
 apply (rule Always_ConstrainsI)
 apply (drule_tac [2] Always_ConstrainsD, simp_all) 
 apply (blast intro: Constrains_weaken)
 done
 
 (** Conjoining Always properties **)
 lemma Always_Int_distrib: "Always(A \<inter> B) = Always(A) \<inter> Always(B)"
 by (auto simp add: Always_eq_includes_reachable)
 
 (* the premise i \<in> I is need since \<Inter>is formally not defined for I=0 *)
 lemma Always_INT_distrib: "i \<in> I\<Longrightarrow>Always(\<Inter>i \<in> I. A(i)) = (\<Inter>i \<in> I. Always(A(i)))"
 apply (rule equalityI)
 apply (auto simp add: Inter_iff Always_eq_includes_reachable)
 done
 
 
 lemma Always_Int_I: "\<lbrakk>F \<in> Always(A);  F \<in> Always(B)\<rbrakk> \<Longrightarrow> F \<in> Always(A \<inter> B)"
 apply (simp (no_asm_simp) add: Always_Int_distrib)
 done
 
 (*Allows a kind of "implication introduction"*)
 lemma Always_Diff_Un_eq: "\<lbrakk>F \<in> Always(A)\<rbrakk> \<Longrightarrow> (F \<in> Always(C-A \<union> B)) \<longleftrightarrow> (F \<in> Always(B))"
 by (auto simp add: Always_eq_includes_reachable)
 
 (*Delete the nearest invariance assumption (which will be the second one
   used by Always_Int_I) *)
 lemmas Always_thin = thin_rl [of "F \<in> Always(A)"] for F A
 
 (*To allow expansion of the program's definition when appropriate*)
 named_theorems program "program definitions"
 
 ML
 \<open>
 (*Combines two invariance ASSUMPTIONS into one.  USEFUL??*)
 fun Always_Int_tac ctxt =
   dresolve_tac ctxt @{thms Always_Int_I} THEN'
   assume_tac ctxt THEN'
   eresolve_tac ctxt @{thms Always_thin};
 
 (*Combines a list of invariance THEOREMS into one.*)
 val Always_Int_rule = foldr1 (fn (th1,th2) => [th1,th2] MRS @{thm Always_Int_I});
 
 (*proves "co" properties when the program is specified*)
 
 fun constrains_tac ctxt =
    SELECT_GOAL
       (EVERY [REPEAT (Always_Int_tac ctxt 1),
               REPEAT (eresolve_tac ctxt @{thms Always_ConstrainsI} 1
                       ORELSE
                       resolve_tac ctxt [@{thm StableI}, @{thm stableI},
                                    @{thm constrains_imp_Constrains}] 1),
               resolve_tac ctxt @{thms constrainsI} 1,
               (* Three subgoals *)
               rewrite_goal_tac ctxt [@{thm st_set_def}] 3,
               REPEAT (force_tac ctxt 2),
               full_simp_tac (ctxt addsimps (Named_Theorems.get ctxt \<^named_theorems>\<open>program\<close>)) 1,
               ALLGOALS (clarify_tac ctxt),
               REPEAT (FIRSTGOAL (eresolve_tac ctxt @{thms disjE})),
               ALLGOALS (clarify_tac ctxt),
               REPEAT (FIRSTGOAL (eresolve_tac ctxt @{thms disjE})),
               ALLGOALS (clarify_tac ctxt),
               ALLGOALS (asm_full_simp_tac ctxt),
               ALLGOALS (clarify_tac ctxt)]);
 
 (*For proving invariants*)
 fun always_tac ctxt i =
   resolve_tac ctxt @{thms AlwaysI} i THEN
   force_tac ctxt i
   THEN constrains_tac ctxt i;
 \<close>
 
 method_setup safety = \<open>
   Scan.succeed (SIMPLE_METHOD' o constrains_tac)\<close>
   "for proving safety properties"
 
 method_setup always = \<open>
   Scan.succeed (SIMPLE_METHOD' o always_tac)\<close>
   "for proving invariants"
 
 end
diff --git a/src/ZF/UNITY/FP.thy b/src/ZF/UNITY/FP.thy
--- a/src/ZF/UNITY/FP.thy
+++ b/src/ZF/UNITY/FP.thy
@@ -1,83 +1,83 @@
 (*  Title:      ZF/UNITY/FP.thy
     Author:     Sidi O Ehmety, Computer Laboratory
     Copyright   2001  University of Cambridge
 
 From Misra, "A Logic for Concurrent Programming", 1994
 
 Theory ported from HOL.
 *)
 
 section\<open>Fixed Point of a Program\<close>
 
 theory FP imports UNITY begin
 
 definition   
   FP_Orig :: "i\<Rightarrow>i"  where
     "FP_Orig(F) \<equiv> \<Union>({A \<in> Pow(state). \<forall>B. F \<in> stable(A \<inter> B)})"
 
 definition
   FP :: "i\<Rightarrow>i"  where
     "FP(F) \<equiv> {s\<in>state. F \<in> stable({s})}"
 
 
 lemma FP_Orig_type: "FP_Orig(F) \<subseteq> state"
 by (unfold FP_Orig_def, blast)
 
 lemma st_set_FP_Orig [iff]: "st_set(FP_Orig(F))"
   unfolding st_set_def
 apply (rule FP_Orig_type)
 done
 
 lemma FP_type: "FP(F) \<subseteq> state"
 by (unfold FP_def, blast)
 
 lemma st_set_FP [iff]: "st_set(FP(F))"
   unfolding st_set_def
 apply (rule FP_type)
 done
 
 lemma stable_FP_Orig_Int: "F \<in> program \<Longrightarrow> F \<in> stable(FP_Orig(F) \<inter> B)"
 apply (simp only: FP_Orig_def stable_def Int_Union2)
 apply (blast intro: constrains_UN)
 done
 
 lemma FP_Orig_weakest2: 
     "\<lbrakk>\<forall>B. F \<in> stable (A \<inter> B); st_set(A)\<rbrakk>  \<Longrightarrow> A \<subseteq> FP_Orig(F)"
 by (unfold FP_Orig_def stable_def st_set_def, blast)
 
 lemmas FP_Orig_weakest = allI [THEN FP_Orig_weakest2]
 
 lemma stable_FP_Int: "F \<in> program \<Longrightarrow> F \<in> stable (FP(F) \<inter> B)"
 apply (subgoal_tac "FP (F) \<inter> B = (\<Union>x\<in>B. FP (F) \<inter> {x}) ")
  prefer 2 apply blast
 apply (simp (no_asm_simp) add: Int_cons_right)
-apply (unfold FP_def stable_def)
+  unfolding FP_def stable_def
 apply (rule constrains_UN)
 apply (auto simp add: cons_absorb)
 done
 
 lemma FP_subset_FP_Orig: "F \<in> program \<Longrightarrow> FP(F) \<subseteq> FP_Orig(F)"
 by (rule stable_FP_Int [THEN FP_Orig_weakest], auto)
 
 lemma FP_Orig_subset_FP: "F \<in> program \<Longrightarrow> FP_Orig(F) \<subseteq> FP(F)"
 apply (unfold FP_Orig_def FP_def, clarify)
 apply (drule_tac x = "{x}" in spec)
 apply (simp add: Int_cons_right)
 apply (frule stableD2)
 apply (auto simp add: cons_absorb st_set_def)
 done
 
 lemma FP_equivalence: "F \<in> program \<Longrightarrow> FP(F) = FP_Orig(F)"
 by (blast intro!: FP_Orig_subset_FP FP_subset_FP_Orig)
 
 lemma FP_weakest [rule_format]:
      "\<lbrakk>\<forall>B. F \<in> stable(A \<inter> B); F \<in> program; st_set(A)\<rbrakk> \<Longrightarrow> A \<subseteq> FP(F)"
 by (simp add: FP_equivalence FP_Orig_weakest)
 
 
 lemma Diff_FP: 
      "\<lbrakk>F \<in> program;  st_set(A)\<rbrakk> 
       \<Longrightarrow> A-FP(F) = (\<Union>act \<in> Acts(F). A - {s \<in> state. act``{s} \<subseteq> {s}})"
 by (unfold FP_def stable_def constrains_def st_set_def, blast)
 
 end
diff --git a/src/ZF/UNITY/Follows.thy b/src/ZF/UNITY/Follows.thy
--- a/src/ZF/UNITY/Follows.thy
+++ b/src/ZF/UNITY/Follows.thy
@@ -1,475 +1,475 @@
 (*  Title:      ZF/UNITY/Follows.thy
     Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
     Copyright   2002  University of Cambridge
 
 Theory ported from HOL.
 *)
 
 section\<open>The "Follows" relation of Charpentier and Sivilotte\<close>
 
 theory Follows imports SubstAx Increasing begin
 
 definition
   Follows :: "[i, i, i\<Rightarrow>i, i\<Rightarrow>i] \<Rightarrow> i"  where
   "Follows(A, r, f, g) \<equiv>
             Increasing(A, r, g) Int
             Increasing(A, r,f) Int
             Always({s \<in> state. <f(s), g(s)>:r}) Int
            (\<Inter>k \<in> A. {s \<in> state. <k, g(s)>:r} \<longmapsto>w {s \<in> state. <k,f(s)>:r})"
 
 abbreviation
   Incr :: "[i\<Rightarrow>i]\<Rightarrow>i" where
   "Incr(f) \<equiv> Increasing(list(nat), prefix(nat), f)"
 
 abbreviation
   n_Incr :: "[i\<Rightarrow>i]\<Rightarrow>i" where
   "n_Incr(f) \<equiv> Increasing(nat, Le, f)"
 
 abbreviation
   s_Incr :: "[i\<Rightarrow>i]\<Rightarrow>i" where
   "s_Incr(f) \<equiv> Increasing(Pow(nat), SetLe(nat), f)"
 
 abbreviation
   m_Incr :: "[i\<Rightarrow>i]\<Rightarrow>i" where
   "m_Incr(f) \<equiv> Increasing(Mult(nat), MultLe(nat, Le), f)"
 
 abbreviation
   n_Fols :: "[i\<Rightarrow>i, i\<Rightarrow>i]\<Rightarrow>i"   (infixl \<open>n'_Fols\<close> 65)  where
   "f n_Fols g \<equiv> Follows(nat, Le, f, g)"
 
 abbreviation
   Follows' :: "[i\<Rightarrow>i, i\<Rightarrow>i, i, i] \<Rightarrow> i"
         (\<open>(_ /Fols _ /Wrt (_ /'/ _))\<close> [60, 0, 0, 60] 60)  where
   "f Fols g Wrt r/A \<equiv> Follows(A,r,f,g)"
 
 
 (*Does this hold for "invariant"?*)
 
 lemma Follows_cong:
      "\<lbrakk>A=A'; r=r'; \<And>x. x \<in> state \<Longrightarrow> f(x)=f'(x); \<And>x. x \<in> state \<Longrightarrow> g(x)=g'(x)\<rbrakk> \<Longrightarrow> Follows(A, r, f, g) = Follows(A', r', f', g')"
 by (simp add: Increasing_def Follows_def)
 
 
 lemma subset_Always_comp:
 "\<lbrakk>mono1(A, r, B, s, h); \<forall>x \<in> state. f(x):A \<and> g(x):A\<rbrakk> \<Longrightarrow>
    Always({x \<in> state. <f(x), g(x)> \<in> r})<=Always({x \<in> state. <(h comp f)(x), (h comp g)(x)> \<in> s})"
-apply (unfold mono1_def metacomp_def)
+  unfolding mono1_def metacomp_def
 apply (auto simp add: Always_eq_includes_reachable)
 done
 
 lemma imp_Always_comp:
 "\<lbrakk>F \<in> Always({x \<in> state. <f(x), g(x)> \<in> r});
     mono1(A, r, B, s, h); \<forall>x \<in> state. f(x):A \<and> g(x):A\<rbrakk> \<Longrightarrow>
     F \<in> Always({x \<in> state. <(h comp f)(x), (h comp g)(x)> \<in> s})"
 by (blast intro: subset_Always_comp [THEN subsetD])
 
 
 lemma imp_Always_comp2:
 "\<lbrakk>F \<in> Always({x \<in> state. <f1(x), f(x)> \<in> r});
     F \<in> Always({x \<in> state. <g1(x), g(x)> \<in> s});
     mono2(A, r, B, s, C, t, h);
     \<forall>x \<in> state. f1(x):A \<and> f(x):A \<and> g1(x):B \<and> g(x):B\<rbrakk>
   \<Longrightarrow> F \<in> Always({x \<in> state. <h(f1(x), g1(x)), h(f(x), g(x))> \<in> t})"
 apply (auto simp add: Always_eq_includes_reachable mono2_def)
 apply (auto dest!: subsetD)
 done
 
 (* comp LeadsTo *)
 
 lemma subset_LeadsTo_comp:
 "\<lbrakk>mono1(A, r, B, s, h); refl(A,r); trans[B](s);
         \<forall>x \<in> state. f(x):A \<and> g(x):A\<rbrakk> \<Longrightarrow>
   (\<Inter>j \<in> A. {s \<in> state. <j, g(s)> \<in> r} \<longmapsto>w {s \<in> state. <j,f(s)> \<in> r}) <=
  (\<Inter>k \<in> B. {x \<in> state. <k, (h comp g)(x)> \<in> s} \<longmapsto>w {x \<in> state. <k, (h comp f)(x)> \<in> s})"
 
 apply (unfold mono1_def metacomp_def, clarify)
 apply (simp_all (no_asm_use) add: INT_iff)
 apply auto
 apply (rule single_LeadsTo_I)
 prefer 2 apply (blast dest: LeadsTo_type [THEN subsetD], auto)
 apply (rotate_tac 5)
 apply (drule_tac x = "g (sa) " in bspec)
 apply (erule_tac [2] LeadsTo_weaken)
 apply (auto simp add: part_order_def refl_def)
 apply (rule_tac b = "h (g (sa))" in trans_onD)
 apply blast
 apply auto
 done
 
 lemma imp_LeadsTo_comp:
 "\<lbrakk>F:(\<Inter>j \<in> A. {s \<in> state. <j, g(s)> \<in> r} \<longmapsto>w {s \<in> state. <j,f(s)> \<in> r});
     mono1(A, r, B, s, h); refl(A,r); trans[B](s);
     \<forall>x \<in> state. f(x):A \<and> g(x):A\<rbrakk> \<Longrightarrow>
    F:(\<Inter>k \<in> B. {x \<in> state. <k, (h comp g)(x)> \<in> s} \<longmapsto>w {x \<in> state. <k, (h comp f)(x)> \<in> s})"
 apply (rule subset_LeadsTo_comp [THEN subsetD], auto)
 done
 
 lemma imp_LeadsTo_comp_right:
 "\<lbrakk>F \<in> Increasing(B, s, g);
   \<forall>j \<in> A. F: {s \<in> state. <j, f(s)> \<in> r} \<longmapsto>w {s \<in> state. <j,f1(s)> \<in> r};
   mono2(A, r, B, s, C, t, h); refl(A, r); refl(B, s); trans[C](t);
   \<forall>x \<in> state. f1(x):A \<and> f(x):A \<and> g(x):B; k \<in> C\<rbrakk> \<Longrightarrow>
   F:{x \<in> state. <k, h(f(x), g(x))> \<in> t} \<longmapsto>w {x \<in> state. <k, h(f1(x), g(x))> \<in> t}"
-apply (unfold mono2_def Increasing_def)
+  unfolding mono2_def Increasing_def
 apply (rule single_LeadsTo_I, auto)
 apply (drule_tac x = "g (sa) " and A = B in bspec)
 apply auto
 apply (drule_tac x = "f (sa) " and P = "\<lambda>j. F \<in> X(j) \<longmapsto>w Y(j)" for X Y in bspec)
 apply auto
 apply (rule PSP_Stable [THEN LeadsTo_weaken], blast, blast)
 apply auto
 apply (force simp add: part_order_def refl_def)
 apply (force simp add: part_order_def refl_def)
 apply (drule_tac x = "f1 (x)" and x1 = "f (sa) " and P2 = "\<lambda>x y. \<forall>u\<in>B. P (x,y,u)" for P in bspec [THEN bspec])
 apply (drule_tac [3] x = "g (x) " and x1 = "g (sa) " and P2 = "\<lambda>x y. P (x,y) \<longrightarrow> d (x,y) \<in> t" for P d in bspec [THEN bspec])
 apply auto
 apply (rule_tac b = "h (f (sa), g (sa))" and A = C in trans_onD)
 apply (auto simp add: part_order_def)
 done
 
 lemma imp_LeadsTo_comp_left:
 "\<lbrakk>F \<in> Increasing(A, r, f);
   \<forall>j \<in> B. F: {x \<in> state. <j, g(x)> \<in> s} \<longmapsto>w {x \<in> state. <j,g1(x)> \<in> s};
   mono2(A, r, B, s, C, t, h); refl(A,r); refl(B, s); trans[C](t);
   \<forall>x \<in> state. f(x):A \<and> g1(x):B \<and> g(x):B; k \<in> C\<rbrakk> \<Longrightarrow>
   F:{x \<in> state. <k, h(f(x), g(x))> \<in> t} \<longmapsto>w {x \<in> state. <k, h(f(x), g1(x))> \<in> t}"
-apply (unfold mono2_def Increasing_def)
+  unfolding mono2_def Increasing_def
 apply (rule single_LeadsTo_I, auto)
 apply (drule_tac x = "f (sa) " and P = "\<lambda>k. F \<in> Stable (X (k))" for X in bspec)
 apply auto
 apply (drule_tac x = "g (sa) " in bspec)
 apply auto
 apply (rule PSP_Stable [THEN LeadsTo_weaken], blast, blast)
 apply auto
 apply (force simp add: part_order_def refl_def)
 apply (force simp add: part_order_def refl_def)
 apply (drule_tac x = "f (x) " and x1 = "f (sa) " in bspec [THEN bspec])
 apply (drule_tac [3] x = "g1 (x) " and x1 = "g (sa) " and P2 = "\<lambda>x y. P (x,y) \<longrightarrow> d (x,y) \<in> t" for P d in bspec [THEN bspec])
 apply auto
 apply (rule_tac b = "h (f (sa), g (sa))" and A = C in trans_onD)
 apply (auto simp add: part_order_def)
 done
 
 (**  This general result is used to prove Follows Un, munion, etc. **)
 lemma imp_LeadsTo_comp2:
 "\<lbrakk>F \<in> Increasing(A, r, f1) \<inter>  Increasing(B, s, g);
   \<forall>j \<in> A. F: {s \<in> state. <j, f(s)> \<in> r} \<longmapsto>w {s \<in> state. <j,f1(s)> \<in> r};
   \<forall>j \<in> B. F: {x \<in> state. <j, g(x)> \<in> s} \<longmapsto>w {x \<in> state. <j,g1(x)> \<in> s};
   mono2(A, r, B, s, C, t, h); refl(A,r); refl(B, s); trans[C](t);
   \<forall>x \<in> state. f(x):A \<and> g1(x):B \<and> f1(x):A \<and>g(x):B; k \<in> C\<rbrakk>
   \<Longrightarrow> F:{x \<in> state. <k, h(f(x), g(x))> \<in> t} \<longmapsto>w {x \<in> state. <k, h(f1(x), g1(x))> \<in> t}"
 apply (rule_tac B = "{x \<in> state. <k, h (f1 (x), g (x))> \<in> t}" in LeadsTo_Trans)
 apply (blast intro: imp_LeadsTo_comp_right)
 apply (blast intro: imp_LeadsTo_comp_left)
 done
 
 (* Follows type *)
 lemma Follows_type: "Follows(A, r, f, g)<=program"
   unfolding Follows_def
 apply (blast dest: Increasing_type [THEN subsetD])
 done
 
 lemma Follows_into_program [TC]: "F \<in> Follows(A, r, f, g) \<Longrightarrow> F \<in> program"
 by (blast dest: Follows_type [THEN subsetD])
 
 lemma FollowsD:
 "F \<in> Follows(A, r, f, g)\<Longrightarrow>
   F \<in> program \<and> (\<exists>a. a \<in> A) \<and> (\<forall>x \<in> state. f(x):A \<and> g(x):A)"
   unfolding Follows_def
 apply (blast dest: IncreasingD)
 done
 
 lemma Follows_constantI:
  "\<lbrakk>F \<in> program; c \<in> A; refl(A, r)\<rbrakk> \<Longrightarrow> F \<in> Follows(A, r, \<lambda>x. c, \<lambda>x. c)"
 apply (unfold Follows_def, auto)
 apply (auto simp add: refl_def)
 done
 
 lemma subset_Follows_comp:
 "\<lbrakk>mono1(A, r, B, s, h); refl(A, r); trans[B](s)\<rbrakk>
    \<Longrightarrow> Follows(A, r, f, g) \<subseteq> Follows(B, s,  h comp f, h comp g)"
 apply (unfold Follows_def, clarify)
 apply (frule_tac f = g in IncreasingD)
 apply (frule_tac f = f in IncreasingD)
 apply (rule IntI)
 apply (rule_tac [2] h = h in imp_LeadsTo_comp)
 prefer 5 apply assumption
 apply (auto intro: imp_Increasing_comp imp_Always_comp simp del: INT_simps)
 done
 
 lemma imp_Follows_comp:
 "\<lbrakk>F \<in> Follows(A, r, f, g);  mono1(A, r, B, s, h); refl(A, r); trans[B](s)\<rbrakk>
   \<Longrightarrow>  F \<in> Follows(B, s,  h comp f, h comp g)"
 apply (blast intro: subset_Follows_comp [THEN subsetD])
 done
 
 (* 2-place monotone operation \<in> this general result is used to prove Follows_Un, Follows_munion *)
 
 (* 2-place monotone operation \<in> this general result is
    used to prove Follows_Un, Follows_munion *)
 lemma imp_Follows_comp2:
 "\<lbrakk>F \<in> Follows(A, r, f1, f);  F \<in> Follows(B, s, g1, g);
    mono2(A, r, B, s, C, t, h); refl(A,r); refl(B, s); trans[C](t)\<rbrakk>
    \<Longrightarrow> F \<in> Follows(C, t, \<lambda>x. h(f1(x), g1(x)), \<lambda>x. h(f(x), g(x)))"
 apply (unfold Follows_def, clarify)
 apply (frule_tac f = g in IncreasingD)
 apply (frule_tac f = f in IncreasingD)
 apply (rule IntI, safe)
 apply (rule_tac [3] h = h in imp_Always_comp2)
 prefer 5 apply assumption
 apply (rule_tac [2] h = h in imp_Increasing_comp2)
 prefer 4 apply assumption
 apply (rule_tac h = h in imp_Increasing_comp2)
 prefer 3 apply assumption
 apply simp_all
 apply (blast dest!: IncreasingD)
 apply (rule_tac h = h in imp_LeadsTo_comp2)
 prefer 4 apply assumption
 apply auto
   prefer 3 apply (simp add: mono2_def)
 apply (blast dest: IncreasingD)+
 done
 
 
 lemma Follows_trans:
      "\<lbrakk>F \<in> Follows(A, r, f, g);  F \<in> Follows(A,r, g, h);
          trans[A](r)\<rbrakk> \<Longrightarrow> F \<in> Follows(A, r, f, h)"
 apply (frule_tac f = f in FollowsD)
 apply (frule_tac f = g in FollowsD)
 apply (simp add: Follows_def)
 apply (simp add: Always_eq_includes_reachable INT_iff, auto)
 apply (rule_tac [2] B = "{s \<in> state. <k, g (s) > \<in> r}" in LeadsTo_Trans)
 apply (rule_tac b = "g (x) " in trans_onD)
 apply blast+
 done
 
 (** Destruction rules for Follows **)
 
 lemma Follows_imp_Increasing_left:
      "F \<in> Follows(A, r, f,g) \<Longrightarrow> F \<in> Increasing(A, r, f)"
 by (unfold Follows_def, blast)
 
 lemma Follows_imp_Increasing_right:
      "F \<in> Follows(A, r, f,g) \<Longrightarrow> F \<in> Increasing(A, r, g)"
 by (unfold Follows_def, blast)
 
 lemma Follows_imp_Always:
  "F :Follows(A, r, f, g) \<Longrightarrow> F \<in> Always({s \<in> state. <f(s),g(s)> \<in> r})"
 by (unfold Follows_def, blast)
 
 lemma Follows_imp_LeadsTo:
  "\<lbrakk>F \<in> Follows(A, r, f, g); k \<in> A\<rbrakk>  \<Longrightarrow>
   F: {s \<in> state. <k,g(s)> \<in> r } \<longmapsto>w {s \<in> state. <k,f(s)> \<in> r}"
 by (unfold Follows_def, blast)
 
 lemma Follows_LeadsTo_pfixLe:
      "\<lbrakk>F \<in> Follows(list(nat), gen_prefix(nat, Le), f, g); k \<in> list(nat)\<rbrakk>
    \<Longrightarrow> F \<in> {s \<in> state. k pfixLe g(s)} \<longmapsto>w {s \<in> state. k pfixLe f(s)}"
 by (blast intro: Follows_imp_LeadsTo)
 
 lemma Follows_LeadsTo_pfixGe:
      "\<lbrakk>F \<in> Follows(list(nat), gen_prefix(nat, Ge), f, g); k \<in> list(nat)\<rbrakk>
    \<Longrightarrow> F \<in> {s \<in> state. k pfixGe g(s)} \<longmapsto>w {s \<in> state. k pfixGe f(s)}"
 by (blast intro: Follows_imp_LeadsTo)
 
 lemma Always_Follows1:
 "\<lbrakk>F \<in> Always({s \<in> state. f(s) = g(s)}); F \<in> Follows(A, r, f, h);
     \<forall>x \<in> state. g(x):A\<rbrakk> \<Longrightarrow> F \<in> Follows(A, r, g, h)"
-apply (unfold Follows_def Increasing_def Stable_def)
+  unfolding Follows_def Increasing_def Stable_def
 apply (simp add: INT_iff, auto)
 apply (rule_tac [3] C = "{s \<in> state. f(s)=g(s)}"
         and A = "{s \<in> state. <k, h (s)> \<in> r}"
         and A' = "{s \<in> state. <k, f(s)> \<in> r}" in Always_LeadsTo_weaken)
 apply (erule_tac A = "{s \<in> state. <k,f(s) > \<in> r}"
            and A' = "{s \<in> state. <k,f(s) > \<in> r}" in Always_Constrains_weaken)
 apply auto
 apply (drule Always_Int_I, assumption)
 apply (erule_tac A = "{s \<in> state. f(s)=g(s)} \<inter> {s \<in> state. <f(s), h(s)> \<in> r}"
        in Always_weaken)
 apply auto
 done
 
 
 lemma Always_Follows2:
 "\<lbrakk>F \<in> Always({s \<in> state. g(s) = h(s)});
   F \<in> Follows(A, r, f, g); \<forall>x \<in> state. h(x):A\<rbrakk> \<Longrightarrow> F \<in> Follows(A, r, f, h)"
-apply (unfold Follows_def Increasing_def Stable_def)
+  unfolding Follows_def Increasing_def Stable_def
 apply (simp add: INT_iff, auto)
 apply (rule_tac [3] C = "{s \<in> state. g (s) =h (s) }"
             and A = "{s \<in> state. <k, g (s) > \<in> r}"
             and A' = "{s \<in> state. <k, f (s) > \<in> r}" in Always_LeadsTo_weaken)
 apply (erule_tac A = "{s \<in> state. <k, g(s)> \<in> r}"
          and A' = "{s \<in> state. <k, g(s)> \<in> r}" in Always_Constrains_weaken)
 apply auto
 apply (drule Always_Int_I, assumption)
 apply (erule_tac A = "{s \<in> state. g(s)=h(s)} \<inter> {s \<in> state. <f(s), g(s)> \<in> r}"
        in Always_weaken)
 apply auto
 done
 
 (** Union properties (with the subset ordering) **)
 
 lemma refl_SetLe [simp]: "refl(Pow(A), SetLe(A))"
 by (unfold refl_def SetLe_def, auto)
 
 lemma trans_on_SetLe [simp]: "trans[Pow(A)](SetLe(A))"
 by (unfold trans_on_def SetLe_def, auto)
 
 lemma antisym_SetLe [simp]: "antisym(SetLe(A))"
 by (unfold antisym_def SetLe_def, auto)
 
 lemma part_order_SetLe [simp]: "part_order(Pow(A), SetLe(A))"
 by (unfold part_order_def, auto)
 
 lemma increasing_Un:
      "\<lbrakk>F \<in> Increasing.increasing(Pow(A), SetLe(A), f);
          F \<in> Increasing.increasing(Pow(A), SetLe(A), g)\<rbrakk>
      \<Longrightarrow> F \<in> Increasing.increasing(Pow(A), SetLe(A), \<lambda>x. f(x) \<union> g(x))"
 by (rule_tac h = "(Un)" in imp_increasing_comp2, auto)
 
 lemma Increasing_Un:
      "\<lbrakk>F \<in> Increasing(Pow(A), SetLe(A), f);
          F \<in> Increasing(Pow(A), SetLe(A), g)\<rbrakk>
      \<Longrightarrow> F \<in> Increasing(Pow(A), SetLe(A), \<lambda>x. f(x) \<union> g(x))"
 by (rule_tac h = "(Un)" in imp_Increasing_comp2, auto)
 
 lemma Always_Un:
      "\<lbrakk>F \<in> Always({s \<in> state. f1(s) \<subseteq> f(s)});
      F \<in> Always({s \<in> state. g1(s) \<subseteq> g(s)})\<rbrakk>
       \<Longrightarrow> F \<in> Always({s \<in> state. f1(s) \<union> g1(s) \<subseteq> f(s) \<union> g(s)})"
 by (simp add: Always_eq_includes_reachable, blast)
 
 lemma Follows_Un:
 "\<lbrakk>F \<in> Follows(Pow(A), SetLe(A), f1, f);
      F \<in> Follows(Pow(A), SetLe(A), g1, g)\<rbrakk>
      \<Longrightarrow> F \<in> Follows(Pow(A), SetLe(A), \<lambda>s. f1(s) \<union> g1(s), \<lambda>s. f(s) \<union> g(s))"
 by (rule_tac h = "(Un)" in imp_Follows_comp2, auto)
 
 (** Multiset union properties (with the MultLe ordering) **)
 
 lemma refl_MultLe [simp]: "refl(Mult(A), MultLe(A,r))"
 by (unfold MultLe_def refl_def, auto)
 
 lemma MultLe_refl1 [simp]:
  "\<lbrakk>multiset(M); mset_of(M)<=A\<rbrakk> \<Longrightarrow> \<langle>M, M\<rangle> \<in> MultLe(A, r)"
-apply (unfold MultLe_def id_def lam_def)
+  unfolding MultLe_def id_def lam_def
 apply (auto simp add: Mult_iff_multiset)
 done
 
 lemma MultLe_refl2 [simp]: "M \<in> Mult(A) \<Longrightarrow> \<langle>M, M\<rangle> \<in> MultLe(A, r)"
 by (unfold MultLe_def id_def lam_def, auto)
 
 
 lemma trans_on_MultLe [simp]: "trans[Mult(A)](MultLe(A,r))"
-apply (unfold MultLe_def trans_on_def)
+  unfolding MultLe_def trans_on_def
 apply (auto intro: trancl_trans simp add: multirel_def)
 done
 
 lemma MultLe_type: "MultLe(A, r)<= (Mult(A) * Mult(A))"
 apply (unfold MultLe_def, auto)
 apply (drule multirel_type [THEN subsetD], auto)
 done
 
 lemma MultLe_trans:
      "\<lbrakk>\<langle>M,K\<rangle> \<in> MultLe(A,r); \<langle>K,N\<rangle> \<in> MultLe(A,r)\<rbrakk> \<Longrightarrow> \<langle>M,N\<rangle> \<in> MultLe(A,r)"
 apply (cut_tac A=A in trans_on_MultLe)
 apply (drule trans_onD, assumption)
 apply (auto dest: MultLe_type [THEN subsetD])
 done
 
 lemma part_order_imp_part_ord:
      "part_order(A, r) \<Longrightarrow> part_ord(A, r-id(A))"
-apply (unfold part_order_def part_ord_def)
+  unfolding part_order_def part_ord_def
 apply (simp add: refl_def id_def lam_def irrefl_def, auto)
 apply (simp (no_asm) add: trans_on_def)
 apply auto
 apply (blast dest: trans_onD)
 apply (simp (no_asm_use) add: antisym_def)
 apply auto
 done
 
 lemma antisym_MultLe [simp]:
   "part_order(A, r) \<Longrightarrow> antisym(MultLe(A,r))"
-apply (unfold MultLe_def antisym_def)
+  unfolding MultLe_def antisym_def
 apply (drule part_order_imp_part_ord, auto)
 apply (drule irrefl_on_multirel)
 apply (frule multirel_type [THEN subsetD])
 apply (drule multirel_trans)
 apply (auto simp add: irrefl_def)
 done
 
 lemma part_order_MultLe [simp]:
      "part_order(A, r) \<Longrightarrow>  part_order(Mult(A), MultLe(A, r))"
 apply (frule antisym_MultLe)
 apply (auto simp add: part_order_def)
 done
 
 lemma empty_le_MultLe [simp]:
 "\<lbrakk>multiset(M); mset_of(M)<= A\<rbrakk> \<Longrightarrow> \<langle>0, M\<rangle> \<in> MultLe(A, r)"
   unfolding MultLe_def
 apply (case_tac "M=0")
 apply (auto simp add: FiniteFun.intros)
 apply (subgoal_tac "<0 +# 0, 0 +# M> \<in> multirel (A, r - id (A))")
 apply (rule_tac [2] one_step_implies_multirel)
 apply (auto simp add: Mult_iff_multiset)
 done
 
 lemma empty_le_MultLe2 [simp]: "M \<in> Mult(A) \<Longrightarrow> \<langle>0, M\<rangle> \<in> MultLe(A, r)"
 by (simp add: Mult_iff_multiset)
 
 lemma munion_mono:
 "\<lbrakk>\<langle>M, N\<rangle> \<in> MultLe(A, r); \<langle>K, L\<rangle> \<in> MultLe(A, r)\<rbrakk> \<Longrightarrow>
   <M +# K, N +# L> \<in> MultLe(A, r)"
   unfolding MultLe_def
 apply (auto intro: munion_multirel_mono1 munion_multirel_mono2
        munion_multirel_mono multiset_into_Mult simp add: Mult_iff_multiset)
 done
 
 lemma increasing_munion:
      "\<lbrakk>F \<in> Increasing.increasing(Mult(A), MultLe(A,r), f);
          F \<in> Increasing.increasing(Mult(A), MultLe(A,r), g)\<rbrakk>
      \<Longrightarrow> F \<in> Increasing.increasing(Mult(A),MultLe(A,r), \<lambda>x. f(x) +# g(x))"
 by (rule_tac h = munion in imp_increasing_comp2, auto)
 
 lemma Increasing_munion:
      "\<lbrakk>F \<in> Increasing(Mult(A), MultLe(A,r), f);
          F \<in> Increasing(Mult(A), MultLe(A,r), g)\<rbrakk>
      \<Longrightarrow> F \<in> Increasing(Mult(A),MultLe(A,r), \<lambda>x. f(x) +# g(x))"
 by (rule_tac h = munion in imp_Increasing_comp2, auto)
 
 lemma Always_munion:
 "\<lbrakk>F \<in> Always({s \<in> state. <f1(s),f(s)> \<in> MultLe(A,r)});
           F \<in> Always({s \<in> state. <g1(s), g(s)> \<in> MultLe(A,r)});
   \<forall>x \<in> state. f1(x):Mult(A)\<and>f(x):Mult(A) \<and> g1(x):Mult(A) \<and> g(x):Mult(A)\<rbrakk>
       \<Longrightarrow> F \<in> Always({s \<in> state. <f1(s) +# g1(s), f(s) +# g(s)> \<in> MultLe(A,r)})"
 apply (rule_tac h = munion in imp_Always_comp2, simp_all)
 apply (blast intro: munion_mono, simp_all)
 done
 
 lemma Follows_munion:
 "\<lbrakk>F \<in> Follows(Mult(A), MultLe(A, r), f1, f);
     F \<in> Follows(Mult(A), MultLe(A, r), g1, g)\<rbrakk>
   \<Longrightarrow> F \<in> Follows(Mult(A), MultLe(A, r), \<lambda>s. f1(s) +# g1(s), \<lambda>s. f(s) +# g(s))"
 by (rule_tac h = munion in imp_Follows_comp2, auto)
 
 (** Used in ClientImp **)
 
 lemma Follows_msetsum_UN:
 "\<And>f. \<lbrakk>\<forall>i \<in> I. F \<in> Follows(Mult(A), MultLe(A, r), f'(i), f(i));
   \<forall>s. \<forall>i \<in> I. multiset(f'(i, s)) \<and> mset_of(f'(i, s))<=A \<and>
                         multiset(f(i, s)) \<and> mset_of(f(i, s))<=A ;
    Finite(I); F \<in> program\<rbrakk>
         \<Longrightarrow> F \<in> Follows(Mult(A),
                         MultLe(A, r), \<lambda>x. msetsum(\<lambda>i. f'(i, x), I, A),
                                       \<lambda>x. msetsum(\<lambda>i. f(i,  x), I, A))"
 apply (erule rev_mp)
 apply (drule Finite_into_Fin)
 apply (erule Fin_induct)
 apply (simp (no_asm_simp))
 apply (rule Follows_constantI)
 apply (simp_all (no_asm_simp) add: FiniteFun.intros)
 apply auto
 apply (rule Follows_munion, auto)
 done
 
 end
diff --git a/src/ZF/UNITY/GenPrefix.thy b/src/ZF/UNITY/GenPrefix.thy
--- a/src/ZF/UNITY/GenPrefix.thy
+++ b/src/ZF/UNITY/GenPrefix.thy
@@ -1,680 +1,680 @@
 (*  Title:      ZF/UNITY/GenPrefix.thy
     Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
     Copyright   2001  University of Cambridge
 
 \<langle>xs,ys\<rangle>:gen_prefix(r)
   if ys = xs' @ zs where length(xs) = length(xs')
   and corresponding elements of xs, xs' are pairwise related by r
 
 Based on Lex/Prefix
 *)
 
 section\<open>Charpentier's Generalized Prefix Relation\<close>
 
 theory GenPrefix
 imports ZF
 begin
 
 definition (*really belongs in ZF/Trancl*)
   part_order :: "[i, i] \<Rightarrow> o"  where
   "part_order(A, r) \<equiv> refl(A,r) \<and> trans[A](r) \<and> antisym(r)"
 
 consts
   gen_prefix :: "[i, i] \<Rightarrow> i"
 
 inductive
   (* Parameter A is the domain of zs's elements *)
 
   domains "gen_prefix(A, r)" \<subseteq> "list(A)*list(A)"
 
   intros
     Nil:     "<[],[]>:gen_prefix(A, r)"
 
     prepend: "\<lbrakk>\<langle>xs,ys\<rangle>:gen_prefix(A, r);  \<langle>x,y\<rangle>:r; x \<in> A; y \<in> A\<rbrakk>
               \<Longrightarrow> <Cons(x,xs), Cons(y,ys)>: gen_prefix(A, r)"
 
     append:  "\<lbrakk>\<langle>xs,ys\<rangle>:gen_prefix(A, r); zs:list(A)\<rbrakk>
               \<Longrightarrow> <xs, ys@zs>:gen_prefix(A, r)"
     type_intros app_type list.Nil list.Cons
 
 definition
   prefix :: "i\<Rightarrow>i"  where
   "prefix(A) \<equiv> gen_prefix(A, id(A))"
 
 definition
   strict_prefix :: "i\<Rightarrow>i"  where
   "strict_prefix(A) \<equiv> prefix(A) - id(list(A))"
 
 
 (* less or equal and greater or equal over prefixes *)
 
 abbreviation
   pfixLe :: "[i, i] \<Rightarrow> o"  (infixl \<open>pfixLe\<close> 50)  where
   "xs pfixLe ys \<equiv> \<langle>xs, ys\<rangle>:gen_prefix(nat, Le)"
 
 abbreviation
   pfixGe :: "[i, i] \<Rightarrow> o"  (infixl \<open>pfixGe\<close> 50)  where
   "xs pfixGe ys \<equiv> \<langle>xs, ys\<rangle>:gen_prefix(nat, Ge)"
 
 
 lemma reflD:
  "\<lbrakk>refl(A, r); x \<in> A\<rbrakk> \<Longrightarrow> \<langle>x,x\<rangle>:r"
 apply (unfold refl_def, auto)
 done
 
 (*** preliminary lemmas ***)
 
 lemma Nil_gen_prefix: "xs \<in> list(A) \<Longrightarrow> <[], xs> \<in> gen_prefix(A, r)"
 by (drule gen_prefix.append [OF gen_prefix.Nil], simp)
 declare Nil_gen_prefix [simp]
 
 
 lemma gen_prefix_length_le: "\<langle>xs,ys\<rangle> \<in> gen_prefix(A, r) \<Longrightarrow> length(xs) \<le> length(ys)"
 apply (erule gen_prefix.induct)
 apply (subgoal_tac [3] "ys \<in> list (A) ")
 apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
             intro: le_trans simp add: length_app)
 done
 
 
 lemma Cons_gen_prefix_aux:
   "\<lbrakk><xs', ys'> \<in> gen_prefix(A, r)\<rbrakk>
    \<Longrightarrow> (\<forall>x xs. x \<in> A \<longrightarrow> xs'= Cons(x,xs) \<longrightarrow>
        (\<exists>y ys. y \<in> A \<and> ys' = Cons(y,ys) \<and>
        \<langle>x,y\<rangle>:r \<and> \<langle>xs, ys\<rangle> \<in> gen_prefix(A, r)))"
 apply (erule gen_prefix.induct)
 prefer 3 apply (force intro: gen_prefix.append, auto)
 done
 
 lemma Cons_gen_prefixE:
   "\<lbrakk><Cons(x,xs), zs> \<in> gen_prefix(A, r);
     \<And>y ys. \<lbrakk>zs = Cons(y, ys); y \<in> A; x \<in> A; \<langle>x,y\<rangle>:r;
       \<langle>xs,ys\<rangle> \<in> gen_prefix(A, r)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
 apply (frule gen_prefix.dom_subset [THEN subsetD], auto)
 apply (blast dest: Cons_gen_prefix_aux)
 done
 declare Cons_gen_prefixE [elim!]
 
 lemma Cons_gen_prefix_Cons:
 "(<Cons(x,xs),Cons(y,ys)> \<in> gen_prefix(A, r))
   \<longleftrightarrow> (x \<in> A \<and> y \<in> A \<and> \<langle>x,y\<rangle>:r \<and> \<langle>xs,ys\<rangle> \<in> gen_prefix(A, r))"
 apply (auto intro: gen_prefix.prepend)
 done
 declare Cons_gen_prefix_Cons [iff]
 
 (** Monotonicity of gen_prefix **)
 
 lemma gen_prefix_mono2: "r<=s \<Longrightarrow> gen_prefix(A, r) \<subseteq> gen_prefix(A, s)"
 apply clarify
 apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
 apply (erule rev_mp)
 apply (erule gen_prefix.induct)
 apply (auto intro: gen_prefix.append)
 done
 
 lemma gen_prefix_mono1: "A<=B \<Longrightarrow>gen_prefix(A, r) \<subseteq> gen_prefix(B, r)"
 apply clarify
 apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
 apply (erule rev_mp)
 apply (erule_tac P = "y \<in> list (A) " in rev_mp)
 apply (erule_tac P = "xa \<in> list (A) " in rev_mp)
 apply (erule gen_prefix.induct)
 apply (simp (no_asm_simp))
 apply clarify
 apply (erule ConsE)+
 apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
             intro: gen_prefix.append list_mono [THEN subsetD])
 done
 
 lemma gen_prefix_mono: "\<lbrakk>A \<subseteq> B; r \<subseteq> s\<rbrakk> \<Longrightarrow> gen_prefix(A, r) \<subseteq> gen_prefix(B, s)"
 apply (rule subset_trans)
 apply (rule gen_prefix_mono1)
 apply (rule_tac [2] gen_prefix_mono2, auto)
 done
 
 (*** gen_prefix order ***)
 
 (* reflexivity *)
 lemma refl_gen_prefix: "refl(A, r) \<Longrightarrow> refl(list(A), gen_prefix(A, r))"
 apply (unfold refl_def, auto)
 apply (induct_tac "x", auto)
 done
 declare refl_gen_prefix [THEN reflD, simp]
 
 (* Transitivity *)
 (* A lemma for proving gen_prefix_trans_comp *)
 
 lemma append_gen_prefix [rule_format (no_asm)]: "xs \<in> list(A) \<Longrightarrow>
    \<forall>zs. <xs @ ys, zs> \<in> gen_prefix(A, r) \<longrightarrow> \<langle>xs, zs\<rangle>: gen_prefix(A, r)"
 apply (erule list.induct)
 apply (auto dest: gen_prefix.dom_subset [THEN subsetD])
 done
 
 (* Lemma proving transitivity and more*)
 
 lemma gen_prefix_trans_comp [rule_format (no_asm)]:
      "\<langle>x, y\<rangle>: gen_prefix(A, r) \<Longrightarrow>
    (\<forall>z \<in> list(A). \<langle>y,z\<rangle> \<in> gen_prefix(A, s)\<longrightarrow>\<langle>x, z\<rangle> \<in> gen_prefix(A, s O r))"
 apply (erule gen_prefix.induct)
 apply (auto elim: ConsE simp add: Nil_gen_prefix)
 apply (subgoal_tac "ys \<in> list (A) ")
 prefer 2 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
 apply (drule_tac xs = ys and r = s in append_gen_prefix, auto)
 done
 
 lemma trans_comp_subset: "trans(r) \<Longrightarrow> r O r \<subseteq> r"
 by (auto dest: transD)
 
 lemma trans_gen_prefix: "trans(r) \<Longrightarrow> trans(gen_prefix(A,r))"
 apply (simp (no_asm) add: trans_def)
 apply clarify
 apply (rule trans_comp_subset [THEN gen_prefix_mono2, THEN subsetD], assumption)
 apply (rule gen_prefix_trans_comp)
 apply (auto dest: gen_prefix.dom_subset [THEN subsetD])
 done
 
 lemma trans_on_gen_prefix:
  "trans(r) \<Longrightarrow> trans[list(A)](gen_prefix(A, r))"
 apply (drule_tac A = A in trans_gen_prefix)
 apply (unfold trans_def trans_on_def, blast)
 done
 
 lemma prefix_gen_prefix_trans:
     "\<lbrakk>\<langle>x,y\<rangle> \<in> prefix(A); \<langle>y, z\<rangle> \<in> gen_prefix(A, r); r<=A*A\<rbrakk>
       \<Longrightarrow>  \<langle>x, z\<rangle> \<in> gen_prefix(A, r)"
   unfolding prefix_def
 apply (rule_tac P = "\<lambda>r. \<langle>x,z\<rangle> \<in> gen_prefix (A, r) " in right_comp_id [THEN subst])
 apply (blast dest: gen_prefix_trans_comp gen_prefix.dom_subset [THEN subsetD])+
 done
 
 
 lemma gen_prefix_prefix_trans:
 "\<lbrakk>\<langle>x,y\<rangle> \<in> gen_prefix(A,r); \<langle>y, z\<rangle> \<in> prefix(A); r<=A*A\<rbrakk>
   \<Longrightarrow>  \<langle>x, z\<rangle> \<in> gen_prefix(A, r)"
   unfolding prefix_def
 apply (rule_tac P = "\<lambda>r. \<langle>x,z\<rangle> \<in> gen_prefix (A, r) " in left_comp_id [THEN subst])
 apply (blast dest: gen_prefix_trans_comp gen_prefix.dom_subset [THEN subsetD])+
 done
 
 (** Antisymmetry **)
 
 lemma nat_le_lemma [rule_format]: "n \<in> nat \<Longrightarrow> \<forall>b \<in> nat. n #+ b \<le> n \<longrightarrow> b = 0"
 by (induct_tac "n", auto)
 
 lemma antisym_gen_prefix: "antisym(r) \<Longrightarrow> antisym(gen_prefix(A, r))"
 apply (simp (no_asm) add: antisym_def)
 apply (rule impI [THEN allI, THEN allI])
 apply (erule gen_prefix.induct, blast)
 apply (simp add: antisym_def, blast)
 txt\<open>append case is hardest\<close>
 apply clarify
 apply (subgoal_tac "length (zs) = 0")
 apply (subgoal_tac "ys \<in> list (A) ")
 prefer 2 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
 apply (drule_tac psi = "<ys @ zs, xs> \<in> gen_prefix (A,r) " in asm_rl)
 apply simp
 apply (subgoal_tac "length (ys @ zs) = length (ys) #+ length (zs) \<and>ys \<in> list (A) \<and>xs \<in> list (A) ")
 prefer 2 apply (blast intro: length_app dest: gen_prefix.dom_subset [THEN subsetD])
 apply (drule gen_prefix_length_le)+
 apply clarify
 apply simp
 apply (drule_tac j = "length (xs) " in le_trans)
 apply blast
 apply (auto intro: nat_le_lemma)
 done
 
 (*** recursion equations ***)
 
 lemma gen_prefix_Nil: "xs \<in> list(A) \<Longrightarrow> <xs, []> \<in> gen_prefix(A,r) \<longleftrightarrow> (xs = [])"
 by (induct_tac "xs", auto)
 declare gen_prefix_Nil [simp]
 
 lemma same_gen_prefix_gen_prefix:
  "\<lbrakk>refl(A, r);  xs \<in> list(A)\<rbrakk> \<Longrightarrow>
     <xs@ys, xs@zs>: gen_prefix(A, r) \<longleftrightarrow> \<langle>ys,zs\<rangle> \<in> gen_prefix(A, r)"
   unfolding refl_def
 apply (induct_tac "xs")
 apply (simp_all (no_asm_simp))
 done
 declare same_gen_prefix_gen_prefix [simp]
 
 lemma gen_prefix_Cons: "\<lbrakk>xs \<in> list(A); ys \<in> list(A); y \<in> A\<rbrakk> \<Longrightarrow>
     <xs, Cons(y,ys)> \<in> gen_prefix(A,r)  \<longleftrightarrow>
       (xs=[] | (\<exists>z zs. xs=Cons(z,zs) \<and> z \<in> A \<and> \<langle>z,y\<rangle>:r \<and> \<langle>zs,ys\<rangle> \<in> gen_prefix(A,r)))"
 apply (induct_tac "xs", auto)
 done
 
 lemma gen_prefix_take_append: "\<lbrakk>refl(A,r);  \<langle>xs,ys\<rangle> \<in> gen_prefix(A, r); zs \<in> list(A)\<rbrakk>
       \<Longrightarrow>  <xs@zs, take(length(xs), ys) @ zs> \<in> gen_prefix(A, r)"
 apply (erule gen_prefix.induct)
 apply (simp (no_asm_simp))
 apply (frule_tac [!] gen_prefix.dom_subset [THEN subsetD], auto)
 apply (frule gen_prefix_length_le)
 apply (subgoal_tac "take (length (xs), ys) \<in> list (A) ")
 apply (simp_all (no_asm_simp) add: diff_is_0_iff [THEN iffD2] take_type)
 done
 
 lemma gen_prefix_append_both: "\<lbrakk>refl(A, r);  \<langle>xs,ys\<rangle> \<in> gen_prefix(A,r);
          length(xs) = length(ys); zs \<in> list(A)\<rbrakk>
       \<Longrightarrow>  <xs@zs, ys @ zs> \<in> gen_prefix(A, r)"
 apply (drule_tac zs = zs in gen_prefix_take_append, assumption+)
 apply (subgoal_tac "take (length (xs), ys) =ys")
 apply (auto intro!: take_all dest: gen_prefix.dom_subset [THEN subsetD])
 done
 
 (*NOT suitable for rewriting since [y] has the form y#ys*)
 lemma append_cons_conv: "xs \<in> list(A) \<Longrightarrow> xs @ Cons(y, ys) = (xs @ [y]) @ ys"
 by (auto simp add: app_assoc)
 
 lemma append_one_gen_prefix_lemma [rule_format]:
      "\<lbrakk>\<langle>xs,ys\<rangle> \<in> gen_prefix(A, r);  refl(A, r)\<rbrakk>
       \<Longrightarrow> length(xs) < length(ys) \<longrightarrow>
           <xs @ [nth(length(xs), ys)], ys> \<in> gen_prefix(A, r)"
 apply (erule gen_prefix.induct, blast)
 apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
 apply (simp_all add: length_type)
 (* Append case is hardest *)
 apply (frule gen_prefix_length_le [THEN le_iff [THEN iffD1]])
 apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
 apply (subgoal_tac "length (xs) :nat\<and>length (ys) :nat \<and>length (zs) :nat")
 prefer 2 apply (blast intro: length_type, clarify)
 apply (simp_all add: nth_append length_type length_app)
 apply (rule conjI)
 apply (blast intro: gen_prefix.append)
 apply (erule_tac V = "length (xs) < length (ys) \<longrightarrow>u" for u in thin_rl)
 apply (erule_tac a = zs in list.cases, auto)
 apply (rule_tac P1 = "\<lambda>x. <u(x), v>:w" for u v w in nat_diff_split [THEN iffD2])
 apply auto
 apply (simplesubst append_cons_conv)
 apply (rule_tac [2] gen_prefix.append)
 apply (auto elim: ConsE simp add: gen_prefix_append_both)
 done
 
 lemma append_one_gen_prefix: "\<lbrakk>\<langle>xs,ys\<rangle>: gen_prefix(A, r);  length(xs) < length(ys);  refl(A, r)\<rbrakk>
       \<Longrightarrow> <xs @ [nth(length(xs), ys)], ys> \<in> gen_prefix(A, r)"
 apply (blast intro: append_one_gen_prefix_lemma)
 done
 
 
 (** Proving the equivalence with Charpentier's definition **)
 
 lemma gen_prefix_imp_nth_lemma [rule_format]: "xs \<in> list(A) \<Longrightarrow>
   \<forall>ys \<in> list(A). \<forall>i \<in> nat. i < length(xs)
           \<longrightarrow> \<langle>xs, ys\<rangle>: gen_prefix(A, r) \<longrightarrow> <nth(i, xs), nth(i, ys)>:r"
 apply (induct_tac "xs", simp, clarify)
 apply simp
 apply (erule natE, auto)
 done
 
 lemma gen_prefix_imp_nth: "\<lbrakk>\<langle>xs,ys\<rangle> \<in> gen_prefix(A,r); i < length(xs)\<rbrakk>
       \<Longrightarrow> <nth(i, xs), nth(i, ys)>:r"
 apply (cut_tac A = A in gen_prefix.dom_subset)
 apply (rule gen_prefix_imp_nth_lemma)
 apply (auto simp add: lt_nat_in_nat)
 done
 
 lemma nth_imp_gen_prefix [rule_format]: "xs \<in> list(A) \<Longrightarrow>
   \<forall>ys \<in> list(A). length(xs) \<le> length(ys)
       \<longrightarrow> (\<forall>i. i < length(xs) \<longrightarrow> <nth(i, xs), nth(i,ys)>:r)
       \<longrightarrow> \<langle>xs, ys\<rangle> \<in> gen_prefix(A, r)"
 apply (induct_tac "xs")
 apply (simp_all (no_asm_simp))
 apply clarify
 apply (erule_tac a = ys in list.cases, simp)
 apply (force intro!: nat_0_le simp add: lt_nat_in_nat)
 done
 
 lemma gen_prefix_iff_nth: "(\<langle>xs,ys\<rangle> \<in> gen_prefix(A,r)) \<longleftrightarrow>
       (xs \<in> list(A) \<and> ys \<in> list(A) \<and> length(xs) \<le> length(ys) \<and>
       (\<forall>i. i < length(xs) \<longrightarrow> <nth(i,xs), nth(i, ys)>: r))"
 apply (rule iffI)
 apply (frule gen_prefix.dom_subset [THEN subsetD])
 apply (frule gen_prefix_length_le, auto)
 apply (rule_tac [2] nth_imp_gen_prefix)
 apply (drule gen_prefix_imp_nth)
 apply (auto simp add: lt_nat_in_nat)
 done
 
 (** prefix is a partial order: **)
 
 lemma refl_prefix: "refl(list(A), prefix(A))"
   unfolding prefix_def
 apply (rule refl_gen_prefix)
 apply (auto simp add: refl_def)
 done
 declare refl_prefix [THEN reflD, simp]
 
 lemma trans_prefix: "trans(prefix(A))"
   unfolding prefix_def
 apply (rule trans_gen_prefix)
 apply (auto simp add: trans_def)
 done
 
 lemmas prefix_trans = trans_prefix [THEN transD]
 
 lemma trans_on_prefix: "trans[list(A)](prefix(A))"
   unfolding prefix_def
 apply (rule trans_on_gen_prefix)
 apply (auto simp add: trans_def)
 done
 
 lemmas prefix_trans_on = trans_on_prefix [THEN trans_onD]
 
 (* Monotonicity of "set" operator WRT prefix *)
 
 lemma set_of_list_prefix_mono:
 "\<langle>xs,ys\<rangle> \<in> prefix(A) \<Longrightarrow> set_of_list(xs) \<subseteq> set_of_list(ys)"
 
   unfolding prefix_def
 apply (erule gen_prefix.induct)
 apply (subgoal_tac [3] "xs \<in> list (A) \<and>ys \<in> list (A) ")
 prefer 4 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
 apply (auto simp add: set_of_list_append)
 done
 
 (** recursion equations **)
 
 lemma Nil_prefix: "xs \<in> list(A) \<Longrightarrow> <[],xs> \<in> prefix(A)"
 
   unfolding prefix_def
 apply (simp (no_asm_simp) add: Nil_gen_prefix)
 done
 declare Nil_prefix [simp]
 
 
 lemma prefix_Nil: "<xs, []> \<in> prefix(A) \<longleftrightarrow> (xs = [])"
 
 apply (unfold prefix_def, auto)
 apply (frule gen_prefix.dom_subset [THEN subsetD])
 apply (drule_tac psi = "<xs, []> \<in> gen_prefix (A, id (A))" in asm_rl)
 apply (simp add: gen_prefix_Nil)
 done
 declare prefix_Nil [iff]
 
 lemma Cons_prefix_Cons:
 "<Cons(x,xs), Cons(y,ys)> \<in> prefix(A) \<longleftrightarrow> (x=y \<and> \<langle>xs,ys\<rangle> \<in> prefix(A) \<and> y \<in> A)"
 apply (unfold prefix_def, auto)
 done
 declare Cons_prefix_Cons [iff]
 
 lemma same_prefix_prefix:
 "xs \<in> list(A)\<Longrightarrow> <xs@ys,xs@zs> \<in> prefix(A) \<longleftrightarrow> (\<langle>ys,zs\<rangle> \<in> prefix(A))"
   unfolding prefix_def
 apply (subgoal_tac "refl (A,id (A))")
 apply (simp (no_asm_simp))
 apply (auto simp add: refl_def)
 done
 declare same_prefix_prefix [simp]
 
 lemma same_prefix_prefix_Nil: "xs \<in> list(A) \<Longrightarrow> <xs@ys,xs> \<in> prefix(A) \<longleftrightarrow> (<ys,[]> \<in> prefix(A))"
 apply (rule_tac P = "\<lambda>x. \<langle>u, x\<rangle>:v \<longleftrightarrow> w(x)" for u v w in app_right_Nil [THEN subst])
 apply (rule_tac [2] same_prefix_prefix, auto)
 done
 declare same_prefix_prefix_Nil [simp]
 
 lemma prefix_appendI:
 "\<lbrakk>\<langle>xs,ys\<rangle> \<in> prefix(A); zs \<in> list(A)\<rbrakk> \<Longrightarrow> <xs,ys@zs> \<in> prefix(A)"
   unfolding prefix_def
 apply (erule gen_prefix.append, assumption)
 done
 declare prefix_appendI [simp]
 
 lemma prefix_Cons:
 "\<lbrakk>xs \<in> list(A); ys \<in> list(A); y \<in> A\<rbrakk> \<Longrightarrow>
   <xs,Cons(y,ys)> \<in> prefix(A) \<longleftrightarrow>
   (xs=[] | (\<exists>zs. xs=Cons(y,zs) \<and> \<langle>zs,ys\<rangle> \<in> prefix(A)))"
   unfolding prefix_def
 apply (auto simp add: gen_prefix_Cons)
 done
 
 lemma append_one_prefix:
   "\<lbrakk>\<langle>xs,ys\<rangle> \<in> prefix(A); length(xs) < length(ys)\<rbrakk>
   \<Longrightarrow> <xs @ [nth(length(xs),ys)], ys> \<in> prefix(A)"
   unfolding prefix_def
 apply (subgoal_tac "refl (A, id (A))")
 apply (simp (no_asm_simp) add: append_one_gen_prefix)
 apply (auto simp add: refl_def)
 done
 
 lemma prefix_length_le:
 "\<langle>xs,ys\<rangle> \<in> prefix(A) \<Longrightarrow> length(xs) \<le> length(ys)"
   unfolding prefix_def
 apply (blast dest: gen_prefix_length_le)
 done
 
 lemma prefix_type: "prefix(A)<=list(A)*list(A)"
   unfolding prefix_def
 apply (blast intro!: gen_prefix.dom_subset)
 done
 
 lemma strict_prefix_type:
 "strict_prefix(A) \<subseteq> list(A)*list(A)"
   unfolding strict_prefix_def
 apply (blast intro!: prefix_type [THEN subsetD])
 done
 
 lemma strict_prefix_length_lt_aux:
      "\<langle>xs,ys\<rangle> \<in> prefix(A) \<Longrightarrow> xs\<noteq>ys \<longrightarrow> length(xs) < length(ys)"
   unfolding prefix_def
 apply (erule gen_prefix.induct, clarify)
 apply (subgoal_tac [!] "ys \<in> list(A) \<and> xs \<in> list(A)")
 apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
             simp add: length_type)
 apply (subgoal_tac "length (zs) =0")
 apply (drule_tac [2] not_lt_imp_le)
 apply (rule_tac [5] j = "length (ys) " in lt_trans2)
 apply auto
 done
 
 lemma strict_prefix_length_lt:
      "\<langle>xs,ys\<rangle>:strict_prefix(A) \<Longrightarrow> length(xs) < length(ys)"
   unfolding strict_prefix_def
 apply (rule strict_prefix_length_lt_aux [THEN mp])
 apply (auto dest: prefix_type [THEN subsetD])
 done
 
 (*Equivalence to the definition used in Lex/Prefix.thy*)
 lemma prefix_iff:
     "\<langle>xs,zs\<rangle> \<in> prefix(A) \<longleftrightarrow> (\<exists>ys \<in> list(A). zs = xs@ys) \<and> xs \<in> list(A)"
   unfolding prefix_def
 apply (auto simp add: gen_prefix_iff_nth lt_nat_in_nat nth_append nth_type app_type length_app)
 apply (subgoal_tac "drop (length (xs), zs) \<in> list (A) ")
 apply (rule_tac x = "drop (length (xs), zs) " in bexI)
 apply safe
  prefer 2 apply (simp add: length_type drop_type)
 apply (rule nth_equalityI)
 apply (simp_all (no_asm_simp) add: nth_append app_type drop_type length_app length_drop)
 apply (rule nat_diff_split [THEN iffD2], simp_all, clarify)
 apply (drule_tac i = "length (zs) " in leI)
 apply (force simp add: le_subset_iff, safe)
 apply (subgoal_tac "length (xs) #+ (i #- length (xs)) = i")
 apply (subst nth_drop)
 apply (simp_all (no_asm_simp) add: leI split: nat_diff_split)
 done
 
 lemma prefix_snoc:
 "\<lbrakk>xs \<in> list(A); ys \<in> list(A); y \<in> A\<rbrakk> \<Longrightarrow>
    <xs, ys@[y]> \<in> prefix(A) \<longleftrightarrow> (xs = ys@[y] | \<langle>xs,ys\<rangle> \<in> prefix(A))"
 apply (simp (no_asm) add: prefix_iff)
 apply (rule iffI, clarify)
 apply (erule_tac xs = ysa in rev_list_elim, simp)
 apply (simp add: app_type app_assoc [symmetric])
 apply (auto simp add: app_assoc app_type)
 done
 declare prefix_snoc [simp]
 
 lemma prefix_append_iff [rule_format]: "zs \<in> list(A) \<Longrightarrow> \<forall>xs \<in> list(A). \<forall>ys \<in> list(A).
    (<xs, ys@zs> \<in> prefix(A)) \<longleftrightarrow>
   (\<langle>xs,ys\<rangle> \<in> prefix(A) | (\<exists>us. xs = ys@us \<and> \<langle>us,zs\<rangle> \<in> prefix(A)))"
 apply (erule list_append_induct, force, clarify)
 apply (rule iffI)
 apply (simp add: add: app_assoc [symmetric])
 apply (erule disjE)
 apply (rule disjI2)
 apply (rule_tac x = "y @ [x]" in exI)
 apply (simp add: add: app_assoc [symmetric], force+)
 done
 
 
 (*Although the prefix ordering is not linear, the prefixes of a list
   are linearly ordered.*)
 lemma common_prefix_linear_lemma [rule_format]: "\<lbrakk>zs \<in> list(A); xs \<in> list(A); ys \<in> list(A)\<rbrakk>
    \<Longrightarrow> \<langle>xs, zs\<rangle> \<in> prefix(A) \<longrightarrow> \<langle>ys,zs\<rangle> \<in> prefix(A)
   \<longrightarrow>\<langle>xs,ys\<rangle> \<in> prefix(A) | \<langle>ys,xs\<rangle> \<in> prefix(A)"
 apply (erule list_append_induct, auto)
 done
 
 lemma common_prefix_linear: "\<lbrakk>\<langle>xs, zs\<rangle> \<in> prefix(A); \<langle>ys,zs\<rangle> \<in> prefix(A)\<rbrakk>
       \<Longrightarrow> \<langle>xs,ys\<rangle> \<in> prefix(A) | \<langle>ys,xs\<rangle> \<in> prefix(A)"
 apply (cut_tac prefix_type)
 apply (blast del: disjCI intro: common_prefix_linear_lemma)
 done
 
 
 (*** pfixLe, pfixGe \<in> properties inherited from the translations ***)
 
 
 
 (** pfixLe **)
 
 lemma refl_Le: "refl(nat,Le)"
 
 apply (unfold refl_def, auto)
 done
 declare refl_Le [simp]
 
 lemma antisym_Le: "antisym(Le)"
   unfolding antisym_def
 apply (auto intro: le_anti_sym)
 done
 declare antisym_Le [simp]
 
 lemma trans_on_Le: "trans[nat](Le)"
 apply (unfold trans_on_def, auto)
 apply (blast intro: le_trans)
 done
 declare trans_on_Le [simp]
 
 lemma trans_Le: "trans(Le)"
 apply (unfold trans_def, auto)
 apply (blast intro: le_trans)
 done
 declare trans_Le [simp]
 
 lemma part_order_Le: "part_order(nat,Le)"
 by (unfold part_order_def, auto)
 declare part_order_Le [simp]
 
 lemma pfixLe_refl: "x \<in> list(nat) \<Longrightarrow> x pfixLe x"
 by (blast intro: refl_gen_prefix [THEN reflD] refl_Le)
 declare pfixLe_refl [simp]
 
 lemma pfixLe_trans: "\<lbrakk>x pfixLe y; y pfixLe z\<rbrakk> \<Longrightarrow> x pfixLe z"
 by (blast intro: trans_gen_prefix [THEN transD] trans_Le)
 
 lemma pfixLe_antisym: "\<lbrakk>x pfixLe y; y pfixLe x\<rbrakk> \<Longrightarrow> x = y"
 by (blast intro: antisym_gen_prefix [THEN antisymE] antisym_Le)
 
 
 lemma prefix_imp_pfixLe:
 "\<langle>xs,ys\<rangle>:prefix(nat)\<Longrightarrow> xs pfixLe ys"
 
   unfolding prefix_def
 apply (rule gen_prefix_mono [THEN subsetD], auto)
 done
 
 lemma refl_Ge: "refl(nat, Ge)"
 by (unfold refl_def Ge_def, auto)
 declare refl_Ge [iff]
 
 lemma antisym_Ge: "antisym(Ge)"
-apply (unfold antisym_def Ge_def)
+  unfolding antisym_def Ge_def
 apply (auto intro: le_anti_sym)
 done
 declare antisym_Ge [iff]
 
 lemma trans_Ge: "trans(Ge)"
-apply (unfold trans_def Ge_def)
+  unfolding trans_def Ge_def
 apply (auto intro: le_trans)
 done
 declare trans_Ge [iff]
 
 lemma pfixGe_refl: "x \<in> list(nat) \<Longrightarrow> x pfixGe x"
 by (blast intro: refl_gen_prefix [THEN reflD])
 declare pfixGe_refl [simp]
 
 lemma pfixGe_trans: "\<lbrakk>x pfixGe y; y pfixGe z\<rbrakk> \<Longrightarrow> x pfixGe z"
 by (blast intro: trans_gen_prefix [THEN transD])
 
 lemma pfixGe_antisym: "\<lbrakk>x pfixGe y; y pfixGe x\<rbrakk> \<Longrightarrow> x = y"
 by (blast intro: antisym_gen_prefix [THEN antisymE])
 
 lemma prefix_imp_pfixGe:
   "\<langle>xs,ys\<rangle>:prefix(nat) \<Longrightarrow> xs pfixGe ys"
-apply (unfold prefix_def Ge_def)
+  unfolding prefix_def Ge_def
 apply (rule gen_prefix_mono [THEN subsetD], auto)
 done
 (* Added by Sidi \<in> prefix and take *)
 
 lemma prefix_imp_take:
 "\<langle>xs, ys\<rangle> \<in> prefix(A) \<Longrightarrow> xs = take(length(xs), ys)"
 
   unfolding prefix_def
 apply (erule gen_prefix.induct)
 apply (subgoal_tac [3] "length (xs) :nat")
 apply (auto dest: gen_prefix.dom_subset [THEN subsetD] simp add: length_type)
 apply (frule gen_prefix.dom_subset [THEN subsetD])
 apply (frule gen_prefix_length_le)
 apply (auto simp add: take_append)
 apply (subgoal_tac "length (xs) #- length (ys) =0")
 apply (simp_all (no_asm_simp) add: diff_is_0_iff)
 done
 
 lemma prefix_length_equal: "\<lbrakk>\<langle>xs,ys\<rangle> \<in> prefix(A); length(xs)=length(ys)\<rbrakk> \<Longrightarrow> xs = ys"
 apply (cut_tac A = A in prefix_type)
 apply (drule subsetD, auto)
 apply (drule prefix_imp_take)
 apply (erule trans, simp)
 done
 
 lemma prefix_length_le_equal: "\<lbrakk>\<langle>xs,ys\<rangle> \<in> prefix(A); length(ys) \<le> length(xs)\<rbrakk> \<Longrightarrow> xs = ys"
 by (blast intro: prefix_length_equal le_anti_sym prefix_length_le)
 
 lemma take_prefix [rule_format]: "xs \<in> list(A) \<Longrightarrow> \<forall>n \<in> nat. <take(n, xs), xs> \<in> prefix(A)"
   unfolding prefix_def
 apply (erule list.induct, simp, clarify)
 apply (erule natE, auto)
 done
 
 lemma prefix_take_iff: "\<langle>xs,ys\<rangle> \<in> prefix(A) \<longleftrightarrow> (xs=take(length(xs), ys) \<and> xs \<in> list(A) \<and> ys \<in> list(A))"
 apply (rule iffI)
 apply (frule prefix_type [THEN subsetD])
 apply (blast intro: prefix_imp_take, clarify)
 apply (erule ssubst)
 apply (blast intro: take_prefix length_type)
 done
 
 lemma prefix_imp_nth: "\<lbrakk>\<langle>xs,ys\<rangle> \<in> prefix(A); i < length(xs)\<rbrakk> \<Longrightarrow> nth(i,xs) = nth(i,ys)"
 by (auto dest!: gen_prefix_imp_nth simp add: prefix_def)
 
 lemma nth_imp_prefix:
      "\<lbrakk>xs \<in> list(A); ys \<in> list(A); length(xs) \<le> length(ys);
         \<And>i. i < length(xs) \<Longrightarrow> nth(i, xs) = nth(i,ys)\<rbrakk>
       \<Longrightarrow> \<langle>xs,ys\<rangle> \<in> prefix(A)"
 apply (auto simp add: prefix_def nth_imp_gen_prefix)
 apply (auto intro!: nth_imp_gen_prefix simp add: prefix_def)
 apply (blast intro: nth_type lt_trans2)
 done
 
 
 lemma length_le_prefix_imp_prefix: "\<lbrakk>length(xs) \<le> length(ys);
         \<langle>xs,zs\<rangle> \<in> prefix(A); \<langle>ys,zs\<rangle> \<in> prefix(A)\<rbrakk> \<Longrightarrow> \<langle>xs,ys\<rangle> \<in> prefix(A)"
 apply (cut_tac A = A in prefix_type)
 apply (rule nth_imp_prefix, blast, blast)
  apply assumption
 apply (rule_tac b = "nth (i,zs)" in trans)
  apply (blast intro: prefix_imp_nth)
 apply (blast intro: sym prefix_imp_nth prefix_length_le lt_trans2)
 done
 
 end
diff --git a/src/ZF/UNITY/Increasing.thy b/src/ZF/UNITY/Increasing.thy
--- a/src/ZF/UNITY/Increasing.thy
+++ b/src/ZF/UNITY/Increasing.thy
@@ -1,227 +1,227 @@
 (*  Title:      ZF/UNITY/Increasing.thy
     Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
     Copyright   2001  University of Cambridge
 
 Increasing's parameters are a state function f, a domain A and an order
 relation r over the domain A. 
 *)
 
 section\<open>Charpentier's "Increasing" Relation\<close>
 
 theory Increasing imports Constrains Monotonicity begin
 
 definition
   increasing :: "[i, i, i\<Rightarrow>i] \<Rightarrow> i" (\<open>increasing[_]'(_, _')\<close>)  where
   "increasing[A](r, f) \<equiv>
     {F \<in> program. (\<forall>k \<in> A. F \<in> stable({s \<in> state. <k, f(s)> \<in> r})) \<and>
                 (\<forall>x \<in> state. f(x):A)}"
   
 definition
   Increasing :: "[i, i, i\<Rightarrow>i] \<Rightarrow> i" (\<open>Increasing[_]'(_, _')\<close>)  where
   "Increasing[A](r, f) \<equiv>
     {F \<in> program. (\<forall>k \<in> A. F \<in> Stable({s \<in> state. <k, f(s)> \<in> r})) \<and>
                 (\<forall>x \<in> state. f(x):A)}"
 
 abbreviation (input)
   IncWrt ::  "[i\<Rightarrow>i, i, i] \<Rightarrow> i" (\<open>(_ IncreasingWrt _ '/ _)\<close> [60, 0, 60] 60)  where
   "f IncreasingWrt r/A \<equiv> Increasing[A](r,f)"
 
 
 (** increasing **)
 
 lemma increasing_type: "increasing[A](r, f) \<subseteq> program"
 by (unfold increasing_def, blast)
 
 lemma increasing_into_program: "F \<in> increasing[A](r, f) \<Longrightarrow> F \<in> program"
 by (unfold increasing_def, blast)
 
 lemma increasing_imp_stable: 
 "\<lbrakk>F \<in> increasing[A](r, f); x \<in> A\<rbrakk> \<Longrightarrow>F \<in> stable({s \<in> state. <x, f(s)>:r})"
 by (unfold increasing_def, blast)
 
 lemma increasingD: 
 "F \<in> increasing[A](r,f) \<Longrightarrow> F \<in> program \<and> (\<exists>a. a \<in> A) \<and> (\<forall>s \<in> state. f(s):A)"
   unfolding increasing_def
 apply (subgoal_tac "\<exists>x. x \<in> state")
 apply (auto dest: stable_type [THEN subsetD] intro: st0_in_state)
 done
 
 lemma increasing_constant [simp]: 
  "F \<in> increasing[A](r, \<lambda>s. c) \<longleftrightarrow> F \<in> program \<and> c \<in> A"
-apply (unfold increasing_def stable_def)
+  unfolding increasing_def stable_def
 apply (subgoal_tac "\<exists>x. x \<in> state")
 apply (auto dest: stable_type [THEN subsetD] intro: st0_in_state)
 done
 
 lemma subset_increasing_comp: 
 "\<lbrakk>mono1(A, r, B, s, g); refl(A, r); trans[B](s)\<rbrakk> \<Longrightarrow>  
    increasing[A](r, f) \<subseteq> increasing[B](s, g comp f)"
 apply (unfold increasing_def stable_def part_order_def 
        constrains_def mono1_def metacomp_def, clarify, simp)
 apply clarify
 apply (subgoal_tac "xa \<in> state")
 prefer 2 apply (blast dest!: ActsD)
 apply (subgoal_tac "<f (xb), f (xb) >:r")
 prefer 2 apply (force simp add: refl_def)
 apply (rotate_tac 5)
 apply (drule_tac x = "f (xb) " in bspec)
 apply (rotate_tac [2] -1)
 apply (drule_tac [2] x = act in bspec, simp_all)
 apply (drule_tac A = "act``u" and c = xa for u in subsetD, blast)
 apply (drule_tac x = "f(xa) " and x1 = "f(xb)" in bspec [THEN bspec])
 apply (rule_tac [3] b = "g (f (xb))" and A = B in trans_onD)
 apply simp_all
 done
 
 lemma imp_increasing_comp:
      "\<lbrakk>F \<in> increasing[A](r, f); mono1(A, r, B, s, g);  
          refl(A, r); trans[B](s)\<rbrakk> \<Longrightarrow> F \<in> increasing[B](s, g comp f)"
 by (rule subset_increasing_comp [THEN subsetD], auto)
 
 lemma strict_increasing: 
    "increasing[nat](Le, f) \<subseteq> increasing[nat](Lt, f)"
 by (unfold increasing_def Lt_def, auto)
 
 lemma strict_gt_increasing: 
    "increasing[nat](Ge, f) \<subseteq> increasing[nat](Gt, f)"
 apply (unfold increasing_def Gt_def Ge_def, auto)
 apply (erule natE)
 apply (auto simp add: stable_def)
 done
 
 (** Increasing **)
 
 lemma increasing_imp_Increasing: 
      "F \<in> increasing[A](r, f) \<Longrightarrow> F \<in> Increasing[A](r, f)"
 
-apply (unfold increasing_def Increasing_def)
+  unfolding increasing_def Increasing_def
 apply (auto intro: stable_imp_Stable)
 done
 
 lemma Increasing_type: "Increasing[A](r, f) \<subseteq> program"
 by (unfold Increasing_def, auto)
 
 lemma Increasing_into_program: "F \<in> Increasing[A](r, f) \<Longrightarrow> F \<in> program"
 by (unfold Increasing_def, auto)
 
 lemma Increasing_imp_Stable: 
 "\<lbrakk>F \<in> Increasing[A](r, f); a \<in> A\<rbrakk> \<Longrightarrow> F \<in> Stable({s \<in> state. <a,f(s)>:r})"
 by (unfold Increasing_def, blast)
 
 lemma IncreasingD: 
 "F \<in> Increasing[A](r, f) \<Longrightarrow> F \<in> program \<and> (\<exists>a. a \<in> A) \<and> (\<forall>s \<in> state. f(s):A)"
   unfolding Increasing_def
 apply (subgoal_tac "\<exists>x. x \<in> state")
 apply (auto intro: st0_in_state)
 done
 
 lemma Increasing_constant [simp]: 
      "F \<in> Increasing[A](r, \<lambda>s. c) \<longleftrightarrow> F \<in> program \<and> (c \<in> A)"
 apply (subgoal_tac "\<exists>x. x \<in> state")
 apply (auto dest!: IncreasingD intro: st0_in_state increasing_imp_Increasing)
 done
 
 lemma subset_Increasing_comp: 
 "\<lbrakk>mono1(A, r, B, s, g); refl(A, r); trans[B](s)\<rbrakk> \<Longrightarrow>  
    Increasing[A](r, f) \<subseteq> Increasing[B](s, g comp f)"
 apply (unfold Increasing_def Stable_def Constrains_def part_order_def 
        constrains_def mono1_def metacomp_def, safe)
 apply (simp_all add: ActsD)
 apply (subgoal_tac "xb \<in> state \<and> xa \<in> state")
  prefer 2 apply (simp add: ActsD)
 apply (subgoal_tac "<f (xb), f (xb) >:r")
 prefer 2 apply (force simp add: refl_def)
 apply (rotate_tac 5)
 apply (drule_tac x = "f (xb) " in bspec)
 apply simp_all
 apply clarify
 apply (rotate_tac -2)
 apply (drule_tac x = act in bspec)
 apply (drule_tac [2] A = "act``u" and c = xa for u in subsetD, simp_all, blast)
 apply (drule_tac x = "f(xa)" and x1 = "f(xb)" in bspec [THEN bspec])
 apply (rule_tac [3] b = "g (f (xb))" and A = B in trans_onD)
 apply simp_all
 done
 
 lemma imp_Increasing_comp:
  "\<lbrakk>F \<in> Increasing[A](r, f); mono1(A, r, B, s, g); refl(A, r); trans[B](s)\<rbrakk> 
   \<Longrightarrow> F \<in> Increasing[B](s, g comp f)"
 apply (rule subset_Increasing_comp [THEN subsetD], auto)
 done
   
 lemma strict_Increasing: "Increasing[nat](Le, f) \<subseteq> Increasing[nat](Lt, f)"
 by (unfold Increasing_def Lt_def, auto)
 
 lemma strict_gt_Increasing: "Increasing[nat](Ge, f)<= Increasing[nat](Gt, f)"
 apply (unfold Increasing_def Ge_def Gt_def, auto)
 apply (erule natE)
 apply (auto simp add: Stable_def)
 done
 
 (** Two-place monotone operations **)
 
 lemma imp_increasing_comp2: 
 "\<lbrakk>F \<in> increasing[A](r, f); F \<in> increasing[B](s, g);  
     mono2(A, r, B, s, C, t, h); refl(A, r); refl(B, s); trans[C](t)\<rbrakk>
  \<Longrightarrow> F \<in> increasing[C](t, \<lambda>x. h(f(x), g(x)))"
 apply (unfold increasing_def stable_def 
        part_order_def constrains_def mono2_def, clarify, simp)
 apply clarify
 apply (rename_tac xa xb)
 apply (subgoal_tac "xb \<in> state \<and> xa \<in> state")
  prefer 2 apply (blast dest!: ActsD)
 apply (subgoal_tac "<f (xb), f (xb) >:r \<and> <g (xb), g (xb) >:s")
 prefer 2 apply (force simp add: refl_def)
 apply (rotate_tac 6)
 apply (drule_tac x = "f (xb) " in bspec)
 apply (rotate_tac [2] 1)
 apply (drule_tac [2] x = "g (xb) " in bspec)
 apply simp_all
 apply (rotate_tac -1)
 apply (drule_tac x = act in bspec)
 apply (rotate_tac [2] -3)
 apply (drule_tac [2] x = act in bspec, simp_all)
 apply (drule_tac A = "act``u" and c = xa for u in subsetD)
 apply (drule_tac [2] A = "act``u" and c = xa for u in subsetD, blast, blast)
 apply (rotate_tac -4)
 apply (drule_tac x = "f (xa) " and x1 = "f (xb) " in bspec [THEN bspec])
 apply (rotate_tac [3] -1)
 apply (drule_tac [3] x = "g (xa) " and x1 = "g (xb) " in bspec [THEN bspec])
 apply simp_all
 apply (rule_tac b = "h (f (xb), g (xb))" and A = C in trans_onD)
 apply simp_all
 done
 
 lemma imp_Increasing_comp2: 
 "\<lbrakk>F \<in> Increasing[A](r, f); F \<in> Increasing[B](s, g);  
   mono2(A, r, B, s, C, t, h); refl(A, r); refl(B, s); trans[C](t)\<rbrakk> \<Longrightarrow>  
   F \<in> Increasing[C](t, \<lambda>x. h(f(x), g(x)))"
 apply (unfold Increasing_def stable_def 
        part_order_def constrains_def mono2_def Stable_def Constrains_def, safe)
 apply (simp_all add: ActsD)
 apply (subgoal_tac "xa \<in> state \<and> x \<in> state")
 prefer 2 apply (blast dest!: ActsD)
 apply (subgoal_tac "<f (xa), f (xa) >:r \<and> <g (xa), g (xa) >:s")
 prefer 2 apply (force simp add: refl_def)
 apply (rotate_tac 6)
 apply (drule_tac x = "f (xa) " in bspec)
 apply (rotate_tac [2] 1)
 apply (drule_tac [2] x = "g (xa) " in bspec)
 apply simp_all
 apply clarify
 apply (rotate_tac -2)
 apply (drule_tac x = act in bspec)
 apply (rotate_tac [2] -3)
 apply (drule_tac [2] x = act in bspec, simp_all)
 apply (drule_tac A = "act``u" and c = x for u in subsetD)
 apply (drule_tac [2] A = "act``u" and c = x for u in subsetD, blast, blast)
 apply (rotate_tac -9)
 apply (drule_tac x = "f (x) " and x1 = "f (xa) " in bspec [THEN bspec])
 apply (rotate_tac [3] -1)
 apply (drule_tac [3] x = "g (x) " and x1 = "g (xa) " in bspec [THEN bspec])
 apply simp_all
 apply (rule_tac b = "h (f (xa), g (xa))" and A = C in trans_onD)
 apply simp_all
 done
 
 end
diff --git a/src/ZF/UNITY/Monotonicity.thy b/src/ZF/UNITY/Monotonicity.thy
--- a/src/ZF/UNITY/Monotonicity.thy
+++ b/src/ZF/UNITY/Monotonicity.thy
@@ -1,120 +1,120 @@
 (*  Title:      ZF/UNITY/Monotonicity.thy
     Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
     Copyright   2002  University of Cambridge
 
 Monotonicity of an operator (meta-function) with respect to arbitrary
 set relations.
 *)
 
 section\<open>Monotonicity of an Operator WRT a Relation\<close>
 
 theory Monotonicity imports GenPrefix MultisetSum
 begin
 
 definition
   mono1 :: "[i, i, i, i, i\<Rightarrow>i] \<Rightarrow> o"  where
   "mono1(A, r, B, s, f) \<equiv>
     (\<forall>x \<in> A. \<forall>y \<in> A. \<langle>x,y\<rangle> \<in> r \<longrightarrow> <f(x), f(y)> \<in> s) \<and> (\<forall>x \<in> A. f(x) \<in> B)"
 
   (* monotonicity of a 2-place meta-function f *)
 
 definition
   mono2 :: "[i, i, i, i, i, i, [i,i]\<Rightarrow>i] \<Rightarrow> o"  where
   "mono2(A, r, B, s, C, t, f) \<equiv> 
     (\<forall>x \<in> A. \<forall>y \<in> A. \<forall>u \<in> B. \<forall>v \<in> B.
               \<langle>x,y\<rangle> \<in> r \<and> \<langle>u,v\<rangle> \<in> s \<longrightarrow> <f(x,u), f(y,v)> \<in> t) \<and>
     (\<forall>x \<in> A. \<forall>y \<in> B. f(x,y) \<in> C)"
 
  (* Internalized relations on sets and multisets *)
 
 definition
   SetLe :: "i \<Rightarrow>i"  where
   "SetLe(A) \<equiv> {\<langle>x,y\<rangle> \<in> Pow(A)*Pow(A). x \<subseteq> y}"
 
 definition
   MultLe :: "[i,i] \<Rightarrow>i"  where
   "MultLe(A, r) \<equiv> multirel(A, r - id(A)) \<union> id(Mult(A))"
 
 
 lemma mono1D: 
   "\<lbrakk>mono1(A, r, B, s, f); \<langle>x, y\<rangle> \<in> r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> <f(x), f(y)> \<in> s"
 by (unfold mono1_def, auto)
 
 lemma mono2D: 
      "\<lbrakk>mono2(A, r, B, s, C, t, f);  
          \<langle>x, y\<rangle> \<in> r; \<langle>u,v\<rangle> \<in> s; x \<in> A; y \<in> A; u \<in> B; v \<in> B\<rbrakk> 
       \<Longrightarrow> <f(x, u), f(y,v)> \<in> t"
 by (unfold mono2_def, auto)
 
 
 (** Monotonicity of take **)
 
 lemma take_mono_left_lemma:
      "\<lbrakk>i \<le> j; xs \<in> list(A); i \<in> nat; j \<in> nat\<rbrakk> 
       \<Longrightarrow> <take(i, xs), take(j, xs)> \<in> prefix(A)"
 apply (case_tac "length (xs) \<le> i")
  apply (subgoal_tac "length (xs) \<le> j")
   apply (simp)
  apply (blast intro: le_trans)
 apply (drule not_lt_imp_le, auto)
 apply (case_tac "length (xs) \<le> j")
  apply (auto simp add: take_prefix)
 apply (drule not_lt_imp_le, auto)
 apply (drule_tac m = i in less_imp_succ_add, auto)
 apply (subgoal_tac "i #+ k \<le> length (xs) ")
  apply (simp add: take_add prefix_iff take_type drop_type)
 apply (blast intro: leI)
 done
 
 lemma take_mono_left:
      "\<lbrakk>i \<le> j; xs \<in> list(A); j \<in> nat\<rbrakk>
       \<Longrightarrow> <take(i, xs), take(j, xs)> \<in> prefix(A)"
 by (blast intro: le_in_nat take_mono_left_lemma) 
 
 lemma take_mono_right:
      "\<lbrakk>\<langle>xs,ys\<rangle> \<in> prefix(A); i \<in> nat\<rbrakk> 
       \<Longrightarrow> <take(i, xs), take(i, ys)> \<in> prefix(A)"
 by (auto simp add: prefix_iff)
 
 lemma take_mono:
      "\<lbrakk>i \<le> j; \<langle>xs, ys\<rangle> \<in> prefix(A); j \<in> nat\<rbrakk>
       \<Longrightarrow> <take(i, xs), take(j, ys)> \<in> prefix(A)"
 apply (rule_tac b = "take (j, xs) " in prefix_trans)
 apply (auto dest: prefix_type [THEN subsetD] intro: take_mono_left take_mono_right)
 done
 
 lemma mono_take [iff]:
      "mono2(nat, Le, list(A), prefix(A), list(A), prefix(A), take)"
 apply (unfold mono2_def Le_def, auto)
 apply (blast intro: take_mono)
 done
 
 (** Monotonicity of length **)
 
 lemmas length_mono = prefix_length_le
 
 lemma mono_length [iff]:
      "mono1(list(A), prefix(A), nat, Le, length)"
   unfolding mono1_def
 apply (auto dest: prefix_length_le simp add: Le_def)
 done
 
 (** Monotonicity of \<union> **)
 
 lemma mono_Un [iff]: 
      "mono2(Pow(A), SetLe(A), Pow(A), SetLe(A), Pow(A), SetLe(A), (Un))"
 by (unfold mono2_def SetLe_def, auto)
 
 (* Monotonicity of multiset union *)
 
 lemma mono_munion [iff]: 
      "mono2(Mult(A), MultLe(A,r), Mult(A), MultLe(A, r), Mult(A), MultLe(A, r), munion)"
-apply (unfold mono2_def MultLe_def)
+  unfolding mono2_def MultLe_def
 apply (auto simp add: Mult_iff_multiset)
 apply (blast intro: munion_multirel_mono munion_multirel_mono1 munion_multirel_mono2 multiset_into_Mult)+
 done
 
 lemma mono_succ [iff]: "mono1(nat, Le, nat, Le, succ)"
 by (unfold mono1_def Le_def, auto)
 
 end
diff --git a/src/ZF/UNITY/UNITY.thy b/src/ZF/UNITY/UNITY.thy
--- a/src/ZF/UNITY/UNITY.thy
+++ b/src/ZF/UNITY/UNITY.thy
@@ -1,625 +1,625 @@
 (*  Title:      ZF/UNITY/UNITY.thy
     Author:     Sidi O Ehmety, Computer Laboratory
     Copyright   2001  University of Cambridge
 *)
 
 section \<open>The Basic UNITY Theory\<close>
 
 theory UNITY imports State begin
 
 text\<open>The basic UNITY theory (revised version, based upon the "co" operator)
 From Misra, "A Logic for Concurrent Programming", 1994.
 
 This ZF theory was ported from its HOL equivalent.\<close>
 
 definition
   program  :: i  where
   "program \<equiv> {<init, acts, allowed>:
                Pow(state) * Pow(Pow(state*state)) * Pow(Pow(state*state)).
                id(state) \<in> acts \<and> id(state) \<in> allowed}"
 
 definition
   mk_program :: "[i,i,i]\<Rightarrow>i"  where
   \<comment> \<open>The definition yields a program thanks to the coercions
        init \<inter> state, acts \<inter> Pow(state*state), etc.\<close>
   "mk_program(init, acts, allowed) \<equiv>
     <init \<inter> state, cons(id(state), acts \<inter> Pow(state*state)),
               cons(id(state), allowed \<inter> Pow(state*state))>"
 
 definition
   SKIP :: i  (\<open>\<bottom>\<close>) where
   "SKIP \<equiv> mk_program(state, 0, Pow(state*state))"
 
   (* Coercion from anything to program *)
 definition
   programify :: "i\<Rightarrow>i"  where
   "programify(F) \<equiv> if F \<in> program then F else SKIP"
 
 definition
   RawInit :: "i\<Rightarrow>i"  where
   "RawInit(F) \<equiv> fst(F)"
 
 definition
   Init :: "i\<Rightarrow>i"  where
   "Init(F) \<equiv> RawInit(programify(F))"
 
 definition
   RawActs :: "i\<Rightarrow>i"  where
   "RawActs(F) \<equiv> cons(id(state), fst(snd(F)))"
 
 definition
   Acts :: "i\<Rightarrow>i"  where
   "Acts(F) \<equiv> RawActs(programify(F))"
 
 definition
   RawAllowedActs :: "i\<Rightarrow>i"  where
   "RawAllowedActs(F) \<equiv> cons(id(state), snd(snd(F)))"
 
 definition
   AllowedActs :: "i\<Rightarrow>i"  where
   "AllowedActs(F) \<equiv> RawAllowedActs(programify(F))"
 
 
 definition
   Allowed :: "i \<Rightarrow>i"  where
   "Allowed(F) \<equiv> {G \<in> program. Acts(G) \<subseteq> AllowedActs(F)}"
 
 definition
   initially :: "i\<Rightarrow>i"  where
   "initially(A) \<equiv> {F \<in> program. Init(F)\<subseteq>A}"
 
 definition "constrains" :: "[i, i] \<Rightarrow> i"  (infixl \<open>co\<close> 60)  where
   "A co B \<equiv> {F \<in> program. (\<forall>act \<in> Acts(F). act``A\<subseteq>B) \<and> st_set(A)}"
     \<comment> \<open>the condition \<^term>\<open>st_set(A)\<close> makes the definition slightly
          stronger than the HOL one\<close>
 
 definition unless :: "[i, i] \<Rightarrow> i"  (infixl \<open>unless\<close> 60)  where
   "A unless B \<equiv> (A - B) co (A \<union> B)"
 
 definition
   stable     :: "i\<Rightarrow>i"  where
    "stable(A) \<equiv> A co A"
 
 definition
   strongest_rhs :: "[i, i] \<Rightarrow> i"  where
   "strongest_rhs(F, A) \<equiv> \<Inter>({B \<in> Pow(state). F \<in> A co B})"
 
 definition
   invariant :: "i \<Rightarrow> i"  where
   "invariant(A) \<equiv> initially(A) \<inter> stable(A)"
 
   (* meta-function composition *)
 definition
   metacomp :: "[i\<Rightarrow>i, i\<Rightarrow>i] \<Rightarrow> (i\<Rightarrow>i)" (infixl \<open>comp\<close> 65)  where
   "f comp g \<equiv> \<lambda>x. f(g(x))"
 
 definition
   pg_compl :: "i\<Rightarrow>i"  where
   "pg_compl(X)\<equiv> program - X"
 
 text\<open>SKIP\<close>
 lemma SKIP_in_program [iff,TC]: "SKIP \<in> program"
 by (force simp add: SKIP_def program_def mk_program_def)
 
 
 subsection\<open>The function \<^term>\<open>programify\<close>, the coercion from anything to
  program\<close>
 
 lemma programify_program [simp]: "F \<in> program \<Longrightarrow> programify(F)=F"
 by (force simp add: programify_def) 
 
 lemma programify_in_program [iff,TC]: "programify(F) \<in> program"
 by (force simp add: programify_def) 
 
 text\<open>Collapsing rules: to remove programify from expressions\<close>
 lemma programify_idem [simp]: "programify(programify(F))=programify(F)"
 by (force simp add: programify_def) 
 
 lemma Init_programify [simp]: "Init(programify(F)) = Init(F)"
 by (simp add: Init_def)
 
 lemma Acts_programify [simp]: "Acts(programify(F)) = Acts(F)"
 by (simp add: Acts_def)
 
 lemma AllowedActs_programify [simp]:
      "AllowedActs(programify(F)) = AllowedActs(F)"
 by (simp add: AllowedActs_def)
 
 subsection\<open>The Inspectors for Programs\<close>
 
 lemma id_in_RawActs: "F \<in> program \<Longrightarrow>id(state) \<in> RawActs(F)"
 by (auto simp add: program_def RawActs_def)
 
 lemma id_in_Acts [iff,TC]: "id(state) \<in> Acts(F)"
 by (simp add: id_in_RawActs Acts_def)
 
 lemma id_in_RawAllowedActs: "F \<in> program \<Longrightarrow>id(state) \<in> RawAllowedActs(F)"
 by (auto simp add: program_def RawAllowedActs_def)
 
 lemma id_in_AllowedActs [iff,TC]: "id(state) \<in> AllowedActs(F)"
 by (simp add: id_in_RawAllowedActs AllowedActs_def)
 
 lemma cons_id_Acts [simp]: "cons(id(state), Acts(F)) = Acts(F)"
 by (simp add: cons_absorb)
 
 lemma cons_id_AllowedActs [simp]:
      "cons(id(state), AllowedActs(F)) = AllowedActs(F)"
 by (simp add: cons_absorb)
 
 
 subsection\<open>Types of the Inspectors\<close>
 
 lemma RawInit_type: "F \<in> program \<Longrightarrow> RawInit(F)\<subseteq>state"
 by (auto simp add: program_def RawInit_def)
 
 lemma RawActs_type: "F \<in> program \<Longrightarrow> RawActs(F)\<subseteq>Pow(state*state)"
 by (auto simp add: program_def RawActs_def)
 
 lemma RawAllowedActs_type:
      "F \<in> program \<Longrightarrow> RawAllowedActs(F)\<subseteq>Pow(state*state)"
 by (auto simp add: program_def RawAllowedActs_def)
 
 lemma Init_type: "Init(F)\<subseteq>state"
 by (simp add: RawInit_type Init_def)
 
 lemmas InitD = Init_type [THEN subsetD]
 
 lemma st_set_Init [iff]: "st_set(Init(F))"
   unfolding st_set_def
 apply (rule Init_type)
 done
 
 lemma Acts_type: "Acts(F)\<subseteq>Pow(state*state)"
 by (simp add: RawActs_type Acts_def)
 
 lemma AllowedActs_type: "AllowedActs(F) \<subseteq> Pow(state*state)"
 by (simp add: RawAllowedActs_type AllowedActs_def)
 
 text\<open>Needed in Behaviors\<close>
 lemma ActsD: "\<lbrakk>act \<in> Acts(F); <s,s'> \<in> act\<rbrakk> \<Longrightarrow> s \<in> state \<and> s' \<in> state"
 by (blast dest: Acts_type [THEN subsetD])
 
 lemma AllowedActsD:
      "\<lbrakk>act \<in> AllowedActs(F); <s,s'> \<in> act\<rbrakk> \<Longrightarrow> s \<in> state \<and> s' \<in> state"
 by (blast dest: AllowedActs_type [THEN subsetD])
 
 subsection\<open>Simplification rules involving \<^term>\<open>state\<close>, \<^term>\<open>Init\<close>, 
   \<^term>\<open>Acts\<close>, and \<^term>\<open>AllowedActs\<close>\<close>
 
 text\<open>But are they really needed?\<close>
 
 lemma state_subset_is_Init_iff [iff]: "state \<subseteq> Init(F) \<longleftrightarrow> Init(F)=state"
 by (cut_tac F = F in Init_type, auto)
 
 lemma Pow_state_times_state_is_subset_Acts_iff [iff]:
      "Pow(state*state) \<subseteq> Acts(F) \<longleftrightarrow> Acts(F)=Pow(state*state)"
 by (cut_tac F = F in Acts_type, auto)
 
 lemma Pow_state_times_state_is_subset_AllowedActs_iff [iff]:
      "Pow(state*state) \<subseteq> AllowedActs(F) \<longleftrightarrow> AllowedActs(F)=Pow(state*state)"
 by (cut_tac F = F in AllowedActs_type, auto)
 
 subsubsection\<open>Eliminating \<open>\<inter> state\<close> from expressions\<close>
 
 lemma Init_Int_state [simp]: "Init(F) \<inter> state = Init(F)"
 by (cut_tac F = F in Init_type, blast)
 
 lemma state_Int_Init [simp]: "state \<inter> Init(F) = Init(F)"
 by (cut_tac F = F in Init_type, blast)
 
 lemma Acts_Int_Pow_state_times_state [simp]:
      "Acts(F) \<inter> Pow(state*state) = Acts(F)"
 by (cut_tac F = F in Acts_type, blast)
 
 lemma state_times_state_Int_Acts [simp]:
      "Pow(state*state) \<inter> Acts(F) = Acts(F)"
 by (cut_tac F = F in Acts_type, blast)
 
 lemma AllowedActs_Int_Pow_state_times_state [simp]:
      "AllowedActs(F) \<inter> Pow(state*state) = AllowedActs(F)"
 by (cut_tac F = F in AllowedActs_type, blast)
 
 lemma state_times_state_Int_AllowedActs [simp]:
      "Pow(state*state) \<inter> AllowedActs(F) = AllowedActs(F)"
 by (cut_tac F = F in AllowedActs_type, blast)
 
 
 subsubsection\<open>The Operator \<^term>\<open>mk_program\<close>\<close>
 
 lemma mk_program_in_program [iff,TC]:
      "mk_program(init, acts, allowed) \<in> program"
 by (auto simp add: mk_program_def program_def)
 
 lemma RawInit_eq [simp]:
      "RawInit(mk_program(init, acts, allowed)) = init \<inter> state"
 by (auto simp add: mk_program_def RawInit_def)
 
 lemma RawActs_eq [simp]:
      "RawActs(mk_program(init, acts, allowed)) = 
       cons(id(state), acts \<inter> Pow(state*state))"
 by (auto simp add: mk_program_def RawActs_def)
 
 lemma RawAllowedActs_eq [simp]:
      "RawAllowedActs(mk_program(init, acts, allowed)) =
       cons(id(state), allowed \<inter> Pow(state*state))"
 by (auto simp add: mk_program_def RawAllowedActs_def)
 
 lemma Init_eq [simp]: "Init(mk_program(init, acts, allowed)) = init \<inter> state"
 by (simp add: Init_def)
 
 lemma Acts_eq [simp]:
      "Acts(mk_program(init, acts, allowed)) = 
       cons(id(state), acts  \<inter> Pow(state*state))"
 by (simp add: Acts_def)
 
 lemma AllowedActs_eq [simp]:
      "AllowedActs(mk_program(init, acts, allowed))=
       cons(id(state), allowed \<inter> Pow(state*state))"
 by (simp add: AllowedActs_def)
 
 text\<open>Init, Acts, and AlowedActs  of SKIP\<close>
 
 lemma RawInit_SKIP [simp]: "RawInit(SKIP) = state"
 by (simp add: SKIP_def)
 
 lemma RawAllowedActs_SKIP [simp]: "RawAllowedActs(SKIP) = Pow(state*state)"
 by (force simp add: SKIP_def)
 
 lemma RawActs_SKIP [simp]: "RawActs(SKIP) = {id(state)}"
 by (force simp add: SKIP_def)
 
 lemma Init_SKIP [simp]: "Init(SKIP) = state"
 by (force simp add: SKIP_def)
 
 lemma Acts_SKIP [simp]: "Acts(SKIP) = {id(state)}"
 by (force simp add: SKIP_def)
 
 lemma AllowedActs_SKIP [simp]: "AllowedActs(SKIP) = Pow(state*state)"
 by (force simp add: SKIP_def)
 
 text\<open>Equality of UNITY programs\<close>
 
 lemma raw_surjective_mk_program:
      "F \<in> program \<Longrightarrow> mk_program(RawInit(F), RawActs(F), RawAllowedActs(F))=F"
 apply (auto simp add: program_def mk_program_def RawInit_def RawActs_def
             RawAllowedActs_def, blast+)
 done
 
 lemma surjective_mk_program [simp]:
   "mk_program(Init(F), Acts(F), AllowedActs(F)) = programify(F)"
 by (auto simp add: raw_surjective_mk_program Init_def Acts_def AllowedActs_def)
 
 lemma program_equalityI:                             
     "\<lbrakk>Init(F) = Init(G); Acts(F) = Acts(G);
        AllowedActs(F) = AllowedActs(G); F \<in> program; G \<in> program\<rbrakk> \<Longrightarrow> F = G"
 apply (subgoal_tac "programify(F) = programify(G)") 
 apply simp 
 apply (simp only: surjective_mk_program [symmetric]) 
 done
 
 lemma program_equalityE:                             
  "\<lbrakk>F = G;
     \<lbrakk>Init(F) = Init(G); Acts(F) = Acts(G); AllowedActs(F) = AllowedActs(G)\<rbrakk>
     \<Longrightarrow> P\<rbrakk> 
   \<Longrightarrow> P"
 by force
 
 
 lemma program_equality_iff:
     "\<lbrakk>F \<in> program; G \<in> program\<rbrakk> \<Longrightarrow>(F=G)  \<longleftrightarrow>
      (Init(F) = Init(G) \<and> Acts(F) = Acts(G) \<and> AllowedActs(F) = AllowedActs(G))"
 by (blast intro: program_equalityI program_equalityE)
 
 subsection\<open>These rules allow "lazy" definition expansion\<close>
 
 lemma def_prg_Init:
      "F \<equiv> mk_program (init,acts,allowed) \<Longrightarrow> Init(F) = init \<inter> state"
 by auto
 
 lemma def_prg_Acts:
      "F \<equiv> mk_program (init,acts,allowed)
       \<Longrightarrow> Acts(F) = cons(id(state), acts \<inter> Pow(state*state))"
 by auto
 
 lemma def_prg_AllowedActs:
      "F \<equiv> mk_program (init,acts,allowed)
       \<Longrightarrow> AllowedActs(F) = cons(id(state), allowed \<inter> Pow(state*state))"
 by auto
 
 lemma def_prg_simps:
     "\<lbrakk>F \<equiv> mk_program (init,acts,allowed)\<rbrakk>
      \<Longrightarrow> Init(F) = init \<inter> state \<and> 
          Acts(F) = cons(id(state), acts \<inter> Pow(state*state)) \<and>
          AllowedActs(F) = cons(id(state), allowed \<inter> Pow(state*state))"
 by auto
 
 
 text\<open>An action is expanded only if a pair of states is being tested against it\<close>
 lemma def_act_simp:
      "\<lbrakk>act \<equiv> {<s,s'> \<in> A*B. P(s, s')}\<rbrakk>
       \<Longrightarrow> (<s,s'> \<in> act) \<longleftrightarrow> (<s,s'> \<in> A*B \<and> P(s, s'))"
 by auto
 
 text\<open>A set is expanded only if an element is being tested against it\<close>
 lemma def_set_simp: "A \<equiv> B \<Longrightarrow> (x \<in> A) \<longleftrightarrow> (x \<in> B)"
 by auto
 
 
 subsection\<open>The Constrains Operator\<close>
 
 lemma constrains_type: "A co B \<subseteq> program"
 by (force simp add: constrains_def)
 
 lemma constrainsI:
     "\<lbrakk>(\<And>act s s'. \<lbrakk>act: Acts(F);  <s,s'> \<in> act; s \<in> A\<rbrakk> \<Longrightarrow> s' \<in> A');
         F \<in> program; st_set(A)\<rbrakk>  \<Longrightarrow> F \<in> A co A'"
 by (force simp add: constrains_def)
 
 lemma constrainsD:
    "F \<in> A co B \<Longrightarrow> \<forall>act \<in> Acts(F). act``A\<subseteq>B"
 by (force simp add: constrains_def)
 
 lemma constrainsD2: "F \<in> A co B \<Longrightarrow> F \<in> program \<and> st_set(A)"
 by (force simp add: constrains_def)
 
 lemma constrains_empty [iff]: "F \<in> 0 co B \<longleftrightarrow> F \<in> program"
 by (force simp add: constrains_def st_set_def)
 
 lemma constrains_empty2 [iff]: "(F \<in> A co 0) \<longleftrightarrow> (A=0 \<and> F \<in> program)"
 by (force simp add: constrains_def st_set_def)
 
 lemma constrains_state [iff]: "(F \<in> state co B) \<longleftrightarrow> (state\<subseteq>B \<and> F \<in> program)"
 apply (cut_tac F = F in Acts_type)
 apply (force simp add: constrains_def st_set_def)
 done
 
 lemma constrains_state2 [iff]: "F \<in> A co state \<longleftrightarrow> (F \<in> program \<and> st_set(A))"
 apply (cut_tac F = F in Acts_type)
 apply (force simp add: constrains_def st_set_def)
 done
 
 text\<open>monotonic in 2nd argument\<close>
 lemma constrains_weaken_R:
     "\<lbrakk>F \<in> A co A'; A'\<subseteq>B'\<rbrakk> \<Longrightarrow> F \<in> A co B'"
 apply (unfold constrains_def, blast)
 done
 
 text\<open>anti-monotonic in 1st argument\<close>
 lemma constrains_weaken_L:
     "\<lbrakk>F \<in> A co A'; B\<subseteq>A\<rbrakk> \<Longrightarrow> F \<in> B co A'"
 apply (unfold constrains_def st_set_def, blast)
 done
 
 lemma constrains_weaken:
    "\<lbrakk>F \<in> A co A'; B\<subseteq>A; A'\<subseteq>B'\<rbrakk> \<Longrightarrow> F \<in> B co B'"
 apply (drule constrains_weaken_R)
 apply (drule_tac [2] constrains_weaken_L, blast+)
 done
 
 
 subsection\<open>Constrains and Union\<close>
 
 lemma constrains_Un:
     "\<lbrakk>F \<in> A co A'; F \<in> B co B'\<rbrakk> \<Longrightarrow> F \<in> (A \<union> B) co (A' \<union> B')"
 by (auto simp add: constrains_def st_set_def, force)
 
 lemma constrains_UN:
      "\<lbrakk>\<And>i. i \<in> I \<Longrightarrow> F \<in> A(i) co A'(i); F \<in> program\<rbrakk>
       \<Longrightarrow> F \<in> (\<Union>i \<in> I. A(i)) co (\<Union>i \<in> I. A'(i))"
 by (force simp add: constrains_def st_set_def) 
 
 lemma constrains_Un_distrib:
      "(A \<union> B) co C = (A co C) \<inter> (B co C)"
 by (force simp add: constrains_def st_set_def)
 
 lemma constrains_UN_distrib:
    "i \<in> I \<Longrightarrow> (\<Union>i \<in> I. A(i)) co B = (\<Inter>i \<in> I. A(i) co B)"
 by (force simp add: constrains_def st_set_def)
 
 
 subsection\<open>Constrains and Intersection\<close>
 
 lemma constrains_Int_distrib: "C co (A \<inter> B) = (C co A) \<inter> (C co B)"
 by (force simp add: constrains_def st_set_def)
 
 lemma constrains_INT_distrib:
      "x \<in> I \<Longrightarrow> A co (\<Inter>i \<in> I. B(i)) = (\<Inter>i \<in> I. A co B(i))"
 by (force simp add: constrains_def st_set_def)
 
 lemma constrains_Int:
     "\<lbrakk>F \<in> A co A'; F \<in> B co B'\<rbrakk> \<Longrightarrow> F \<in> (A \<inter> B) co (A' \<inter> B')"
 by (force simp add: constrains_def st_set_def)
 
 lemma constrains_INT [rule_format]:
      "\<lbrakk>\<forall>i \<in> I. F \<in> A(i) co A'(i); F \<in> program\<rbrakk>
       \<Longrightarrow> F \<in> (\<Inter>i \<in> I. A(i)) co (\<Inter>i \<in> I. A'(i))"
 apply (case_tac "I=0")
  apply (simp add: Inter_def)
 apply (erule not_emptyE)
 apply (auto simp add: constrains_def st_set_def, blast) 
 apply (drule bspec, assumption, force) 
 done
 
 (* The rule below simulates the HOL's one for (\<Inter>z. A i) co (\<Inter>z. B i) *)
 lemma constrains_All:
 "\<lbrakk>\<forall>z. F:{s \<in> state. P(s, z)} co {s \<in> state. Q(s, z)}; F \<in> program\<rbrakk>\<Longrightarrow>
     F:{s \<in> state. \<forall>z. P(s, z)} co {s \<in> state. \<forall>z. Q(s, z)}"
 by (unfold constrains_def, blast)
 
 lemma constrains_imp_subset:
   "\<lbrakk>F \<in> A co A'\<rbrakk> \<Longrightarrow> A \<subseteq> A'"
 by (unfold constrains_def st_set_def, force)
 
 text\<open>The reasoning is by subsets since "co" refers to single actions
   only.  So this rule isn't that useful.\<close>
 
 lemma constrains_trans: "\<lbrakk>F \<in> A co B; F \<in> B co C\<rbrakk> \<Longrightarrow> F \<in> A co C"
 by (unfold constrains_def st_set_def, auto, blast)
 
 lemma constrains_cancel:
 "\<lbrakk>F \<in> A co (A' \<union> B); F \<in> B co B'\<rbrakk> \<Longrightarrow> F \<in> A co (A' \<union> B')"
 apply (drule_tac A = B in constrains_imp_subset)
 apply (blast intro: constrains_weaken_R)
 done
 
 
 subsection\<open>The Unless Operator\<close>
 
 lemma unless_type: "A unless B \<subseteq> program"
 by (force simp add: unless_def constrains_def) 
 
 lemma unlessI: "\<lbrakk>F \<in> (A-B) co (A \<union> B)\<rbrakk> \<Longrightarrow> F \<in> A unless B"
   unfolding unless_def
 apply (blast dest: constrainsD2)
 done
 
 lemma unlessD: "F :A unless B \<Longrightarrow> F \<in> (A-B) co (A \<union> B)"
 by (unfold unless_def, auto)
 
 
 subsection\<open>The Operator \<^term>\<open>initially\<close>\<close>
 
 lemma initially_type: "initially(A) \<subseteq> program"
 by (unfold initially_def, blast)
 
 lemma initiallyI: "\<lbrakk>F \<in> program; Init(F)\<subseteq>A\<rbrakk> \<Longrightarrow> F \<in> initially(A)"
 by (unfold initially_def, blast)
 
 lemma initiallyD: "F \<in> initially(A) \<Longrightarrow> Init(F)\<subseteq>A"
 by (unfold initially_def, blast)
 
 
 subsection\<open>The Operator \<^term>\<open>stable\<close>\<close>
 
 lemma stable_type: "stable(A)\<subseteq>program"
 by (unfold stable_def constrains_def, blast)
 
 lemma stableI: "F \<in> A co A \<Longrightarrow> F \<in> stable(A)"
 by (unfold stable_def, assumption)
 
 lemma stableD: "F \<in> stable(A) \<Longrightarrow> F \<in> A co A"
 by (unfold stable_def, assumption)
 
 lemma stableD2: "F \<in> stable(A) \<Longrightarrow> F \<in> program \<and> st_set(A)"
 by (unfold stable_def constrains_def, auto)
 
 lemma stable_state [simp]: "stable(state) = program"
 by (auto simp add: stable_def constrains_def dest: Acts_type [THEN subsetD])
 
 
 lemma stable_unless: "stable(A)= A unless 0"
 by (auto simp add: unless_def stable_def)
 
 
 subsection\<open>Union and Intersection with \<^term>\<open>stable\<close>\<close>
 
 lemma stable_Un:
     "\<lbrakk>F \<in> stable(A); F \<in> stable(A')\<rbrakk> \<Longrightarrow> F \<in> stable(A \<union> A')"
   unfolding stable_def
 apply (blast intro: constrains_Un)
 done
 
 lemma stable_UN:
      "\<lbrakk>\<And>i. i\<in>I \<Longrightarrow> F \<in> stable(A(i)); F \<in> program\<rbrakk> 
       \<Longrightarrow> F \<in> stable (\<Union>i \<in> I. A(i))"
   unfolding stable_def
 apply (blast intro: constrains_UN)
 done
 
 lemma stable_Int:
     "\<lbrakk>F \<in> stable(A);  F \<in> stable(A')\<rbrakk> \<Longrightarrow> F \<in> stable (A \<inter> A')"
   unfolding stable_def
 apply (blast intro: constrains_Int)
 done
 
 lemma stable_INT:
      "\<lbrakk>\<And>i. i \<in> I \<Longrightarrow> F \<in> stable(A(i)); F \<in> program\<rbrakk>
       \<Longrightarrow> F \<in> stable (\<Inter>i \<in> I. A(i))"
   unfolding stable_def
 apply (blast intro: constrains_INT)
 done
 
 lemma stable_All:
     "\<lbrakk>\<forall>z. F \<in> stable({s \<in> state. P(s, z)}); F \<in> program\<rbrakk>
      \<Longrightarrow> F \<in> stable({s \<in> state. \<forall>z. P(s, z)})"
   unfolding stable_def
 apply (rule constrains_All, auto)
 done
 
 lemma stable_constrains_Un:
      "\<lbrakk>F \<in> stable(C); F \<in> A co (C \<union> A')\<rbrakk> \<Longrightarrow> F \<in> (C \<union> A) co (C \<union> A')"
 apply (unfold stable_def constrains_def st_set_def, auto)
 apply (blast dest!: bspec)
 done
 
 lemma stable_constrains_Int:
      "\<lbrakk>F \<in> stable(C); F \<in>  (C \<inter> A) co A'\<rbrakk> \<Longrightarrow> F \<in> (C \<inter> A) co (C \<inter> A')"
 by (unfold stable_def constrains_def st_set_def, blast)
 
 (* \<lbrakk>F \<in> stable(C); F  \<in> (C \<inter> A) co A\<rbrakk> \<Longrightarrow> F \<in> stable(C \<inter> A) *)
 lemmas stable_constrains_stable = stable_constrains_Int [THEN stableI]
 
 subsection\<open>The Operator \<^term>\<open>invariant\<close>\<close>
 
 lemma invariant_type: "invariant(A) \<subseteq> program"
   unfolding invariant_def
 apply (blast dest: stable_type [THEN subsetD])
 done
 
 lemma invariantI: "\<lbrakk>Init(F)\<subseteq>A;  F \<in> stable(A)\<rbrakk> \<Longrightarrow> F \<in> invariant(A)"
-apply (unfold invariant_def initially_def)
+  unfolding invariant_def initially_def
 apply (frule stable_type [THEN subsetD], auto)
 done
 
 lemma invariantD: "F \<in> invariant(A) \<Longrightarrow> Init(F)\<subseteq>A \<and> F \<in> stable(A)"
 by (unfold invariant_def initially_def, auto)
 
 lemma invariantD2: "F \<in> invariant(A) \<Longrightarrow> F \<in> program \<and> st_set(A)"
   unfolding invariant_def
 apply (blast dest: stableD2)
 done
 
 text\<open>Could also say
       \<^term>\<open>invariant(A) \<inter> invariant(B) \<subseteq> invariant (A \<inter> B)\<close>\<close>
 lemma invariant_Int:
   "\<lbrakk>F \<in> invariant(A);  F \<in> invariant(B)\<rbrakk> \<Longrightarrow> F \<in> invariant(A \<inter> B)"
-apply (unfold invariant_def initially_def)
+  unfolding invariant_def initially_def
 apply (simp add: stable_Int, blast)
 done
 
 
 subsection\<open>The Elimination Theorem\<close>
 
 (** The "free" m has become universally quantified!
  Should the premise be \<And>m instead of \<forall>m ? Would make it harder
  to use in forward proof. **)
 
 text\<open>The general case is easier to prove than the special case!\<close>
 lemma "elimination":
     "\<lbrakk>\<forall>m \<in> M. F \<in> {s \<in> A. x(s) = m} co B(m); F \<in> program\<rbrakk>
      \<Longrightarrow> F \<in> {s \<in> A. x(s) \<in> M} co (\<Union>m \<in> M. B(m))"
 by (auto simp add: constrains_def st_set_def, blast)
 
 text\<open>As above, but for the special case of A=state\<close>
 lemma elimination2:
      "\<lbrakk>\<forall>m \<in> M. F \<in> {s \<in> state. x(s) = m} co B(m); F \<in> program\<rbrakk>
      \<Longrightarrow> F:{s \<in> state. x(s) \<in> M} co (\<Union>m \<in> M. B(m))"
 by (rule UNITY.elimination, auto)
 
 subsection\<open>The Operator \<^term>\<open>strongest_rhs\<close>\<close>
 
 lemma constrains_strongest_rhs:
     "\<lbrakk>F \<in> program; st_set(A)\<rbrakk> \<Longrightarrow> F \<in> A co (strongest_rhs(F,A))"
 by (auto simp add: constrains_def strongest_rhs_def st_set_def
               dest: Acts_type [THEN subsetD])
 
 lemma strongest_rhs_is_strongest:
      "\<lbrakk>F \<in> A co B; st_set(B)\<rbrakk> \<Longrightarrow> strongest_rhs(F,A) \<subseteq> B"
 by (auto simp add: constrains_def strongest_rhs_def st_set_def)
 
 ML \<open>
 fun simp_of_act def = def RS @{thm def_act_simp};
 fun simp_of_set def = def RS @{thm def_set_simp};
 \<close>
 
 end
diff --git a/src/ZF/UNITY/Union.thy b/src/ZF/UNITY/Union.thy
--- a/src/ZF/UNITY/Union.thy
+++ b/src/ZF/UNITY/Union.thy
@@ -1,576 +1,576 @@
 (*  Title:      ZF/UNITY/Union.thy
     Author:     Sidi O Ehmety, Computer Laboratory
     Copyright   2001  University of Cambridge
 
 Unions of programs
 
 Partly from Misra's Chapter 5 \<in> Asynchronous Compositions of Programs
 
 Theory ported form HOL..
 
 *)
 
 theory Union imports SubstAx FP
 begin
 
 definition
   (*FIXME: conjoin Init(F) \<inter> Init(G) \<noteq> 0 *)
   ok :: "[i, i] \<Rightarrow> o"     (infixl \<open>ok\<close> 65)  where
     "F ok G \<equiv> Acts(F) \<subseteq> AllowedActs(G) \<and>
                Acts(G) \<subseteq> AllowedActs(F)"
 
 definition
   (*FIXME: conjoin (\<Inter>i \<in> I. Init(F(i))) \<noteq> 0 *)
   OK  :: "[i, i\<Rightarrow>i] \<Rightarrow> o"  where
     "OK(I,F) \<equiv> (\<forall>i \<in> I. \<forall>j \<in> I-{i}. Acts(F(i)) \<subseteq> AllowedActs(F(j)))"
 
 definition
   JOIN  :: "[i, i\<Rightarrow>i] \<Rightarrow> i"  where
   "JOIN(I,F) \<equiv> if I = 0 then SKIP else
                  mk_program(\<Inter>i \<in> I. Init(F(i)), \<Union>i \<in> I. Acts(F(i)),
                  \<Inter>i \<in> I. AllowedActs(F(i)))"
 
 definition
   Join :: "[i, i] \<Rightarrow> i"  (infixl \<open>\<squnion>\<close> 65)  where
   "F \<squnion> G \<equiv> mk_program (Init(F) \<inter> Init(G), Acts(F) \<union> Acts(G),
                                 AllowedActs(F) \<inter> AllowedActs(G))"
 definition
   (*Characterizes safety properties.  Used with specifying AllowedActs*)
   safety_prop :: "i \<Rightarrow> o"  where
   "safety_prop(X) \<equiv> X\<subseteq>program \<and>
       SKIP \<in> X \<and> (\<forall>G \<in> program. Acts(G) \<subseteq> (\<Union>F \<in> X. Acts(F)) \<longrightarrow> G \<in> X)"
 
 syntax
   "_JOIN1"  :: "[pttrns, i] \<Rightarrow> i"     (\<open>(3\<Squnion>_./ _)\<close> 10)
   "_JOIN"   :: "[pttrn, i, i] \<Rightarrow> i"   (\<open>(3\<Squnion>_ \<in> _./ _)\<close> 10)
 
 translations
   "\<Squnion>x \<in> A. B" == "CONST JOIN(A, (\<lambda>x. B))"
   "\<Squnion>x y. B"   == "\<Squnion>x. \<Squnion>y. B"
   "\<Squnion>x. B"     == "CONST JOIN(CONST state, (\<lambda>x. B))"
 
 
 subsection\<open>SKIP\<close>
 
 lemma reachable_SKIP [simp]: "reachable(SKIP) = state"
 by (force elim: reachable.induct intro: reachable.intros)
 
 text\<open>Elimination programify from ok and \<squnion>\<close>
 
 lemma ok_programify_left [iff]: "programify(F) ok G \<longleftrightarrow> F ok G"
 by (simp add: ok_def)
 
 lemma ok_programify_right [iff]: "F ok programify(G) \<longleftrightarrow> F ok G"
 by (simp add: ok_def)
 
 lemma Join_programify_left [simp]: "programify(F) \<squnion> G = F \<squnion> G"
 by (simp add: Join_def)
 
 lemma Join_programify_right [simp]: "F \<squnion> programify(G) = F \<squnion> G"
 by (simp add: Join_def)
 
 subsection\<open>SKIP and safety properties\<close>
 
 lemma SKIP_in_constrains_iff [iff]: "(SKIP \<in> A co B) \<longleftrightarrow> (A\<subseteq>B \<and> st_set(A))"
 by (unfold constrains_def st_set_def, auto)
 
 lemma SKIP_in_Constrains_iff [iff]: "(SKIP \<in> A Co B)\<longleftrightarrow> (state \<inter> A\<subseteq>B)"
 by (unfold Constrains_def, auto)
 
 lemma SKIP_in_stable [iff]: "SKIP \<in> stable(A) \<longleftrightarrow> st_set(A)"
 by (auto simp add: stable_def)
 
 lemma SKIP_in_Stable [iff]: "SKIP \<in> Stable(A)"
 by (unfold Stable_def, auto)
 
 subsection\<open>Join and JOIN types\<close>
 
 lemma Join_in_program [iff,TC]: "F \<squnion> G \<in> program"
 by (unfold Join_def, auto)
 
 lemma JOIN_in_program [iff,TC]: "JOIN(I,F) \<in> program"
 by (unfold JOIN_def, auto)
 
 subsection\<open>Init, Acts, and AllowedActs of Join and JOIN\<close>
 lemma Init_Join [simp]: "Init(F \<squnion> G) = Init(F) \<inter> Init(G)"
 by (simp add: Int_assoc Join_def)
 
 lemma Acts_Join [simp]: "Acts(F \<squnion> G) = Acts(F) \<union> Acts(G)"
 by (simp add: Int_Un_distrib2 cons_absorb Join_def)
 
 lemma AllowedActs_Join [simp]: "AllowedActs(F \<squnion> G) =
   AllowedActs(F) \<inter> AllowedActs(G)"
 apply (simp add: Int_assoc cons_absorb Join_def)
 done
 
 subsection\<open>Join's algebraic laws\<close>
 
 lemma Join_commute: "F \<squnion> G = G \<squnion> F"
 by (simp add: Join_def Un_commute Int_commute)
 
 lemma Join_left_commute: "A \<squnion> (B \<squnion> C) = B \<squnion> (A \<squnion> C)"
 apply (simp add: Join_def Int_Un_distrib2 cons_absorb)
 apply (simp add: Un_ac Int_ac Int_Un_distrib2 cons_absorb)
 done
 
 lemma Join_assoc: "(F \<squnion> G) \<squnion> H = F \<squnion> (G \<squnion> H)"
 by (simp add: Un_ac Join_def cons_absorb Int_assoc Int_Un_distrib2)
 
 subsection\<open>Needed below\<close>
 lemma cons_id [simp]: "cons(id(state), Pow(state * state)) = Pow(state*state)"
 by auto
 
 lemma Join_SKIP_left [simp]: "SKIP \<squnion> F = programify(F)"
-apply (unfold Join_def SKIP_def)
+  unfolding Join_def SKIP_def
 apply (auto simp add: Int_absorb cons_eq)
 done
 
 lemma Join_SKIP_right [simp]: "F \<squnion> SKIP =  programify(F)"
 apply (subst Join_commute)
 apply (simp add: Join_SKIP_left)
 done
 
 lemma Join_absorb [simp]: "F \<squnion> F = programify(F)"
 by (rule program_equalityI, auto)
 
 lemma Join_left_absorb: "F \<squnion> (F \<squnion> G) = F \<squnion> G"
 by (simp add: Join_assoc [symmetric])
 
 subsection\<open>Join is an AC-operator\<close>
 lemmas Join_ac = Join_assoc Join_left_absorb Join_commute Join_left_commute
 
 subsection\<open>Eliminating programify form JOIN and OK expressions\<close>
 
 lemma OK_programify [iff]: "OK(I, \<lambda>x. programify(F(x))) \<longleftrightarrow> OK(I, F)"
 by (simp add: OK_def)
 
 lemma JOIN_programify [iff]: "JOIN(I, \<lambda>x. programify(F(x))) = JOIN(I, F)"
 by (simp add: JOIN_def)
 
 
 subsection\<open>JOIN\<close>
 
 lemma JOIN_empty [simp]: "JOIN(0, F) = SKIP"
 by (unfold JOIN_def, auto)
 
 lemma Init_JOIN [simp]:
      "Init(\<Squnion>i \<in> I. F(i)) = (if I=0 then state else (\<Inter>i \<in> I. Init(F(i))))"
 by (simp add: JOIN_def INT_extend_simps del: INT_simps)
 
 lemma Acts_JOIN [simp]:
      "Acts(JOIN(I,F)) = cons(id(state), \<Union>i \<in> I.  Acts(F(i)))"
   unfolding JOIN_def
 apply (auto simp del: INT_simps UN_simps)
 apply (rule equalityI)
 apply (auto dest: Acts_type [THEN subsetD])
 done
 
 lemma AllowedActs_JOIN [simp]:
      "AllowedActs(\<Squnion>i \<in> I. F(i)) =
       (if I=0 then Pow(state*state) else (\<Inter>i \<in> I. AllowedActs(F(i))))"
 apply (unfold JOIN_def, auto)
 apply (rule equalityI)
 apply (auto elim!: not_emptyE dest: AllowedActs_type [THEN subsetD])
 done
 
 lemma JOIN_cons [simp]: "(\<Squnion>i \<in> cons(a,I). F(i)) = F(a) \<squnion> (\<Squnion>i \<in> I. F(i))"
 by (rule program_equalityI, auto)
 
 lemma JOIN_cong [cong]:
     "\<lbrakk>I=J;  \<And>i. i \<in> J \<Longrightarrow> F(i) = G(i)\<rbrakk> \<Longrightarrow>
      (\<Squnion>i \<in> I. F(i)) = (\<Squnion>i \<in> J. G(i))"
 by (simp add: JOIN_def)
 
 
 
 subsection\<open>JOIN laws\<close>
 lemma JOIN_absorb: "k \<in> I \<Longrightarrow>F(k) \<squnion> (\<Squnion>i \<in> I. F(i)) = (\<Squnion>i \<in> I. F(i))"
 apply (subst JOIN_cons [symmetric])
 apply (auto simp add: cons_absorb)
 done
 
 lemma JOIN_Un: "(\<Squnion>i \<in> I \<union> J. F(i)) = ((\<Squnion>i \<in> I. F(i)) \<squnion> (\<Squnion>i \<in> J. F(i)))"
 apply (rule program_equalityI)
 apply (simp_all add: UN_Un INT_Un)
 apply (simp_all del: INT_simps add: INT_extend_simps, blast)
 done
 
 lemma JOIN_constant: "(\<Squnion>i \<in> I. c) = (if I=0 then SKIP else programify(c))"
 by (rule program_equalityI, auto)
 
 lemma JOIN_Join_distrib:
      "(\<Squnion>i \<in> I. F(i) \<squnion> G(i)) = (\<Squnion>i \<in> I. F(i))  \<squnion>  (\<Squnion>i \<in> I. G(i))"
 apply (rule program_equalityI)
 apply (simp_all add: INT_Int_distrib, blast)
 done
 
 lemma JOIN_Join_miniscope: "(\<Squnion>i \<in> I. F(i) \<squnion> G) = ((\<Squnion>i \<in> I. F(i) \<squnion> G))"
 by (simp add: JOIN_Join_distrib JOIN_constant)
 
 text\<open>Used to prove guarantees_JOIN_I\<close>
 lemma JOIN_Join_diff: "i \<in> I\<Longrightarrow>F(i) \<squnion> JOIN(I - {i}, F) = JOIN(I, F)"
 apply (rule program_equalityI)
 apply (auto elim!: not_emptyE)
 done
 
 subsection\<open>Safety: co, stable, FP\<close>
 
 
 (*Fails if I=0 because it collapses to SKIP \<in> A co B, i.e. to A\<subseteq>B.  So an
   alternative precondition is A\<subseteq>B, but most proofs using this rule require
   I to be nonempty for other reasons anyway.*)
 
 lemma JOIN_constrains:
  "i \<in> I\<Longrightarrow>(\<Squnion>i \<in> I. F(i)) \<in> A co B \<longleftrightarrow> (\<forall>i \<in> I. programify(F(i)) \<in> A co B)"
 
 apply (unfold constrains_def JOIN_def st_set_def, auto)
 prefer 2 apply blast
 apply (rename_tac j act y z)
 apply (cut_tac F = "F (j) " in Acts_type)
 apply (drule_tac x = act in bspec, auto)
 done
 
 lemma Join_constrains [iff]:
      "(F \<squnion> G \<in> A co B) \<longleftrightarrow> (programify(F) \<in> A co B \<and> programify(G) \<in> A co B)"
 by (auto simp add: constrains_def)
 
 lemma Join_unless [iff]:
      "(F \<squnion> G \<in> A unless B) \<longleftrightarrow>
     (programify(F) \<in> A unless B \<and> programify(G) \<in> A unless B)"
 by (simp add: Join_constrains unless_def)
 
 
 (*Analogous weak versions FAIL; see Misra [1994] 5.4.1, Substitution Axiom.
   reachable (F \<squnion> G) could be much bigger than reachable F, reachable G
 *)
 
 lemma Join_constrains_weaken:
      "\<lbrakk>F \<in> A co A';  G \<in> B co B'\<rbrakk>
       \<Longrightarrow> F \<squnion> G \<in> (A \<inter> B) co (A' \<union> B')"
 apply (subgoal_tac "st_set (A) \<and> st_set (B) \<and> F \<in> program \<and> G \<in> program")
 prefer 2 apply (blast dest: constrainsD2, simp)
 apply (blast intro: constrains_weaken)
 done
 
 (*If I=0, it degenerates to SKIP \<in> state co 0, which is false.*)
 lemma JOIN_constrains_weaken:
   assumes major: "(\<And>i. i \<in> I \<Longrightarrow> F(i) \<in> A(i) co A'(i))"
       and minor: "i \<in> I"
   shows "(\<Squnion>i \<in> I. F(i)) \<in> (\<Inter>i \<in> I. A(i)) co (\<Union>i \<in> I. A'(i))"
 apply (cut_tac minor)
 apply (simp (no_asm_simp) add: JOIN_constrains)
 apply clarify
 apply (rename_tac "j")
 apply (frule_tac i = j in major)
 apply (frule constrainsD2, simp)
 apply (blast intro: constrains_weaken)
 done
 
 lemma JOIN_stable:
      "(\<Squnion>i \<in> I. F(i)) \<in>  stable(A) \<longleftrightarrow> ((\<forall>i \<in> I. programify(F(i)) \<in> stable(A)) \<and> st_set(A))"
 apply (auto simp add: stable_def constrains_def JOIN_def)
 apply (cut_tac F = "F (i) " in Acts_type)
 apply (drule_tac x = act in bspec, auto)
 done
 
 lemma initially_JOIN_I:
   assumes major: "(\<And>i. i \<in> I \<Longrightarrow>F(i) \<in> initially(A))"
       and minor: "i \<in> I"
   shows  "(\<Squnion>i \<in> I. F(i)) \<in> initially(A)"
 apply (cut_tac minor)
 apply (auto elim!: not_emptyE simp add: Inter_iff initially_def)
 apply (frule_tac i = x in major)
 apply (auto simp add: initially_def)
 done
 
 lemma invariant_JOIN_I:
   assumes major: "(\<And>i. i \<in> I \<Longrightarrow> F(i) \<in> invariant(A))"
       and minor: "i \<in> I"
   shows "(\<Squnion>i \<in> I. F(i)) \<in> invariant(A)"
 apply (cut_tac minor)
 apply (auto intro!: initially_JOIN_I dest: major simp add: invariant_def JOIN_stable)
 apply (erule_tac V = "i \<in> I" in thin_rl)
 apply (frule major)
 apply (drule_tac [2] major)
 apply (auto simp add: invariant_def)
 apply (frule stableD2, force)+
 done
 
 lemma Join_stable [iff]:
      " (F \<squnion> G \<in> stable(A)) \<longleftrightarrow>
       (programify(F) \<in> stable(A) \<and> programify(G) \<in>  stable(A))"
 by (simp add: stable_def)
 
 lemma initially_JoinI [intro!]:
      "\<lbrakk>F \<in> initially(A); G \<in> initially(A)\<rbrakk> \<Longrightarrow> F \<squnion> G \<in> initially(A)"
 by (unfold initially_def, auto)
 
 lemma invariant_JoinI:
      "\<lbrakk>F \<in> invariant(A); G \<in> invariant(A)\<rbrakk>
       \<Longrightarrow> F \<squnion> G \<in> invariant(A)"
 apply (subgoal_tac "F \<in> program\<and>G \<in> program")
 prefer 2 apply (blast dest: invariantD2)
 apply (simp add: invariant_def)
 apply (auto intro: Join_in_program)
 done
 
 
 (* Fails if I=0 because \<Inter>i \<in> 0. A(i) = 0 *)
 lemma FP_JOIN: "i \<in> I \<Longrightarrow> FP(\<Squnion>i \<in> I. F(i)) = (\<Inter>i \<in> I. FP (programify(F(i))))"
 by (auto simp add: FP_def Inter_def st_set_def JOIN_stable)
 
 subsection\<open>Progress: transient, ensures\<close>
 
 lemma JOIN_transient:
      "i \<in> I \<Longrightarrow>
       (\<Squnion>i \<in> I. F(i)) \<in> transient(A) \<longleftrightarrow> (\<exists>i \<in> I. programify(F(i)) \<in> transient(A))"
 apply (auto simp add: transient_def JOIN_def)
   unfolding st_set_def
 apply (drule_tac [2] x = act in bspec)
 apply (auto dest: Acts_type [THEN subsetD])
 done
 
 lemma Join_transient [iff]:
      "F \<squnion> G \<in> transient(A) \<longleftrightarrow>
       (programify(F) \<in> transient(A) | programify(G) \<in> transient(A))"
 apply (auto simp add: transient_def Join_def Int_Un_distrib2)
 done
 
 lemma Join_transient_I1: "F \<in> transient(A) \<Longrightarrow> F \<squnion> G \<in> transient(A)"
 by (simp add: Join_transient transientD2)
 
 
 lemma Join_transient_I2: "G \<in> transient(A) \<Longrightarrow> F \<squnion> G \<in> transient(A)"
 by (simp add: Join_transient transientD2)
 
 (*If I=0 it degenerates to (SKIP \<in> A ensures B) = False, i.e. to \<not>(A\<subseteq>B) *)
 lemma JOIN_ensures:
      "i \<in> I \<Longrightarrow>
       (\<Squnion>i \<in> I. F(i)) \<in> A ensures B \<longleftrightarrow>
       ((\<forall>i \<in> I. programify(F(i)) \<in> (A-B) co (A \<union> B)) \<and>
       (\<exists>i \<in> I. programify(F(i)) \<in> A ensures B))"
 by (auto simp add: ensures_def JOIN_constrains JOIN_transient)
 
 
 lemma Join_ensures:
      "F \<squnion> G \<in> A ensures B  \<longleftrightarrow>
       (programify(F) \<in> (A-B) co (A \<union> B) \<and> programify(G) \<in> (A-B) co (A \<union> B) \<and>
        (programify(F) \<in>  transient (A-B) | programify(G) \<in> transient (A-B)))"
 
   unfolding ensures_def
 apply (auto simp add: Join_transient)
 done
 
 lemma stable_Join_constrains:
     "\<lbrakk>F \<in> stable(A);  G \<in> A co A'\<rbrakk>
      \<Longrightarrow> F \<squnion> G \<in> A co A'"
-apply (unfold stable_def constrains_def Join_def st_set_def)
+  unfolding stable_def constrains_def Join_def st_set_def
 apply (cut_tac F = F in Acts_type)
 apply (cut_tac F = G in Acts_type, force)
 done
 
 (*Premise for G cannot use Always because  F \<in> Stable A  is
    weaker than G \<in> stable A *)
 lemma stable_Join_Always1:
      "\<lbrakk>F \<in> stable(A);  G \<in> invariant(A)\<rbrakk> \<Longrightarrow> F \<squnion> G \<in> Always(A)"
 apply (subgoal_tac "F \<in> program \<and> G \<in> program \<and> st_set (A) ")
 prefer 2 apply (blast dest: invariantD2 stableD2)
 apply (simp add: Always_def invariant_def initially_def Stable_eq_stable)
 apply (force intro: stable_Int)
 done
 
 (*As above, but exchanging the roles of F and G*)
 lemma stable_Join_Always2:
      "\<lbrakk>F \<in> invariant(A);  G \<in> stable(A)\<rbrakk> \<Longrightarrow> F \<squnion> G \<in> Always(A)"
 apply (subst Join_commute)
 apply (blast intro: stable_Join_Always1)
 done
 
 
 
 lemma stable_Join_ensures1:
      "\<lbrakk>F \<in> stable(A);  G \<in> A ensures B\<rbrakk> \<Longrightarrow> F \<squnion> G \<in> A ensures B"
 apply (subgoal_tac "F \<in> program \<and> G \<in> program \<and> st_set (A) ")
 prefer 2 apply (blast dest: stableD2 ensures_type [THEN subsetD])
 apply (simp (no_asm_simp) add: Join_ensures)
 apply (simp add: stable_def ensures_def)
 apply (erule constrains_weaken, auto)
 done
 
 
 (*As above, but exchanging the roles of F and G*)
 lemma stable_Join_ensures2:
      "\<lbrakk>F \<in> A ensures B;  G \<in> stable(A)\<rbrakk> \<Longrightarrow> F \<squnion> G \<in> A ensures B"
 apply (subst Join_commute)
 apply (blast intro: stable_Join_ensures1)
 done
 
 subsection\<open>The ok and OK relations\<close>
 
 lemma ok_SKIP1 [iff]: "SKIP ok F"
 by (auto dest: Acts_type [THEN subsetD] simp add: ok_def)
 
 lemma ok_SKIP2 [iff]: "F ok SKIP"
 by (auto dest: Acts_type [THEN subsetD] simp add: ok_def)
 
 lemma ok_Join_commute:
      "(F ok G \<and> (F \<squnion> G) ok H) \<longleftrightarrow> (G ok H \<and> F ok (G \<squnion> H))"
 by (auto simp add: ok_def)
 
 lemma ok_commute: "(F ok G) \<longleftrightarrow>(G ok F)"
 by (auto simp add: ok_def)
 
 lemmas ok_sym = ok_commute [THEN iffD1]
 
 lemma ok_iff_OK: "OK({\<langle>0,F\<rangle>,\<langle>1,G\<rangle>,\<langle>2,H\<rangle>}, snd) \<longleftrightarrow> (F ok G \<and> (F \<squnion> G) ok H)"
 by (simp add: ok_def Join_def OK_def Int_assoc cons_absorb
                  Int_Un_distrib2 Ball_def,  safe, force+)
 
 lemma ok_Join_iff1 [iff]: "F ok (G \<squnion> H) \<longleftrightarrow> (F ok G \<and> F ok H)"
 by (auto simp add: ok_def)
 
 lemma ok_Join_iff2 [iff]: "(G \<squnion> H) ok F \<longleftrightarrow> (G ok F \<and> H ok F)"
 by (auto simp add: ok_def)
 
 (*useful?  Not with the previous two around*)
 lemma ok_Join_commute_I: "\<lbrakk>F ok G; (F \<squnion> G) ok H\<rbrakk> \<Longrightarrow> F ok (G \<squnion> H)"
 by (auto simp add: ok_def)
 
 lemma ok_JOIN_iff1 [iff]: "F ok JOIN(I,G) \<longleftrightarrow> (\<forall>i \<in> I. F ok G(i))"
 by (force dest: Acts_type [THEN subsetD] elim!: not_emptyE simp add: ok_def)
 
 lemma ok_JOIN_iff2 [iff]: "JOIN(I,G) ok F   \<longleftrightarrow>  (\<forall>i \<in> I. G(i) ok F)"
 apply (auto elim!: not_emptyE simp add: ok_def)
 apply (blast dest: Acts_type [THEN subsetD])
 done
 
 lemma OK_iff_ok: "OK(I,F) \<longleftrightarrow> (\<forall>i \<in> I. \<forall>j \<in> I-{i}. F(i) ok (F(j)))"
 by (auto simp add: ok_def OK_def)
 
 lemma OK_imp_ok: "\<lbrakk>OK(I,F); i \<in> I; j \<in> I; i\<noteq>j\<rbrakk> \<Longrightarrow> F(i) ok F(j)"
 by (auto simp add: OK_iff_ok)
 
 
 lemma OK_0 [iff]: "OK(0,F)"
 by (simp add: OK_def)
 
 lemma OK_cons_iff:
      "OK(cons(i, I), F) \<longleftrightarrow>
       (i \<in> I \<and> OK(I, F)) | (i\<notin>I \<and> OK(I, F) \<and> F(i) ok JOIN(I,F))"
 apply (simp add: OK_iff_ok)
 apply (blast intro: ok_sym)
 done
 
 
 subsection\<open>Allowed\<close>
 
 lemma Allowed_SKIP [simp]: "Allowed(SKIP) = program"
 by (auto dest: Acts_type [THEN subsetD] simp add: Allowed_def)
 
 lemma Allowed_Join [simp]:
      "Allowed(F \<squnion> G) =
    Allowed(programify(F)) \<inter> Allowed(programify(G))"
 apply (auto simp add: Allowed_def)
 done
 
 lemma Allowed_JOIN [simp]:
      "i \<in> I \<Longrightarrow>
    Allowed(JOIN(I,F)) = (\<Inter>i \<in> I. Allowed(programify(F(i))))"
 apply (auto simp add: Allowed_def, blast)
 done
 
 lemma ok_iff_Allowed:
      "F ok G \<longleftrightarrow> (programify(F) \<in> Allowed(programify(G)) \<and>
    programify(G) \<in> Allowed(programify(F)))"
 by (simp add: ok_def Allowed_def)
 
 
 lemma OK_iff_Allowed:
      "OK(I,F) \<longleftrightarrow>
   (\<forall>i \<in> I. \<forall>j \<in> I-{i}. programify(F(i)) \<in> Allowed(programify(F(j))))"
 apply (auto simp add: OK_iff_ok ok_iff_Allowed)
 done
 
 subsection\<open>safety_prop, for reasoning about given instances of "ok"\<close>
 
 lemma safety_prop_Acts_iff:
      "safety_prop(X) \<Longrightarrow> (Acts(G) \<subseteq> cons(id(state), (\<Union>F \<in> X. Acts(F)))) \<longleftrightarrow> (programify(G) \<in> X)"
 apply (simp (no_asm_use) add: safety_prop_def)
 apply clarify
 apply (case_tac "G \<in> program", simp_all, blast, safe)
 prefer 2 apply force
 apply (force simp add: programify_def)
 done
 
 lemma safety_prop_AllowedActs_iff_Allowed:
      "safety_prop(X) \<Longrightarrow>
   (\<Union>G \<in> X. Acts(G)) \<subseteq> AllowedActs(F) \<longleftrightarrow> (X \<subseteq> Allowed(programify(F)))"
 apply (simp add: Allowed_def safety_prop_Acts_iff [THEN iff_sym]
                  safety_prop_def, blast)
 done
 
 
 lemma Allowed_eq:
      "safety_prop(X) \<Longrightarrow> Allowed(mk_program(init, acts, \<Union>F \<in> X. Acts(F))) = X"
 apply (subgoal_tac "cons (id (state), \<Union>(RepFun (X, Acts)) \<inter> Pow (state * state)) = \<Union>(RepFun (X, Acts))")
 apply (rule_tac [2] equalityI)
   apply (simp del: UN_simps add: Allowed_def safety_prop_Acts_iff safety_prop_def, auto)
 apply (force dest: Acts_type [THEN subsetD] simp add: safety_prop_def)+
 done
 
 lemma def_prg_Allowed:
      "\<lbrakk>F \<equiv> mk_program (init, acts, \<Union>F \<in> X. Acts(F)); safety_prop(X)\<rbrakk>
       \<Longrightarrow> Allowed(F) = X"
 by (simp add: Allowed_eq)
 
 (*For safety_prop to hold, the property must be satisfiable!*)
 lemma safety_prop_constrains [iff]:
      "safety_prop(A co B) \<longleftrightarrow> (A \<subseteq> B \<and> st_set(A))"
 by (simp add: safety_prop_def constrains_def st_set_def, blast)
 
 (* To be used with resolution *)
 lemma safety_prop_constrainsI [iff]:
      "\<lbrakk>A\<subseteq>B; st_set(A)\<rbrakk> \<Longrightarrow>safety_prop(A co B)"
 by auto
 
 lemma safety_prop_stable [iff]: "safety_prop(stable(A)) \<longleftrightarrow> st_set(A)"
 by (simp add: stable_def)
 
 lemma safety_prop_stableI: "st_set(A) \<Longrightarrow> safety_prop(stable(A))"
 by auto
 
 lemma safety_prop_Int [simp]:
      "\<lbrakk>safety_prop(X) ; safety_prop(Y)\<rbrakk> \<Longrightarrow> safety_prop(X \<inter> Y)"
 apply (simp add: safety_prop_def, safe, blast)
 apply (drule_tac [2] B = "\<Union>(RepFun (X \<inter> Y, Acts))" and C = "\<Union>(RepFun (Y, Acts))" in subset_trans)
 apply (drule_tac B = "\<Union>(RepFun (X \<inter> Y, Acts))" and C = "\<Union>(RepFun (X, Acts))" in subset_trans)
 apply blast+
 done
 
 (* If I=0 the conclusion becomes safety_prop(0) which is false *)
 lemma safety_prop_Inter:
   assumes major: "(\<And>i. i \<in> I \<Longrightarrow>safety_prop(X(i)))"
       and minor: "i \<in> I"
   shows "safety_prop(\<Inter>i \<in> I. X(i))"
 apply (simp add: safety_prop_def)
 apply (cut_tac minor, safe)
 apply (simp (no_asm_use) add: Inter_iff)
 apply clarify
 apply (frule major)
 apply (drule_tac [2] i = xa in major)
 apply (frule_tac [4] i = xa in major)
 apply (auto simp add: safety_prop_def)
 apply (drule_tac B = "\<Union>(RepFun (\<Inter>(RepFun (I, X)), Acts))" and C = "\<Union>(RepFun (X (xa), Acts))" in subset_trans)
 apply blast+
 done
 
 lemma def_UNION_ok_iff:
 "\<lbrakk>F \<equiv> mk_program(init,acts, \<Union>G \<in> X. Acts(G)); safety_prop(X)\<rbrakk>
       \<Longrightarrow> F ok G \<longleftrightarrow> (programify(G) \<in> X \<and> acts \<inter> Pow(state*state) \<subseteq> AllowedActs(G))"
   unfolding ok_def
 apply (drule_tac G = G in safety_prop_Acts_iff)
 apply (cut_tac F = G in AllowedActs_type)
 apply (cut_tac F = G in Acts_type, auto)
 done
 
 end
diff --git a/src/ZF/UNITY/WFair.thy b/src/ZF/UNITY/WFair.thy
--- a/src/ZF/UNITY/WFair.thy
+++ b/src/ZF/UNITY/WFair.thy
@@ -1,707 +1,707 @@
 (*  Title:      ZF/UNITY/WFair.thy
     Author:     Sidi Ehmety, Computer Laboratory
     Copyright   1998  University of Cambridge
 *)
 
 section\<open>Progress under Weak Fairness\<close>
 
 theory WFair
 imports UNITY ZFC
 begin
 
 text\<open>This theory defines the operators transient, ensures and leadsTo,
 assuming weak fairness. From Misra, "A Logic for Concurrent Programming",
 1994.\<close>
 
 definition
   (* This definition specifies weak fairness.  The rest of the theory
     is generic to all forms of fairness.*)
   transient :: "i\<Rightarrow>i"  where
   "transient(A) \<equiv>{F \<in> program. (\<exists>act\<in>Acts(F). A<=domain(act) \<and>
                                act``A \<subseteq> state-A) \<and> st_set(A)}"
 
 definition
   ensures :: "[i,i] \<Rightarrow> i"       (infixl \<open>ensures\<close> 60)  where
   "A ensures B \<equiv> ((A-B) co (A \<union> B)) \<inter> transient(A-B)"
 
 consts
 
   (*LEADS-TO constant for the inductive definition*)
   leads :: "[i, i]\<Rightarrow>i"
 
 inductive
   domains
      "leads(D, F)" \<subseteq> "Pow(D)*Pow(D)"
   intros
     Basis:  "\<lbrakk>F \<in> A ensures B;  A \<in> Pow(D); B \<in> Pow(D)\<rbrakk> \<Longrightarrow> \<langle>A,B\<rangle>:leads(D, F)"
     Trans:  "\<lbrakk>\<langle>A,B\<rangle> \<in> leads(D, F); \<langle>B,C\<rangle> \<in> leads(D, F)\<rbrakk> \<Longrightarrow>  \<langle>A,C\<rangle>:leads(D, F)"
     Union:   "\<lbrakk>S \<in> Pow({A \<in> S. \<langle>A, B\<rangle>:leads(D, F)}); B \<in> Pow(D); S \<in> Pow(Pow(D))\<rbrakk> \<Longrightarrow>
               <\<Union>(S),B>:leads(D, F)"
 
   monos        Pow_mono
   type_intros  Union_Pow_iff [THEN iffD2] UnionI PowI
 
 definition
   (* The Visible version of the LEADS-TO relation*)
   leadsTo :: "[i, i] \<Rightarrow> i"       (infixl \<open>\<longmapsto>\<close> 60)  where
   "A \<longmapsto> B \<equiv> {F \<in> program. \<langle>A,B\<rangle>:leads(state, F)}"
 
 definition
   (* wlt(F, B) is the largest set that leads to B*)
   wlt :: "[i, i] \<Rightarrow> i"  where
     "wlt(F, B) \<equiv> \<Union>({A \<in> Pow(state). F \<in> A \<longmapsto> B})"
 
 (** Ad-hoc set-theory rules **)
 
 lemma Int_Union_Union: "\<Union>(B) \<inter> A = (\<Union>b \<in> B. b \<inter> A)"
 by auto
 
 lemma Int_Union_Union2: "A \<inter> \<Union>(B) = (\<Union>b \<in> B. A \<inter> b)"
 by auto
 
 (*** transient ***)
 
 lemma transient_type: "transient(A)<=program"
 by (unfold transient_def, auto)
 
 lemma transientD2:
 "F \<in> transient(A) \<Longrightarrow> F \<in> program \<and> st_set(A)"
 apply (unfold transient_def, auto)
 done
 
 lemma stable_transient_empty: "\<lbrakk>F \<in> stable(A); F \<in> transient(A)\<rbrakk> \<Longrightarrow> A = 0"
 by (simp add: stable_def constrains_def transient_def, fast)
 
 lemma transient_strengthen: "\<lbrakk>F \<in> transient(A); B<=A\<rbrakk> \<Longrightarrow> F \<in> transient(B)"
 apply (simp add: transient_def st_set_def, clarify)
 apply (blast intro!: rev_bexI)
 done
 
 lemma transientI:
 "\<lbrakk>act \<in> Acts(F); A \<subseteq> domain(act); act``A \<subseteq> state-A;
     F \<in> program; st_set(A)\<rbrakk> \<Longrightarrow> F \<in> transient(A)"
 by (simp add: transient_def, blast)
 
 lemma transientE:
      "\<lbrakk>F \<in> transient(A);
          \<And>act. \<lbrakk>act \<in> Acts(F);  A \<subseteq> domain(act); act``A \<subseteq> state-A\<rbrakk>\<Longrightarrow>P\<rbrakk>
       \<Longrightarrow>P"
 by (simp add: transient_def, blast)
 
 lemma transient_state: "transient(state) = 0"
 apply (simp add: transient_def)
 apply (rule equalityI, auto)
 apply (cut_tac F = x in Acts_type)
 apply (simp add: Diff_cancel)
 apply (auto intro: st0_in_state)
 done
 
 lemma transient_state2: "state<=B \<Longrightarrow> transient(B) = 0"
 apply (simp add: transient_def st_set_def)
 apply (rule equalityI, auto)
 apply (cut_tac F = x in Acts_type)
 apply (subgoal_tac "B=state")
 apply (auto intro: st0_in_state)
 done
 
 lemma transient_empty: "transient(0) = program"
 by (auto simp add: transient_def)
 
 declare transient_empty [simp] transient_state [simp] transient_state2 [simp]
 
 (*** ensures ***)
 
 lemma ensures_type: "A ensures B <=program"
 by (simp add: ensures_def constrains_def, auto)
 
 lemma ensuresI:
 "\<lbrakk>F:(A-B) co (A \<union> B); F \<in> transient(A-B)\<rbrakk>\<Longrightarrow>F \<in> A ensures B"
   unfolding ensures_def
 apply (auto simp add: transient_type [THEN subsetD])
 done
 
 (* Added by Sidi, from Misra's notes, Progress chapter, exercise 4 *)
 lemma ensuresI2: "\<lbrakk>F \<in> A co A \<union> B; F \<in> transient(A)\<rbrakk> \<Longrightarrow> F \<in> A ensures B"
 apply (drule_tac B = "A-B" in constrains_weaken_L)
 apply (drule_tac [2] B = "A-B" in transient_strengthen)
 apply (auto simp add: ensures_def transient_type [THEN subsetD])
 done
 
 lemma ensuresD: "F \<in> A ensures B \<Longrightarrow> F:(A-B) co (A \<union> B) \<and> F \<in> transient (A-B)"
 by (unfold ensures_def, auto)
 
 lemma ensures_weaken_R: "\<lbrakk>F \<in> A ensures A'; A'<=B'\<rbrakk> \<Longrightarrow> F \<in> A ensures B'"
   unfolding ensures_def
 apply (blast intro: transient_strengthen constrains_weaken)
 done
 
 (*The L-version (precondition strengthening) fails, but we have this*)
 lemma stable_ensures_Int:
      "\<lbrakk>F \<in> stable(C);  F \<in> A ensures B\<rbrakk> \<Longrightarrow> F:(C \<inter> A) ensures (C \<inter> B)"
 
   unfolding ensures_def
 apply (simp (no_asm) add: Int_Un_distrib [symmetric] Diff_Int_distrib [symmetric])
 apply (blast intro: transient_strengthen stable_constrains_Int constrains_weaken)
 done
 
 lemma stable_transient_ensures: "\<lbrakk>F \<in> stable(A);  F \<in> transient(C); A<=B \<union> C\<rbrakk> \<Longrightarrow> F \<in> A ensures B"
 apply (frule stable_type [THEN subsetD])
 apply (simp add: ensures_def stable_def)
 apply (blast intro: transient_strengthen constrains_weaken)
 done
 
 lemma ensures_eq: "(A ensures B) = (A unless B) \<inter> transient (A-B)"
 by (auto simp add: ensures_def unless_def)
 
 lemma subset_imp_ensures: "\<lbrakk>F \<in> program; A<=B\<rbrakk> \<Longrightarrow> F \<in> A ensures B"
 by (auto simp add: ensures_def constrains_def transient_def st_set_def)
 
 (*** leadsTo ***)
 lemmas leads_left = leads.dom_subset [THEN subsetD, THEN SigmaD1]
 lemmas leads_right = leads.dom_subset [THEN subsetD, THEN SigmaD2]
 
 lemma leadsTo_type: "A \<longmapsto> B \<subseteq> program"
 by (unfold leadsTo_def, auto)
 
 lemma leadsToD2:
 "F \<in> A \<longmapsto> B \<Longrightarrow> F \<in> program \<and> st_set(A) \<and> st_set(B)"
-apply (unfold leadsTo_def st_set_def)
+  unfolding leadsTo_def st_set_def
 apply (blast dest: leads_left leads_right)
 done
 
 lemma leadsTo_Basis:
     "\<lbrakk>F \<in> A ensures B; st_set(A); st_set(B)\<rbrakk> \<Longrightarrow> F \<in> A \<longmapsto> B"
-apply (unfold leadsTo_def st_set_def)
+  unfolding leadsTo_def st_set_def
 apply (cut_tac ensures_type)
 apply (auto intro: leads.Basis)
 done
 declare leadsTo_Basis [intro]
 
 (* Added by Sidi, from Misra's notes, Progress chapter, exercise number 4 *)
 (* \<lbrakk>F \<in> program; A<=B;  st_set(A); st_set(B)\<rbrakk> \<Longrightarrow> A \<longmapsto> B *)
 lemmas subset_imp_leadsTo = subset_imp_ensures [THEN leadsTo_Basis]
 
 lemma leadsTo_Trans: "\<lbrakk>F \<in> A \<longmapsto> B;  F \<in> B \<longmapsto> C\<rbrakk>\<Longrightarrow>F \<in> A \<longmapsto> C"
   unfolding leadsTo_def
 apply (auto intro: leads.Trans)
 done
 
 (* Better when used in association with leadsTo_weaken_R *)
 lemma transient_imp_leadsTo: "F \<in> transient(A) \<Longrightarrow> F \<in> A \<longmapsto> (state-A)"
   unfolding transient_def
 apply (blast intro: ensuresI [THEN leadsTo_Basis] constrains_weaken transientI)
 done
 
 (*Useful with cancellation, disjunction*)
 lemma leadsTo_Un_duplicate: "F \<in> A \<longmapsto> (A' \<union> A') \<Longrightarrow> F \<in> A \<longmapsto> A'"
 by simp
 
 lemma leadsTo_Un_duplicate2:
      "F \<in> A \<longmapsto> (A' \<union> C \<union> C) \<Longrightarrow> F \<in> A \<longmapsto> (A' \<union> C)"
 by (simp add: Un_ac)
 
 (*The Union introduction rule as we should have liked to state it*)
 lemma leadsTo_Union:
     "\<lbrakk>\<And>A. A \<in> S \<Longrightarrow> F \<in> A \<longmapsto> B; F \<in> program; st_set(B)\<rbrakk>
      \<Longrightarrow> F \<in> \<Union>(S) \<longmapsto> B"
-apply (unfold leadsTo_def st_set_def)
+  unfolding leadsTo_def st_set_def
 apply (blast intro: leads.Union dest: leads_left)
 done
 
 lemma leadsTo_Union_Int:
     "\<lbrakk>\<And>A. A \<in> S \<Longrightarrow>F \<in> (A \<inter> C) \<longmapsto> B; F \<in> program; st_set(B)\<rbrakk>
      \<Longrightarrow> F \<in> (\<Union>(S)Int C)\<longmapsto> B"
-apply (unfold leadsTo_def st_set_def)
+  unfolding leadsTo_def st_set_def
 apply (simp only: Int_Union_Union)
 apply (blast dest: leads_left intro: leads.Union)
 done
 
 lemma leadsTo_UN:
     "\<lbrakk>\<And>i. i \<in> I \<Longrightarrow> F \<in> A(i) \<longmapsto> B; F \<in> program; st_set(B)\<rbrakk>
      \<Longrightarrow> F:(\<Union>i \<in> I. A(i)) \<longmapsto> B"
 apply (simp add: Int_Union_Union leadsTo_def st_set_def)
 apply (blast dest: leads_left intro: leads.Union)
 done
 
 (* Binary union introduction rule *)
 lemma leadsTo_Un:
      "\<lbrakk>F \<in> A \<longmapsto> C; F \<in> B \<longmapsto> C\<rbrakk> \<Longrightarrow> F \<in> (A \<union> B) \<longmapsto> C"
 apply (subst Un_eq_Union)
 apply (blast intro: leadsTo_Union dest: leadsToD2)
 done
 
 lemma single_leadsTo_I:
     "\<lbrakk>\<And>x. x \<in> A\<Longrightarrow> F:{x} \<longmapsto> B; F \<in> program; st_set(B)\<rbrakk>
      \<Longrightarrow> F \<in> A \<longmapsto> B"
 apply (rule_tac b = A in UN_singleton [THEN subst])
 apply (rule leadsTo_UN, auto)
 done
 
 lemma leadsTo_refl: "\<lbrakk>F \<in> program; st_set(A)\<rbrakk> \<Longrightarrow> F \<in> A \<longmapsto> A"
 by (blast intro: subset_imp_leadsTo)
 
 lemma leadsTo_refl_iff: "F \<in> A \<longmapsto> A \<longleftrightarrow> F \<in> program \<and> st_set(A)"
 by (auto intro: leadsTo_refl dest: leadsToD2)
 
 lemma empty_leadsTo: "F \<in> 0 \<longmapsto> B \<longleftrightarrow> (F \<in> program \<and> st_set(B))"
 by (auto intro: subset_imp_leadsTo dest: leadsToD2)
 declare empty_leadsTo [iff]
 
 lemma leadsTo_state: "F \<in> A \<longmapsto> state \<longleftrightarrow> (F \<in> program \<and> st_set(A))"
 by (auto intro: subset_imp_leadsTo dest: leadsToD2 st_setD)
 declare leadsTo_state [iff]
 
 lemma leadsTo_weaken_R: "\<lbrakk>F \<in> A \<longmapsto> A'; A'<=B'; st_set(B')\<rbrakk> \<Longrightarrow> F \<in> A \<longmapsto> B'"
 by (blast dest: leadsToD2 intro: subset_imp_leadsTo leadsTo_Trans)
 
 lemma leadsTo_weaken_L: "\<lbrakk>F \<in> A \<longmapsto> A'; B<=A\<rbrakk> \<Longrightarrow> F \<in> B \<longmapsto> A'"
 apply (frule leadsToD2)
 apply (blast intro: leadsTo_Trans subset_imp_leadsTo st_set_subset)
 done
 
 lemma leadsTo_weaken: "\<lbrakk>F \<in> A \<longmapsto> A'; B<=A; A'<=B'; st_set(B')\<rbrakk>\<Longrightarrow> F \<in> B \<longmapsto> B'"
 apply (frule leadsToD2)
 apply (blast intro: leadsTo_weaken_R leadsTo_weaken_L leadsTo_Trans leadsTo_refl)
 done
 
 (* This rule has a nicer conclusion *)
 lemma transient_imp_leadsTo2: "\<lbrakk>F \<in> transient(A); state-A<=B; st_set(B)\<rbrakk> \<Longrightarrow> F \<in> A \<longmapsto> B"
 apply (frule transientD2)
 apply (rule leadsTo_weaken_R)
 apply (auto simp add: transient_imp_leadsTo)
 done
 
 (*Distributes over binary unions*)
 lemma leadsTo_Un_distrib: "F:(A \<union> B) \<longmapsto> C  \<longleftrightarrow>  (F \<in> A \<longmapsto> C \<and> F \<in> B \<longmapsto> C)"
 by (blast intro: leadsTo_Un leadsTo_weaken_L)
 
 lemma leadsTo_UN_distrib:
 "(F:(\<Union>i \<in> I. A(i)) \<longmapsto> B)\<longleftrightarrow> ((\<forall>i \<in> I. F \<in> A(i) \<longmapsto> B) \<and> F \<in> program \<and> st_set(B))"
 apply (blast dest: leadsToD2 intro: leadsTo_UN leadsTo_weaken_L)
 done
 
 lemma leadsTo_Union_distrib: "(F \<in> \<Union>(S) \<longmapsto> B) \<longleftrightarrow>  (\<forall>A \<in> S. F \<in> A \<longmapsto> B) \<and> F \<in> program \<and> st_set(B)"
 by (blast dest: leadsToD2 intro: leadsTo_Union leadsTo_weaken_L)
 
 text\<open>Set difference: maybe combine with \<open>leadsTo_weaken_L\<close>??\<close>
 lemma leadsTo_Diff:
      "\<lbrakk>F: (A-B) \<longmapsto> C; F \<in> B \<longmapsto> C; st_set(C)\<rbrakk>
       \<Longrightarrow> F \<in> A \<longmapsto> C"
 by (blast intro: leadsTo_Un leadsTo_weaken dest: leadsToD2)
 
 lemma leadsTo_UN_UN:
     "\<lbrakk>\<And>i. i \<in> I \<Longrightarrow> F \<in> A(i) \<longmapsto> A'(i); F \<in> program\<rbrakk>
      \<Longrightarrow> F: (\<Union>i \<in> I. A(i)) \<longmapsto> (\<Union>i \<in> I. A'(i))"
 apply (rule leadsTo_Union)
 apply (auto intro: leadsTo_weaken_R dest: leadsToD2)
 done
 
 (*Binary union version*)
 lemma leadsTo_Un_Un: "\<lbrakk>F \<in> A \<longmapsto> A'; F \<in> B \<longmapsto> B'\<rbrakk> \<Longrightarrow> F \<in> (A \<union> B) \<longmapsto> (A' \<union> B')"
 apply (subgoal_tac "st_set (A) \<and> st_set (A') \<and> st_set (B) \<and> st_set (B') ")
 prefer 2 apply (blast dest: leadsToD2)
 apply (blast intro: leadsTo_Un leadsTo_weaken_R)
 done
 
 (** The cancellation law **)
 lemma leadsTo_cancel2: "\<lbrakk>F \<in> A \<longmapsto> (A' \<union> B); F \<in> B \<longmapsto> B'\<rbrakk> \<Longrightarrow> F \<in> A \<longmapsto> (A' \<union> B')"
 apply (subgoal_tac "st_set (A) \<and> st_set (A') \<and> st_set (B) \<and> st_set (B') \<and>F \<in> program")
 prefer 2 apply (blast dest: leadsToD2)
 apply (blast intro: leadsTo_Trans leadsTo_Un_Un leadsTo_refl)
 done
 
 lemma leadsTo_cancel_Diff2: "\<lbrakk>F \<in> A \<longmapsto> (A' \<union> B); F \<in> (B-A') \<longmapsto> B'\<rbrakk>\<Longrightarrow> F \<in> A \<longmapsto> (A' \<union> B')"
 apply (rule leadsTo_cancel2)
 prefer 2 apply assumption
 apply (blast dest: leadsToD2 intro: leadsTo_weaken_R)
 done
 
 
 lemma leadsTo_cancel1: "\<lbrakk>F \<in> A \<longmapsto> (B \<union> A'); F \<in> B \<longmapsto> B'\<rbrakk> \<Longrightarrow> F \<in> A \<longmapsto> (B' \<union> A')"
 apply (simp add: Un_commute)
 apply (blast intro!: leadsTo_cancel2)
 done
 
 lemma leadsTo_cancel_Diff1:
      "\<lbrakk>F \<in> A \<longmapsto> (B \<union> A'); F: (B-A') \<longmapsto> B'\<rbrakk>\<Longrightarrow> F \<in> A \<longmapsto> (B' \<union> A')"
 apply (rule leadsTo_cancel1)
 prefer 2 apply assumption
 apply (blast intro: leadsTo_weaken_R dest: leadsToD2)
 done
 
 (*The INDUCTION rule as we should have liked to state it*)
 lemma leadsTo_induct:
   assumes major: "F \<in> za \<longmapsto> zb"
       and basis: "\<And>A B. \<lbrakk>F \<in> A ensures B; st_set(A); st_set(B)\<rbrakk> \<Longrightarrow> P(A,B)"
       and trans: "\<And>A B C. \<lbrakk>F \<in> A \<longmapsto> B; P(A, B);
                               F \<in> B \<longmapsto> C; P(B, C)\<rbrakk> \<Longrightarrow> P(A,C)"
       and union: "\<And>B S. \<lbrakk>\<forall>A \<in> S. F \<in> A \<longmapsto> B; \<forall>A \<in> S. P(A,B);
                            st_set(B); \<forall>A \<in> S. st_set(A)\<rbrakk> \<Longrightarrow> P(\<Union>(S), B)"
   shows "P(za, zb)"
 apply (cut_tac major)
 apply (unfold leadsTo_def, clarify)
 apply (erule leads.induct)
   apply (blast intro: basis [unfolded st_set_def])
  apply (blast intro: trans [unfolded leadsTo_def])
 apply (force intro: union [unfolded st_set_def leadsTo_def])
 done
 
 
 (* Added by Sidi, an induction rule without ensures *)
 lemma leadsTo_induct2:
   assumes major: "F \<in> za \<longmapsto> zb"
       and basis1: "\<And>A B. \<lbrakk>A<=B; st_set(B)\<rbrakk> \<Longrightarrow> P(A, B)"
       and basis2: "\<And>A B. \<lbrakk>F \<in> A co A \<union> B; F \<in> transient(A); st_set(B)\<rbrakk>
                           \<Longrightarrow> P(A, B)"
       and trans: "\<And>A B C. \<lbrakk>F \<in> A \<longmapsto> B; P(A, B);
                               F \<in> B \<longmapsto> C; P(B, C)\<rbrakk> \<Longrightarrow> P(A,C)"
       and union: "\<And>B S. \<lbrakk>\<forall>A \<in> S. F \<in> A \<longmapsto> B; \<forall>A \<in> S. P(A,B);
                            st_set(B); \<forall>A \<in> S. st_set(A)\<rbrakk> \<Longrightarrow> P(\<Union>(S), B)"
   shows "P(za, zb)"
 apply (cut_tac major)
 apply (erule leadsTo_induct)
 apply (auto intro: trans union)
 apply (simp add: ensures_def, clarify)
 apply (frule constrainsD2)
 apply (drule_tac B' = " (A-B) \<union> B" in constrains_weaken_R)
 apply blast
 apply (frule ensuresI2 [THEN leadsTo_Basis])
 apply (drule_tac [4] basis2, simp_all)
 apply (frule_tac A1 = A and B = B in Int_lower2 [THEN basis1])
 apply (subgoal_tac "A=\<Union>({A - B, A \<inter> B}) ")
 prefer 2 apply blast
 apply (erule ssubst)
 apply (rule union)
 apply (auto intro: subset_imp_leadsTo)
 done
 
 
 (** Variant induction rule: on the preconditions for B **)
 (*Lemma is the weak version: can't see how to do it in one step*)
 lemma leadsTo_induct_pre_aux:
   "\<lbrakk>F \<in> za \<longmapsto> zb;
       P(zb);
       \<And>A B. \<lbrakk>F \<in> A ensures B;  P(B); st_set(A); st_set(B)\<rbrakk> \<Longrightarrow> P(A);
       \<And>S. \<lbrakk>\<forall>A \<in> S. P(A); \<forall>A \<in> S. st_set(A)\<rbrakk> \<Longrightarrow> P(\<Union>(S))
 \<rbrakk> \<Longrightarrow> P(za)"
 txt\<open>by induction on this formula\<close>
 apply (subgoal_tac "P (zb) \<longrightarrow> P (za) ")
 txt\<open>now solve first subgoal: this formula is sufficient\<close>
 apply (blast intro: leadsTo_refl)
 apply (erule leadsTo_induct)
 apply (blast+)
 done
 
 
 lemma leadsTo_induct_pre:
   "\<lbrakk>F \<in> za \<longmapsto> zb;
       P(zb);
       \<And>A B. \<lbrakk>F \<in> A ensures B;  F \<in> B \<longmapsto> zb;  P(B); st_set(A)\<rbrakk> \<Longrightarrow> P(A);
       \<And>S. \<forall>A \<in> S. F \<in> A \<longmapsto> zb \<and> P(A) \<and> st_set(A) \<Longrightarrow> P(\<Union>(S))
 \<rbrakk> \<Longrightarrow> P(za)"
 apply (subgoal_tac " (F \<in> za \<longmapsto> zb) \<and> P (za) ")
 apply (erule conjunct2)
 apply (frule leadsToD2)
 apply (erule leadsTo_induct_pre_aux)
 prefer 3 apply (blast dest: leadsToD2 intro: leadsTo_Union)
 prefer 2 apply (blast intro: leadsTo_Trans leadsTo_Basis)
 apply (blast intro: leadsTo_refl)
 done
 
 (** The impossibility law **)
 lemma leadsTo_empty:
    "F \<in> A \<longmapsto> 0 \<Longrightarrow> A=0"
 apply (erule leadsTo_induct_pre)
 apply (auto simp add: ensures_def constrains_def transient_def st_set_def)
 apply (drule bspec, assumption)+
 apply blast
 done
 declare leadsTo_empty [simp]
 
 subsection\<open>PSP: Progress-Safety-Progress\<close>
 
 text\<open>Special case of PSP: Misra's "stable conjunction"\<close>
 
 lemma psp_stable:
    "\<lbrakk>F \<in> A \<longmapsto> A'; F \<in> stable(B)\<rbrakk> \<Longrightarrow> F:(A \<inter> B) \<longmapsto> (A' \<inter> B)"
   unfolding stable_def
 apply (frule leadsToD2)
 apply (erule leadsTo_induct)
 prefer 3 apply (blast intro: leadsTo_Union_Int)
 prefer 2 apply (blast intro: leadsTo_Trans)
 apply (rule leadsTo_Basis)
 apply (simp add: ensures_def Diff_Int_distrib2 [symmetric] Int_Un_distrib2 [symmetric])
 apply (auto intro: transient_strengthen constrains_Int)
 done
 
 
 lemma psp_stable2: "\<lbrakk>F \<in> A \<longmapsto> A'; F \<in> stable(B)\<rbrakk>\<Longrightarrow>F: (B \<inter> A) \<longmapsto> (B \<inter> A')"
 apply (simp (no_asm_simp) add: psp_stable Int_ac)
 done
 
 lemma psp_ensures:
 "\<lbrakk>F \<in> A ensures A'; F \<in> B co B'\<rbrakk>\<Longrightarrow> F: (A \<inter> B') ensures ((A' \<inter> B) \<union> (B' - B))"
-apply (unfold ensures_def constrains_def st_set_def)
+  unfolding ensures_def constrains_def st_set_def
 (*speeds up the proof*)
 apply clarify
 apply (blast intro: transient_strengthen)
 done
 
 lemma psp:
 "\<lbrakk>F \<in> A \<longmapsto> A'; F \<in> B co B'; st_set(B')\<rbrakk>\<Longrightarrow> F:(A \<inter> B') \<longmapsto> ((A' \<inter> B) \<union> (B' - B))"
 apply (subgoal_tac "F \<in> program \<and> st_set (A) \<and> st_set (A') \<and> st_set (B) ")
 prefer 2 apply (blast dest!: constrainsD2 leadsToD2)
 apply (erule leadsTo_induct)
 prefer 3 apply (blast intro: leadsTo_Union_Int)
  txt\<open>Basis case\<close>
  apply (blast intro: psp_ensures leadsTo_Basis)
 txt\<open>Transitivity case has a delicate argument involving "cancellation"\<close>
 apply (rule leadsTo_Un_duplicate2)
 apply (erule leadsTo_cancel_Diff1)
 apply (simp add: Int_Diff Diff_triv)
 apply (blast intro: leadsTo_weaken_L dest: constrains_imp_subset)
 done
 
 
 lemma psp2: "\<lbrakk>F \<in> A \<longmapsto> A'; F \<in> B co B'; st_set(B')\<rbrakk>
     \<Longrightarrow> F \<in> (B' \<inter> A) \<longmapsto> ((B \<inter> A') \<union> (B' - B))"
 by (simp (no_asm_simp) add: psp Int_ac)
 
 lemma psp_unless:
    "\<lbrakk>F \<in> A \<longmapsto> A';  F \<in> B unless B'; st_set(B); st_set(B')\<rbrakk>
     \<Longrightarrow> F \<in> (A \<inter> B) \<longmapsto> ((A' \<inter> B) \<union> B')"
   unfolding unless_def
 apply (subgoal_tac "st_set (A) \<and>st_set (A') ")
 prefer 2 apply (blast dest: leadsToD2)
 apply (drule psp, assumption, blast)
 apply (blast intro: leadsTo_weaken)
 done
 
 
 subsection\<open>Proving the induction rules\<close>
 
 (** The most general rule \<in> r is any wf relation; f is any variant function **)
 lemma leadsTo_wf_induct_aux: "\<lbrakk>wf(r);
          m \<in> I;
          field(r)<=I;
          F \<in> program; st_set(B);
          \<forall>m \<in> I. F \<in> (A \<inter> f-``{m}) \<longmapsto>
                     ((A \<inter> f-``(converse(r)``{m})) \<union> B)\<rbrakk>
       \<Longrightarrow> F \<in> (A \<inter> f-``{m}) \<longmapsto> B"
 apply (erule_tac a = m in wf_induct2, simp_all)
 apply (subgoal_tac "F \<in> (A \<inter> (f-`` (converse (r) ``{x}))) \<longmapsto> B")
  apply (blast intro: leadsTo_cancel1 leadsTo_Un_duplicate)
 apply (subst vimage_eq_UN)
 apply (simp del: UN_simps add: Int_UN_distrib)
 apply (auto intro: leadsTo_UN simp del: UN_simps simp add: Int_UN_distrib)
 done
 
 (** Meta or object quantifier ? **)
 lemma leadsTo_wf_induct: "\<lbrakk>wf(r);
          field(r)<=I;
          A<=f-``I;
          F \<in> program; st_set(A); st_set(B);
          \<forall>m \<in> I. F \<in> (A \<inter> f-``{m}) \<longmapsto>
                     ((A \<inter> f-``(converse(r)``{m})) \<union> B)\<rbrakk>
       \<Longrightarrow> F \<in> A \<longmapsto> B"
 apply (rule_tac b = A in subst)
  defer 1
  apply (rule_tac I = I in leadsTo_UN)
  apply (erule_tac I = I in leadsTo_wf_induct_aux, assumption+, best)
 done
 
 lemma nat_measure_field: "field(measure(nat, \<lambda>x. x)) = nat"
   unfolding field_def
 apply (simp add: measure_def)
 apply (rule equalityI, force, clarify)
 apply (erule_tac V = "x\<notin>range (y)" for y in thin_rl)
 apply (erule nat_induct)
 apply (rule_tac [2] b = "succ (succ (xa))" in domainI)
 apply (rule_tac b = "succ (0) " in domainI)
 apply simp_all
 done
 
 
 lemma Image_inverse_lessThan: "k<A \<Longrightarrow> measure(A, \<lambda>x. x) -`` {k} = k"
 apply (rule equalityI)
 apply (auto simp add: measure_def)
 apply (blast intro: ltD)
 apply (rule vimageI)
 prefer 2 apply blast
 apply (simp add: lt_Ord lt_Ord2 Ord_mem_iff_lt)
 apply (blast intro: lt_trans)
 done
 
 (*Alternative proof is via the lemma F \<in> (A \<inter> f-`(lessThan m)) \<longmapsto> B*)
 lemma lessThan_induct:
  "\<lbrakk>A<=f-``nat;
      F \<in> program; st_set(A); st_set(B);
      \<forall>m \<in> nat. F:(A \<inter> f-``{m}) \<longmapsto> ((A \<inter> f -`` m) \<union> B)\<rbrakk>
       \<Longrightarrow> F \<in> A \<longmapsto> B"
 apply (rule_tac A1 = nat and f1 = "\<lambda>x. x" in wf_measure [THEN leadsTo_wf_induct])
 apply (simp_all add: nat_measure_field)
 apply (simp add: ltI Image_inverse_lessThan vimage_def [symmetric])
 done
 
 
 (*** wlt ****)
 
 (*Misra's property W3*)
 lemma wlt_type: "wlt(F,B) <=state"
 by (unfold wlt_def, auto)
 
 lemma wlt_st_set: "st_set(wlt(F, B))"
   unfolding st_set_def
 apply (rule wlt_type)
 done
 declare wlt_st_set [iff]
 
 lemma wlt_leadsTo_iff: "F \<in> wlt(F, B) \<longmapsto> B \<longleftrightarrow> (F \<in> program \<and> st_set(B))"
   unfolding wlt_def
 apply (blast dest: leadsToD2 intro!: leadsTo_Union)
 done
 
 (* \<lbrakk>F \<in> program;  st_set(B)\<rbrakk> \<Longrightarrow> F \<in> wlt(F, B) \<longmapsto> B  *)
 lemmas wlt_leadsTo = conjI [THEN wlt_leadsTo_iff [THEN iffD2]]
 
 lemma leadsTo_subset: "F \<in> A \<longmapsto> B \<Longrightarrow> A \<subseteq> wlt(F, B)"
   unfolding wlt_def
 apply (frule leadsToD2)
 apply (auto simp add: st_set_def)
 done
 
 (*Misra's property W2*)
 lemma leadsTo_eq_subset_wlt: "F \<in> A \<longmapsto> B \<longleftrightarrow> (A \<subseteq> wlt(F,B) \<and> F \<in> program \<and> st_set(B))"
 apply auto
 apply (blast dest: leadsToD2 leadsTo_subset intro: leadsTo_weaken_L wlt_leadsTo)+
 done
 
 (*Misra's property W4*)
 lemma wlt_increasing: "\<lbrakk>F \<in> program; st_set(B)\<rbrakk> \<Longrightarrow> B \<subseteq> wlt(F,B)"
 apply (rule leadsTo_subset)
 apply (simp (no_asm_simp) add: leadsTo_eq_subset_wlt [THEN iff_sym] subset_imp_leadsTo)
 done
 
 (*Used in the Trans case below*)
 lemma leadsTo_123_aux:
    "\<lbrakk>B \<subseteq> A2;
        F \<in> (A1 - B) co (A1 \<union> B);
        F \<in> (A2 - C) co (A2 \<union> C)\<rbrakk>
     \<Longrightarrow> F \<in> (A1 \<union> A2 - C) co (A1 \<union> A2 \<union> C)"
 apply (unfold constrains_def st_set_def, blast)
 done
 
 (*Lemma (1,2,3) of Misra's draft book, Chapter 4, "Progress"*)
 (* slightly different from the HOL one \<in> B here is bounded *)
 lemma leadsTo_123: "F \<in> A \<longmapsto> A'
       \<Longrightarrow> \<exists>B \<in> Pow(state). A<=B \<and> F \<in> B \<longmapsto> A' \<and> F \<in> (B-A') co (B \<union> A')"
 apply (frule leadsToD2)
 apply (erule leadsTo_induct)
   txt\<open>Basis\<close>
   apply (blast dest: ensuresD constrainsD2 st_setD)
  txt\<open>Trans\<close>
  apply clarify
  apply (rule_tac x = "Ba \<union> Bb" in bexI)
  apply (blast intro: leadsTo_123_aux leadsTo_Un_Un leadsTo_cancel1 leadsTo_Un_duplicate, blast)
 txt\<open>Union\<close>
 apply (clarify dest!: ball_conj_distrib [THEN iffD1])
 apply (subgoal_tac "\<exists>y. y \<in> Pi (S, \<lambda>A. {Ba \<in> Pow (state) . A<=Ba \<and> F \<in> Ba \<longmapsto> B \<and> F \<in> Ba - B co Ba \<union> B}) ")
 defer 1
 apply (rule AC_ball_Pi, safe)
 apply (rotate_tac 1)
 apply (drule_tac x = x in bspec, blast, blast)
 apply (rule_tac x = "\<Union>A \<in> S. y`A" in bexI, safe)
 apply (rule_tac [3] I1 = S in constrains_UN [THEN constrains_weaken])
 apply (rule_tac [2] leadsTo_Union)
 prefer 5 apply (blast dest!: apply_type, simp_all)
 apply (force dest!: apply_type)+
 done
 
 
 (*Misra's property W5*)
 lemma wlt_constrains_wlt: "\<lbrakk>F \<in> program; st_set(B)\<rbrakk> \<Longrightarrow>F \<in> (wlt(F, B) - B) co (wlt(F,B))"
 apply (cut_tac F = F in wlt_leadsTo [THEN leadsTo_123], assumption, blast)
 apply clarify
 apply (subgoal_tac "Ba = wlt (F,B) ")
 prefer 2 apply (blast dest: leadsTo_eq_subset_wlt [THEN iffD1], clarify)
 apply (simp add: wlt_increasing [THEN subset_Un_iff2 [THEN iffD1]])
 done
 
 
 subsection\<open>Completion: Binary and General Finite versions\<close>
 
 lemma completion_aux: "\<lbrakk>W = wlt(F, (B' \<union> C));
        F \<in> A \<longmapsto> (A' \<union> C);  F \<in> A' co (A' \<union> C);
        F \<in> B \<longmapsto> (B' \<union> C);  F \<in> B' co (B' \<union> C)\<rbrakk>
     \<Longrightarrow> F \<in> (A \<inter> B) \<longmapsto> ((A' \<inter> B') \<union> C)"
 apply (subgoal_tac "st_set (C) \<and>st_set (W) \<and>st_set (W-C) \<and>st_set (A') \<and>st_set (A) \<and> st_set (B) \<and> st_set (B') \<and> F \<in> program")
  prefer 2
  apply simp
  apply (blast dest!: leadsToD2)
 apply (subgoal_tac "F \<in> (W-C) co (W \<union> B' \<union> C) ")
  prefer 2
  apply (blast intro!: constrains_weaken [OF constrains_Un [OF _ wlt_constrains_wlt]])
 apply (subgoal_tac "F \<in> (W-C) co W")
  prefer 2
  apply (simp add: wlt_increasing [THEN subset_Un_iff2 [THEN iffD1]] Un_assoc)
 apply (subgoal_tac "F \<in> (A \<inter> W - C) \<longmapsto> (A' \<inter> W \<union> C) ")
  prefer 2 apply (blast intro: wlt_leadsTo psp [THEN leadsTo_weaken])
 (** step 13 **)
 apply (subgoal_tac "F \<in> (A' \<inter> W \<union> C) \<longmapsto> (A' \<inter> B' \<union> C) ")
 apply (drule leadsTo_Diff)
 apply (blast intro: subset_imp_leadsTo dest: leadsToD2 constrainsD2)
 apply (force simp add: st_set_def)
 apply (subgoal_tac "A \<inter> B \<subseteq> A \<inter> W")
 prefer 2 apply (blast dest!: leadsTo_subset intro!: subset_refl [THEN Int_mono])
 apply (blast intro: leadsTo_Trans subset_imp_leadsTo)
 txt\<open>last subgoal\<close>
 apply (rule_tac leadsTo_Un_duplicate2)
 apply (rule_tac leadsTo_Un_Un)
  prefer 2 apply (blast intro: leadsTo_refl)
 apply (rule_tac A'1 = "B' \<union> C" in wlt_leadsTo[THEN psp2, THEN leadsTo_weaken])
 apply blast+
 done
 
 lemmas completion = refl [THEN completion_aux]
 
 lemma finite_completion_aux:
      "\<lbrakk>I \<in> Fin(X); F \<in> program; st_set(C)\<rbrakk> \<Longrightarrow>
        (\<forall>i \<in> I. F \<in> (A(i)) \<longmapsto> (A'(i) \<union> C)) \<longrightarrow>
                      (\<forall>i \<in> I. F \<in> (A'(i)) co (A'(i) \<union> C)) \<longrightarrow>
                    F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto> ((\<Inter>i \<in> I. A'(i)) \<union> C)"
 apply (erule Fin_induct)
 apply (auto simp add: Inter_0)
 apply (rule completion)
 apply (auto simp del: INT_simps simp add: INT_extend_simps)
 apply (blast intro: constrains_INT)
 done
 
 lemma finite_completion:
      "\<lbrakk>I \<in> Fin(X);
          \<And>i. i \<in> I \<Longrightarrow> F \<in> A(i) \<longmapsto> (A'(i) \<union> C);
          \<And>i. i \<in> I \<Longrightarrow> F \<in> A'(i) co (A'(i) \<union> C); F \<in> program; st_set(C)\<rbrakk>
       \<Longrightarrow> F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto> ((\<Inter>i \<in> I. A'(i)) \<union> C)"
 by (blast intro: finite_completion_aux [THEN mp, THEN mp])
 
 lemma stable_completion:
      "\<lbrakk>F \<in> A \<longmapsto> A';  F \<in> stable(A');
          F \<in> B \<longmapsto> B';  F \<in> stable(B')\<rbrakk>
     \<Longrightarrow> F \<in> (A \<inter> B) \<longmapsto> (A' \<inter> B')"
   unfolding stable_def
 apply (rule_tac C1 = 0 in completion [THEN leadsTo_weaken_R], simp+)
 apply (blast dest: leadsToD2)
 done
 
 
 lemma finite_stable_completion:
      "\<lbrakk>I \<in> Fin(X);
          (\<And>i. i \<in> I \<Longrightarrow> F \<in> A(i) \<longmapsto> A'(i));
          (\<And>i. i \<in> I \<Longrightarrow> F \<in> stable(A'(i)));  F \<in> program\<rbrakk>
       \<Longrightarrow> F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto> (\<Inter>i \<in> I. A'(i))"
   unfolding stable_def
 apply (subgoal_tac "st_set (\<Inter>i \<in> I. A' (i))")
 prefer 2 apply (blast dest: leadsToD2)
 apply (rule_tac C1 = 0 in finite_completion [THEN leadsTo_weaken_R], auto)
 done
 
 end
diff --git a/src/ZF/WF.thy b/src/ZF/WF.thy
--- a/src/ZF/WF.thy
+++ b/src/ZF/WF.thy
@@ -1,372 +1,372 @@
 (*  Title:      ZF/WF.thy
     Author:     Tobias Nipkow and Lawrence C Paulson
     Copyright   1994  University of Cambridge
 
 Derived first for transitive relations, and finally for arbitrary WF relations
 via wf_trancl and trans_trancl.
 
 It is difficult to derive this general case directly, using r^+ instead of
 r.  In is_recfun, the two occurrences of the relation must have the same
 form.  Inserting r^+ in the_recfun or wftrec yields a recursion rule with
 r^+ -`` {a} instead of r-``{a}.  This recursion rule is stronger in
 principle, but harder to use, especially to prove wfrec_eclose_eq in
 epsilon.ML.  Expanding out the definition of wftrec in wfrec would yield
 a mess.
 *)
 
 section\<open>Well-Founded Recursion\<close>
 
 theory WF imports Trancl begin
 
 definition
   wf           :: "i\<Rightarrow>o"  where
     (*r is a well-founded relation*)
     "wf(r) \<equiv> \<forall>Z. Z=0 | (\<exists>x\<in>Z. \<forall>y. \<langle>y,x\<rangle>:r \<longrightarrow> \<not> y \<in> Z)"
 
 definition
   wf_on        :: "[i,i]\<Rightarrow>o"                      (\<open>wf[_]'(_')\<close>)  where
     (*r is well-founded on A*)
     "wf_on(A,r) \<equiv> wf(r \<inter> A*A)"
 
 definition
   is_recfun    :: "[i, i, [i,i]\<Rightarrow>i, i] \<Rightarrow>o"  where
     "is_recfun(r,a,H,f) \<equiv> (f = (\<lambda>x\<in>r-``{a}. H(x, restrict(f, r-``{x}))))"
 
 definition
   the_recfun   :: "[i, i, [i,i]\<Rightarrow>i] \<Rightarrow>i"  where
     "the_recfun(r,a,H) \<equiv> (THE f. is_recfun(r,a,H,f))"
 
 definition
   wftrec :: "[i, i, [i,i]\<Rightarrow>i] \<Rightarrow>i"  where
     "wftrec(r,a,H) \<equiv> H(a, the_recfun(r,a,H))"
 
 definition
   wfrec :: "[i, i, [i,i]\<Rightarrow>i] \<Rightarrow>i"  where
     (*public version.  Does not require r to be transitive*)
     "wfrec(r,a,H) \<equiv> wftrec(r^+, a, \<lambda>x f. H(x, restrict(f,r-``{x})))"
 
 definition
   wfrec_on     :: "[i, i, i, [i,i]\<Rightarrow>i] \<Rightarrow>i"       (\<open>wfrec[_]'(_,_,_')\<close>)  where
     "wfrec[A](r,a,H) \<equiv> wfrec(r \<inter> A*A, a, H)"
 
 
 subsection\<open>Well-Founded Relations\<close>
 
 subsubsection\<open>Equivalences between \<^term>\<open>wf\<close> and \<^term>\<open>wf_on\<close>\<close>
 
 lemma wf_imp_wf_on: "wf(r) \<Longrightarrow> wf[A](r)"
 by (unfold wf_def wf_on_def, force)
 
 lemma wf_on_imp_wf: "\<lbrakk>wf[A](r); r \<subseteq> A*A\<rbrakk> \<Longrightarrow> wf(r)"
 by (simp add: wf_on_def subset_Int_iff)
 
 lemma wf_on_field_imp_wf: "wf[field(r)](r) \<Longrightarrow> wf(r)"
 by (unfold wf_def wf_on_def, fast)
 
 lemma wf_iff_wf_on_field: "wf(r) \<longleftrightarrow> wf[field(r)](r)"
 by (blast intro: wf_imp_wf_on wf_on_field_imp_wf)
 
 lemma wf_on_subset_A: "\<lbrakk>wf[A](r);  B<=A\<rbrakk> \<Longrightarrow> wf[B](r)"
 by (unfold wf_on_def wf_def, fast)
 
 lemma wf_on_subset_r: "\<lbrakk>wf[A](r); s<=r\<rbrakk> \<Longrightarrow> wf[A](s)"
 by (unfold wf_on_def wf_def, fast)
 
 lemma wf_subset: "\<lbrakk>wf(s); r<=s\<rbrakk> \<Longrightarrow> wf(r)"
 by (simp add: wf_def, fast)
 
 subsubsection\<open>Introduction Rules for \<^term>\<open>wf_on\<close>\<close>
 
 text\<open>If every non-empty subset of \<^term>\<open>A\<close> has an \<^term>\<open>r\<close>-minimal element
    then we have \<^term>\<open>wf[A](r)\<close>.\<close>
 lemma wf_onI:
  assumes prem: "\<And>Z u. \<lbrakk>Z<=A;  u \<in> Z;  \<forall>x\<in>Z. \<exists>y\<in>Z. \<langle>y,x\<rangle>:r\<rbrakk> \<Longrightarrow> False"
  shows         "wf[A](r)"
-apply (unfold wf_on_def wf_def)
+  unfolding wf_on_def wf_def
 apply (rule equals0I [THEN disjCI, THEN allI])
 apply (rule_tac Z = Z in prem, blast+)
 done
 
 text\<open>If \<^term>\<open>r\<close> allows well-founded induction over \<^term>\<open>A\<close>
    then we have \<^term>\<open>wf[A](r)\<close>.   Premise is equivalent to
   \<^prop>\<open>\<And>B. \<forall>x\<in>A. (\<forall>y. \<langle>y,x\<rangle>: r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B \<Longrightarrow> A<=B\<close>\<close>
 lemma wf_onI2:
  assumes prem: "\<And>y B. \<lbrakk>\<forall>x\<in>A. (\<forall>y\<in>A. \<langle>y,x\<rangle>:r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B;   y \<in> A\<rbrakk>
                        \<Longrightarrow> y \<in> B"
  shows         "wf[A](r)"
 apply (rule wf_onI)
 apply (rule_tac c=u in prem [THEN DiffE])
   prefer 3 apply blast
  apply fast+
 done
 
 
 subsubsection\<open>Well-founded Induction\<close>
 
 text\<open>Consider the least \<^term>\<open>z\<close> in \<^term>\<open>domain(r)\<close> such that
   \<^term>\<open>P(z)\<close> does not hold...\<close>
 lemma wf_induct_raw:
     "\<lbrakk>wf(r);
         \<And>x.\<lbrakk>\<forall>y. \<langle>y,x\<rangle>: r \<longrightarrow> P(y)\<rbrakk> \<Longrightarrow> P(x)\<rbrakk>
      \<Longrightarrow> P(a)"
   unfolding wf_def
 apply (erule_tac x = "{z \<in> domain(r). \<not> P(z)}" in allE)
 apply blast
 done
 
 lemmas wf_induct = wf_induct_raw [rule_format, consumes 1, case_names step, induct set: wf]
 
 text\<open>The form of this rule is designed to match \<open>wfI\<close>\<close>
 lemma wf_induct2:
     "\<lbrakk>wf(r);  a \<in> A;  field(r)<=A;
         \<And>x.\<lbrakk>x \<in> A;  \<forall>y. \<langle>y,x\<rangle>: r \<longrightarrow> P(y)\<rbrakk> \<Longrightarrow> P(x)\<rbrakk>
      \<Longrightarrow>  P(a)"
 apply (erule_tac P="a \<in> A" in rev_mp)
 apply (erule_tac a=a in wf_induct, blast)
 done
 
 lemma field_Int_square: "field(r \<inter> A*A) \<subseteq> A"
 by blast
 
 lemma wf_on_induct_raw [consumes 2, induct set: wf_on]:
     "\<lbrakk>wf[A](r);  a \<in> A;
         \<And>x.\<lbrakk>x \<in> A;  \<forall>y\<in>A. \<langle>y,x\<rangle>: r \<longrightarrow> P(y)\<rbrakk> \<Longrightarrow> P(x)
 \<rbrakk>  \<Longrightarrow>  P(a)"
   unfolding wf_on_def
 apply (erule wf_induct2, assumption)
 apply (rule field_Int_square, blast)
 done
 
 lemma wf_on_induct [consumes 2, case_names step, induct set: wf_on]:
   "wf[A](r) \<Longrightarrow> a \<in> A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> (\<And>y. y \<in> A \<Longrightarrow> \<langle>y, x\<rangle> \<in> r \<Longrightarrow> P(y)) \<Longrightarrow> P(x)) \<Longrightarrow> P(a)"
   using wf_on_induct_raw [of A r a P] by simp
 
 text\<open>If \<^term>\<open>r\<close> allows well-founded induction
    then we have \<^term>\<open>wf(r)\<close>.\<close>
 lemma wfI:
     "\<lbrakk>field(r)<=A;
         \<And>y B. \<lbrakk>\<forall>x\<in>A. (\<forall>y\<in>A. \<langle>y,x\<rangle>:r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B;  y \<in> A\<rbrakk>
                \<Longrightarrow> y \<in> B\<rbrakk>
      \<Longrightarrow>  wf(r)"
 apply (rule wf_on_subset_A [THEN wf_on_field_imp_wf])
 apply (rule wf_onI2)
  prefer 2 apply blast
 apply blast
 done
 
 
 subsection\<open>Basic Properties of Well-Founded Relations\<close>
 
 lemma wf_not_refl: "wf(r) \<Longrightarrow> \<langle>a,a\<rangle> \<notin> r"
 by (erule_tac a=a in wf_induct, blast)
 
 lemma wf_not_sym [rule_format]: "wf(r) \<Longrightarrow> \<forall>x. \<langle>a,x\<rangle>:r \<longrightarrow> \<langle>x,a\<rangle> \<notin> r"
 by (erule_tac a=a in wf_induct, blast)
 
 (* @{term"\<lbrakk>wf(r);  \<langle>a,x\<rangle> \<in> r;  \<not>P \<Longrightarrow> \<langle>x,a\<rangle> \<in> r\<rbrakk> \<Longrightarrow> P"} *)
 lemmas wf_asym = wf_not_sym [THEN swap]
 
 lemma wf_on_not_refl: "\<lbrakk>wf[A](r); a \<in> A\<rbrakk> \<Longrightarrow> \<langle>a,a\<rangle> \<notin> r"
 by (erule_tac a=a in wf_on_induct, assumption, blast)
 
 lemma wf_on_not_sym:
      "\<lbrakk>wf[A](r);  a \<in> A\<rbrakk> \<Longrightarrow> (\<And>b. b\<in>A \<Longrightarrow> \<langle>a,b\<rangle>:r \<Longrightarrow> \<langle>b,a\<rangle>\<notin>r)"
 apply (atomize (full), intro impI)
 apply (erule_tac a=a in wf_on_induct, assumption, blast)
 done
 
 lemma wf_on_asym:
      "\<lbrakk>wf[A](r);  \<not>Z \<Longrightarrow> \<langle>a,b\<rangle> \<in> r;
          \<langle>b,a\<rangle> \<notin> r \<Longrightarrow> Z; \<not>Z \<Longrightarrow> a \<in> A; \<not>Z \<Longrightarrow> b \<in> A\<rbrakk> \<Longrightarrow> Z"
 by (blast dest: wf_on_not_sym)
 
 
 (*Needed to prove well_ordI.  Could also reason that wf[A](r) means
   wf(r \<inter> A*A);  thus wf( (r \<inter> A*A)^+ ) and use wf_not_refl *)
 lemma wf_on_chain3:
      "\<lbrakk>wf[A](r); \<langle>a,b\<rangle>:r; \<langle>b,c\<rangle>:r; \<langle>c,a\<rangle>:r; a \<in> A; b \<in> A; c \<in> A\<rbrakk> \<Longrightarrow> P"
 apply (subgoal_tac "\<forall>y\<in>A. \<forall>z\<in>A. \<langle>a,y\<rangle>:r \<longrightarrow> \<langle>y,z\<rangle>:r \<longrightarrow> \<langle>z,a\<rangle>:r \<longrightarrow> P",
        blast)
 apply (erule_tac a=a in wf_on_induct, assumption, blast)
 done
 
 
 
 text\<open>transitive closure of a WF relation is WF provided
   \<^term>\<open>A\<close> is downward closed\<close>
 lemma wf_on_trancl:
     "\<lbrakk>wf[A](r);  r-``A \<subseteq> A\<rbrakk> \<Longrightarrow> wf[A](r^+)"
 apply (rule wf_onI2)
 apply (frule bspec [THEN mp], assumption+)
 apply (erule_tac a = y in wf_on_induct, assumption)
 apply (blast elim: tranclE, blast)
 done
 
 lemma wf_trancl: "wf(r) \<Longrightarrow> wf(r^+)"
 apply (simp add: wf_iff_wf_on_field)
 apply (rule wf_on_subset_A)
  apply (erule wf_on_trancl)
  apply blast
 apply (rule trancl_type [THEN field_rel_subset])
 done
 
 
 text\<open>\<^term>\<open>r-``{a}\<close> is the set of everything under \<^term>\<open>a\<close> in \<^term>\<open>r\<close>\<close>
 
 lemmas underI = vimage_singleton_iff [THEN iffD2]
 lemmas underD = vimage_singleton_iff [THEN iffD1]
 
 
 subsection\<open>The Predicate \<^term>\<open>is_recfun\<close>\<close>
 
 lemma is_recfun_type: "is_recfun(r,a,H,f) \<Longrightarrow> f \<in> r-``{a} -> range(f)"
   unfolding is_recfun_def
 apply (erule ssubst)
 apply (rule lamI [THEN rangeI, THEN lam_type], assumption)
 done
 
 lemmas is_recfun_imp_function = is_recfun_type [THEN fun_is_function]
 
 lemma apply_recfun:
     "\<lbrakk>is_recfun(r,a,H,f); \<langle>x,a\<rangle>:r\<rbrakk> \<Longrightarrow> f`x = H(x, restrict(f,r-``{x}))"
   unfolding is_recfun_def
   txt\<open>replace f only on the left-hand side\<close>
 apply (erule_tac P = "\<lambda>x. t(x) = u" for t u in ssubst)
 apply (simp add: underI)
 done
 
 lemma is_recfun_equal [rule_format]:
      "\<lbrakk>wf(r);  trans(r);  is_recfun(r,a,H,f);  is_recfun(r,b,H,g)\<rbrakk>
       \<Longrightarrow> \<langle>x,a\<rangle>:r \<longrightarrow> \<langle>x,b\<rangle>:r \<longrightarrow> f`x=g`x"
 apply (frule_tac f = f in is_recfun_type)
 apply (frule_tac f = g in is_recfun_type)
 apply (simp add: is_recfun_def)
 apply (erule_tac a=x in wf_induct)
 apply (intro impI)
 apply (elim ssubst)
 apply (simp (no_asm_simp) add: vimage_singleton_iff restrict_def)
 apply (rule_tac t = "\<lambda>z. H (x, z)" for x in subst_context)
 apply (subgoal_tac "\<forall>y\<in>r-``{x}. \<forall>z. \<langle>y,z\<rangle>:f \<longleftrightarrow> \<langle>y,z\<rangle>:g")
  apply (blast dest: transD)
 apply (simp add: apply_iff)
 apply (blast dest: transD intro: sym)
 done
 
 lemma is_recfun_cut:
      "\<lbrakk>wf(r);  trans(r);
          is_recfun(r,a,H,f);  is_recfun(r,b,H,g);  \<langle>b,a\<rangle>:r\<rbrakk>
       \<Longrightarrow> restrict(f, r-``{b}) = g"
 apply (frule_tac f = f in is_recfun_type)
 apply (rule fun_extension)
   apply (blast dest: transD intro: restrict_type2)
  apply (erule is_recfun_type, simp)
 apply (blast dest: transD intro: is_recfun_equal)
 done
 
 subsection\<open>Recursion: Main Existence Lemma\<close>
 
 lemma is_recfun_functional:
      "\<lbrakk>wf(r); trans(r); is_recfun(r,a,H,f); is_recfun(r,a,H,g)\<rbrakk>  \<Longrightarrow>  f=g"
 by (blast intro: fun_extension is_recfun_type is_recfun_equal)
 
 lemma the_recfun_eq:
     "\<lbrakk>is_recfun(r,a,H,f);  wf(r);  trans(r)\<rbrakk> \<Longrightarrow> the_recfun(r,a,H) = f"
   unfolding the_recfun_def
 apply (blast intro: is_recfun_functional)
 done
 
 (*If some f satisfies is_recfun(r,a,H,-) then so does the_recfun(r,a,H) *)
 lemma is_the_recfun:
     "\<lbrakk>is_recfun(r,a,H,f);  wf(r);  trans(r)\<rbrakk>
      \<Longrightarrow> is_recfun(r, a, H, the_recfun(r,a,H))"
 by (simp add: the_recfun_eq)
 
 lemma unfold_the_recfun:
      "\<lbrakk>wf(r);  trans(r)\<rbrakk> \<Longrightarrow> is_recfun(r, a, H, the_recfun(r,a,H))"
 apply (rule_tac a=a in wf_induct, assumption)
 apply (rename_tac a1)
 apply (rule_tac f = "\<lambda>y\<in>r-``{a1}. wftrec (r,y,H)" in is_the_recfun)
   apply typecheck
-apply (unfold is_recfun_def wftrec_def)
+  unfolding is_recfun_def wftrec_def
   \<comment> \<open>Applying the substitution: must keep the quantified assumption!\<close>
 apply (rule lam_cong [OF refl])
 apply (drule underD)
 apply (fold is_recfun_def)
 apply (rule_tac t = "\<lambda>z. H(x, z)" for x in subst_context)
 apply (rule fun_extension)
   apply (blast intro: is_recfun_type)
  apply (rule lam_type [THEN restrict_type2])
   apply blast
  apply (blast dest: transD)
 apply atomize
 apply (frule spec [THEN mp], assumption)
 apply (subgoal_tac "\<langle>xa,a1\<rangle> \<in> r")
  apply (drule_tac x1 = xa in spec [THEN mp], assumption)
 apply (simp add: vimage_singleton_iff
                  apply_recfun is_recfun_cut)
 apply (blast dest: transD)
 done
 
 
 subsection\<open>Unfolding \<^term>\<open>wftrec(r,a,H)\<close>\<close>
 
 lemma the_recfun_cut:
      "\<lbrakk>wf(r);  trans(r);  \<langle>b,a\<rangle>:r\<rbrakk>
       \<Longrightarrow> restrict(the_recfun(r,a,H), r-``{b}) = the_recfun(r,b,H)"
 by (blast intro: is_recfun_cut unfold_the_recfun)
 
 (*NOT SUITABLE FOR REWRITING: it is recursive!*)
 lemma wftrec:
     "\<lbrakk>wf(r);  trans(r)\<rbrakk> \<Longrightarrow>
           wftrec(r,a,H) = H(a, \<lambda>x\<in>r-``{a}. wftrec(r,x,H))"
   unfolding wftrec_def
 apply (subst unfold_the_recfun [unfolded is_recfun_def])
 apply (simp_all add: vimage_singleton_iff [THEN iff_sym] the_recfun_cut)
 done
 
 
 subsubsection\<open>Removal of the Premise \<^term>\<open>trans(r)\<close>\<close>
 
 (*NOT SUITABLE FOR REWRITING: it is recursive!*)
 lemma wfrec:
     "wf(r) \<Longrightarrow> wfrec(r,a,H) = H(a, \<lambda>x\<in>r-``{a}. wfrec(r,x,H))"
   unfolding wfrec_def
 apply (erule wf_trancl [THEN wftrec, THEN ssubst])
  apply (rule trans_trancl)
 apply (rule vimage_pair_mono [THEN restrict_lam_eq, THEN subst_context])
  apply (erule r_into_trancl)
 apply (rule subset_refl)
 done
 
 (*This form avoids giant explosions in proofs.  NOTE USE OF \<equiv> *)
 lemma def_wfrec:
     "\<lbrakk>\<And>x. h(x)\<equiv>wfrec(r,x,H);  wf(r)\<rbrakk> \<Longrightarrow>
      h(a) = H(a, \<lambda>x\<in>r-``{a}. h(x))"
 apply simp
 apply (elim wfrec)
 done
 
 lemma wfrec_type:
     "\<lbrakk>wf(r);  a \<in> A;  field(r)<=A;
         \<And>x u. \<lbrakk>x \<in> A;  u \<in> Pi(r-``{x}, B)\<rbrakk> \<Longrightarrow> H(x,u) \<in> B(x)
 \<rbrakk> \<Longrightarrow> wfrec(r,a,H) \<in> B(a)"
 apply (rule_tac a = a in wf_induct2, assumption+)
 apply (subst wfrec, assumption)
 apply (simp add: lam_type underD)
 done
 
 
 lemma wfrec_on:
  "\<lbrakk>wf[A](r);  a \<in> A\<rbrakk> \<Longrightarrow>
          wfrec[A](r,a,H) = H(a, \<lambda>x\<in>(r-``{a}) \<inter> A. wfrec[A](r,x,H))"
-apply (unfold wf_on_def wfrec_on_def)
+  unfolding wf_on_def wfrec_on_def
 apply (erule wfrec [THEN trans])
 apply (simp add: vimage_Int_square cons_subset_iff)
 done
 
 text\<open>Minimal-element characterization of well-foundedness\<close>
 lemma wf_eq_minimal:
      "wf(r) \<longleftrightarrow> (\<forall>Q x. x \<in> Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. \<langle>y,z\<rangle>:r \<longrightarrow> y\<notin>Q))"
 by (unfold wf_def, blast)
 
 end
diff --git a/src/ZF/ZF_Base.thy b/src/ZF/ZF_Base.thy
--- a/src/ZF/ZF_Base.thy
+++ b/src/ZF/ZF_Base.thy
@@ -1,650 +1,650 @@
 (*  Title:      ZF/ZF_Base.thy
     Author:     Lawrence C Paulson and Martin D Coen, CU Computer Laboratory
     Copyright   1993  University of Cambridge
 *)
 
 section \<open>Base of Zermelo-Fraenkel Set Theory\<close>
 
 theory ZF_Base
 imports FOL
 begin
 
 subsection \<open>Signature\<close>
 
 declare [[eta_contract = false]]
 
 typedecl i
 instance i :: "term" ..
 
 axiomatization mem :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<in>\<close> 50)  \<comment> \<open>membership relation\<close>
   and zero :: "i"  (\<open>0\<close>)  \<comment> \<open>the empty set\<close>
   and Pow :: "i \<Rightarrow> i"  \<comment> \<open>power sets\<close>
   and Inf :: "i"  \<comment> \<open>infinite set\<close>
   and Union :: "i \<Rightarrow> i"  (\<open>\<Union>_\<close> [90] 90)
   and PrimReplace :: "[i, [i, i] \<Rightarrow> o] \<Rightarrow> i"
 
 abbreviation not_mem :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<notin>\<close> 50)  \<comment> \<open>negated membership relation\<close>
   where "x \<notin> y \<equiv> \<not> (x \<in> y)"
 
 
 subsection \<open>Bounded Quantifiers\<close>
 
 definition Ball :: "[i, i \<Rightarrow> o] \<Rightarrow> o"
   where "Ball(A, P) \<equiv> \<forall>x. x\<in>A \<longrightarrow> P(x)"
 
 definition Bex :: "[i, i \<Rightarrow> o] \<Rightarrow> o"
   where "Bex(A, P) \<equiv> \<exists>x. x\<in>A \<and> P(x)"
 
 syntax
   "_Ball" :: "[pttrn, i, o] \<Rightarrow> o"  (\<open>(3\<forall>_\<in>_./ _)\<close> 10)
   "_Bex" :: "[pttrn, i, o] \<Rightarrow> o"  (\<open>(3\<exists>_\<in>_./ _)\<close> 10)
 translations
   "\<forall>x\<in>A. P" \<rightleftharpoons> "CONST Ball(A, \<lambda>x. P)"
   "\<exists>x\<in>A. P" \<rightleftharpoons> "CONST Bex(A, \<lambda>x. P)"
 
 
 subsection \<open>Variations on Replacement\<close>
 
 (* Derived form of replacement, restricting P to its functional part.
    The resulting set (for functional P) is the same as with
    PrimReplace, but the rules are simpler. *)
 definition Replace :: "[i, [i, i] \<Rightarrow> o] \<Rightarrow> i"
   where "Replace(A,P) \<equiv> PrimReplace(A, \<lambda>x y. (\<exists>!z. P(x,z)) \<and> P(x,y))"
 
 syntax
   "_Replace"  :: "[pttrn, pttrn, i, o] \<Rightarrow> i"  (\<open>(1{_ ./ _ \<in> _, _})\<close>)
 translations
   "{y. x\<in>A, Q}" \<rightleftharpoons> "CONST Replace(A, \<lambda>x y. Q)"
 
 
 (* Functional form of replacement -- analgous to ML's map functional *)
 
 definition RepFun :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
   where "RepFun(A,f) \<equiv> {y . x\<in>A, y=f(x)}"
 
 syntax
   "_RepFun" :: "[i, pttrn, i] \<Rightarrow> i"  (\<open>(1{_ ./ _ \<in> _})\<close> [51,0,51])
 translations
   "{b. x\<in>A}" \<rightleftharpoons> "CONST RepFun(A, \<lambda>x. b)"
 
 
 (* Separation and Pairing can be derived from the Replacement
    and Powerset Axioms using the following definitions. *)
 definition Collect :: "[i, i \<Rightarrow> o] \<Rightarrow> i"
   where "Collect(A,P) \<equiv> {y . x\<in>A, x=y \<and> P(x)}"
 
 syntax
   "_Collect" :: "[pttrn, i, o] \<Rightarrow> i"  (\<open>(1{_ \<in> _ ./ _})\<close>)
 translations
   "{x\<in>A. P}" \<rightleftharpoons> "CONST Collect(A, \<lambda>x. P)"
 
 
 subsection \<open>General union and intersection\<close>
 
 definition Inter :: "i \<Rightarrow> i"  (\<open>\<Inter>_\<close> [90] 90)
   where "\<Inter>(A) \<equiv> { x\<in>\<Union>(A) . \<forall>y\<in>A. x\<in>y}"
 
 syntax
   "_UNION" :: "[pttrn, i, i] \<Rightarrow> i"  (\<open>(3\<Union>_\<in>_./ _)\<close> 10)
   "_INTER" :: "[pttrn, i, i] \<Rightarrow> i"  (\<open>(3\<Inter>_\<in>_./ _)\<close> 10)
 translations
   "\<Union>x\<in>A. B" == "CONST Union({B. x\<in>A})"
   "\<Inter>x\<in>A. B" == "CONST Inter({B. x\<in>A})"
 
 
 subsection \<open>Finite sets and binary operations\<close>
 
 (*Unordered pairs (Upair) express binary union/intersection and cons;
   set enumerations translate as {a,...,z} = cons(a,...,cons(z,0)...)*)
 
 definition Upair :: "[i, i] \<Rightarrow> i"
   where "Upair(a,b) \<equiv> {y. x\<in>Pow(Pow(0)), (x=0 \<and> y=a) | (x=Pow(0) \<and> y=b)}"
 
 definition Subset :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<subseteq>\<close> 50)  \<comment> \<open>subset relation\<close>
   where subset_def: "A \<subseteq> B \<equiv> \<forall>x\<in>A. x\<in>B"
 
 definition Diff :: "[i, i] \<Rightarrow> i"  (infixl \<open>-\<close> 65)  \<comment> \<open>set difference\<close>
   where "A - B \<equiv> { x\<in>A . \<not>(x\<in>B) }"
 
 definition Un :: "[i, i] \<Rightarrow> i"  (infixl \<open>\<union>\<close> 65)  \<comment> \<open>binary union\<close>
   where "A \<union> B \<equiv> \<Union>(Upair(A,B))"
 
 definition Int :: "[i, i] \<Rightarrow> i"  (infixl \<open>\<inter>\<close> 70)  \<comment> \<open>binary intersection\<close>
   where "A \<inter> B \<equiv> \<Inter>(Upair(A,B))"
 
 definition cons :: "[i, i] \<Rightarrow> i"
   where "cons(a,A) \<equiv> Upair(a,a) \<union> A"
 
 definition succ :: "i \<Rightarrow> i"
   where "succ(i) \<equiv> cons(i, i)"
 
 nonterminal "is"
 syntax
   "" :: "i \<Rightarrow> is"  (\<open>_\<close>)
   "_Enum" :: "[i, is] \<Rightarrow> is"  (\<open>_,/ _\<close>)
   "_Finset" :: "is \<Rightarrow> i"  (\<open>{(_)}\<close>)
 translations
   "{x, xs}" == "CONST cons(x, {xs})"
   "{x}" == "CONST cons(x, 0)"
 
 
 subsection \<open>Axioms\<close>
 
 (* ZF axioms -- see Suppes p.238
    Axioms for Union, Pow and Replace state existence only,
    uniqueness is derivable using extensionality. *)
 
 axiomatization
 where
   extension:     "A = B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A" and
   Union_iff:     "A \<in> \<Union>(C) \<longleftrightarrow> (\<exists>B\<in>C. A\<in>B)" and
   Pow_iff:       "A \<in> Pow(B) \<longleftrightarrow> A \<subseteq> B" and
 
   (*We may name this set, though it is not uniquely defined.*)
   infinity:      "0 \<in> Inf \<and> (\<forall>y\<in>Inf. succ(y) \<in> Inf)" and
 
   (*This formulation facilitates case analysis on A.*)
   foundation:    "A = 0 \<or> (\<exists>x\<in>A. \<forall>y\<in>x. y\<notin>A)" and
 
   (*Schema axiom since predicate P is a higher-order variable*)
   replacement:   "(\<forall>x\<in>A. \<forall>y z. P(x,y) \<and> P(x,z) \<longrightarrow> y = z) \<Longrightarrow>
                          b \<in> PrimReplace(A,P) \<longleftrightarrow> (\<exists>x\<in>A. P(x,b))"
 
 
 subsection \<open>Definite descriptions -- via Replace over the set "1"\<close>
 
 definition The :: "(i \<Rightarrow> o) \<Rightarrow> i"  (binder \<open>THE \<close> 10)
   where the_def: "The(P)    \<equiv> \<Union>({y . x \<in> {0}, P(y)})"
 
 definition If :: "[o, i, i] \<Rightarrow> i"  (\<open>(if (_)/ then (_)/ else (_))\<close> [10] 10)
   where if_def: "if P then a else b \<equiv> THE z. P \<and> z=a | \<not>P \<and> z=b"
 
 abbreviation (input)
   old_if :: "[o, i, i] \<Rightarrow> i"  (\<open>if '(_,_,_')\<close>)
   where "if(P,a,b) \<equiv> If(P,a,b)"
 
 
 subsection \<open>Ordered Pairing\<close>
 
 (* this "symmetric" definition works better than {{a}, {a,b}} *)
 definition Pair :: "[i, i] \<Rightarrow> i"
   where "Pair(a,b) \<equiv> {{a,a}, {a,b}}"
 
 definition fst :: "i \<Rightarrow> i"
   where "fst(p) \<equiv> THE a. \<exists>b. p = Pair(a, b)"
 
 definition snd :: "i \<Rightarrow> i"
   where "snd(p) \<equiv> THE b. \<exists>a. p = Pair(a, b)"
 
 definition split :: "[[i, i] \<Rightarrow> 'a, i] \<Rightarrow> 'a::{}"  \<comment> \<open>for pattern-matching\<close>
   where "split(c) \<equiv> \<lambda>p. c(fst(p), snd(p))"
 
 (* Patterns -- extends pre-defined type "pttrn" used in abstractions *)
 nonterminal patterns
 syntax
   "_pattern"  :: "patterns \<Rightarrow> pttrn"         (\<open>\<langle>_\<rangle>\<close>)
   ""          :: "pttrn \<Rightarrow> patterns"         (\<open>_\<close>)
   "_patterns" :: "[pttrn, patterns] \<Rightarrow> patterns"  (\<open>_,/_\<close>)
   "_Tuple"    :: "[i, is] \<Rightarrow> i"              (\<open>\<langle>(_,/ _)\<rangle>\<close>)
 translations
   "\<langle>x, y, z\<rangle>"   == "\<langle>x, \<langle>y, z\<rangle>\<rangle>"
   "\<langle>x, y\<rangle>"      == "CONST Pair(x, y)"
   "\<lambda>\<langle>x,y,zs\<rangle>.b" == "CONST split(\<lambda>x \<langle>y,zs\<rangle>.b)"
   "\<lambda>\<langle>x,y\<rangle>.b"    == "CONST split(\<lambda>x y. b)"
 
 definition Sigma :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
   where "Sigma(A,B) \<equiv> \<Union>x\<in>A. \<Union>y\<in>B(x). {\<langle>x,y\<rangle>}"
 
 abbreviation cart_prod :: "[i, i] \<Rightarrow> i"  (infixr \<open>\<times>\<close> 80)  \<comment> \<open>Cartesian product\<close>
   where "A \<times> B \<equiv> Sigma(A, \<lambda>_. B)"
 
 
 subsection \<open>Relations and Functions\<close>
 
 (*converse of relation r, inverse of function*)
 definition converse :: "i \<Rightarrow> i"
   where "converse(r) \<equiv> {z. w\<in>r, \<exists>x y. w=\<langle>x,y\<rangle> \<and> z=\<langle>y,x\<rangle>}"
 
 definition domain :: "i \<Rightarrow> i"
   where "domain(r) \<equiv> {x. w\<in>r, \<exists>y. w=\<langle>x,y\<rangle>}"
 
 definition range :: "i \<Rightarrow> i"
   where "range(r) \<equiv> domain(converse(r))"
 
 definition field :: "i \<Rightarrow> i"
   where "field(r) \<equiv> domain(r) \<union> range(r)"
 
 definition relation :: "i \<Rightarrow> o"  \<comment> \<open>recognizes sets of pairs\<close>
   where "relation(r) \<equiv> \<forall>z\<in>r. \<exists>x y. z = \<langle>x,y\<rangle>"
 
 definition "function" :: "i \<Rightarrow> o"  \<comment> \<open>recognizes functions; can have non-pairs\<close>
   where "function(r) \<equiv> \<forall>x y. \<langle>x,y\<rangle> \<in> r \<longrightarrow> (\<forall>y'. \<langle>x,y'\<rangle> \<in> r \<longrightarrow> y = y')"
 
 definition Image :: "[i, i] \<Rightarrow> i"  (infixl \<open>``\<close> 90)  \<comment> \<open>image\<close>
   where image_def: "r `` A  \<equiv> {y \<in> range(r). \<exists>x\<in>A. \<langle>x,y\<rangle> \<in> r}"
 
 definition vimage :: "[i, i] \<Rightarrow> i"  (infixl \<open>-``\<close> 90)  \<comment> \<open>inverse image\<close>
   where vimage_def: "r -`` A \<equiv> converse(r)``A"
 
 (* Restrict the relation r to the domain A *)
 definition restrict :: "[i, i] \<Rightarrow> i"
   where "restrict(r,A) \<equiv> {z \<in> r. \<exists>x\<in>A. \<exists>y. z = \<langle>x,y\<rangle>}"
 
 
 (* Abstraction, application and Cartesian product of a family of sets *)
 
 definition Lambda :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
   where lam_def: "Lambda(A,b) \<equiv> {\<langle>x,b(x)\<rangle>. x\<in>A}"
 
 definition "apply" :: "[i, i] \<Rightarrow> i"  (infixl \<open>`\<close> 90)  \<comment> \<open>function application\<close>
   where "f`a \<equiv> \<Union>(f``{a})"
 
 definition Pi :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
   where "Pi(A,B) \<equiv> {f\<in>Pow(Sigma(A,B)). A\<subseteq>domain(f) \<and> function(f)}"
 
 abbreviation function_space :: "[i, i] \<Rightarrow> i"  (infixr \<open>\<rightarrow>\<close> 60)  \<comment> \<open>function space\<close>
   where "A \<rightarrow> B \<equiv> Pi(A, \<lambda>_. B)"
 
 
 (* binder syntax *)
 
 syntax
   "_PROD"     :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3\<Prod>_\<in>_./ _)\<close> 10)
   "_SUM"      :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3\<Sum>_\<in>_./ _)\<close> 10)
   "_lam"      :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3\<lambda>_\<in>_./ _)\<close> 10)
 translations
   "\<Prod>x\<in>A. B"   == "CONST Pi(A, \<lambda>x. B)"
   "\<Sum>x\<in>A. B"   == "CONST Sigma(A, \<lambda>x. B)"
   "\<lambda>x\<in>A. f"    == "CONST Lambda(A, \<lambda>x. f)"
 
 
 subsection \<open>ASCII syntax\<close>
 
 notation (ASCII)
   cart_prod       (infixr \<open>*\<close> 80) and
   Int             (infixl \<open>Int\<close> 70) and
   Un              (infixl \<open>Un\<close> 65) and
   function_space  (infixr \<open>->\<close> 60) and
   Subset          (infixl \<open><=\<close> 50) and
   mem             (infixl \<open>:\<close> 50) and
   not_mem         (infixl \<open>\<not>:\<close> 50)
 
 syntax (ASCII)
   "_Ball"     :: "[pttrn, i, o] \<Rightarrow> o"        (\<open>(3ALL _:_./ _)\<close> 10)
   "_Bex"      :: "[pttrn, i, o] \<Rightarrow> o"        (\<open>(3EX _:_./ _)\<close> 10)
   "_Collect"  :: "[pttrn, i, o] \<Rightarrow> i"        (\<open>(1{_: _ ./ _})\<close>)
   "_Replace"  :: "[pttrn, pttrn, i, o] \<Rightarrow> i" (\<open>(1{_ ./ _: _, _})\<close>)
   "_RepFun"   :: "[i, pttrn, i] \<Rightarrow> i"        (\<open>(1{_ ./ _: _})\<close> [51,0,51])
   "_UNION"    :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3UN _:_./ _)\<close> 10)
   "_INTER"    :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3INT _:_./ _)\<close> 10)
   "_PROD"     :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3PROD _:_./ _)\<close> 10)
   "_SUM"      :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3SUM _:_./ _)\<close> 10)
   "_lam"      :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3lam _:_./ _)\<close> 10)
   "_Tuple"    :: "[i, is] \<Rightarrow> i"              (\<open><(_,/ _)>\<close>)
   "_pattern"  :: "patterns \<Rightarrow> pttrn"         (\<open><_>\<close>)
 
 
 subsection \<open>Substitution\<close>
 
 (*Useful examples:  singletonI RS subst_elem,  subst_elem RSN (2,IntI) *)
 lemma subst_elem: "\<lbrakk>b\<in>A;  a=b\<rbrakk> \<Longrightarrow> a\<in>A"
 by (erule ssubst, assumption)
 
 
 subsection\<open>Bounded universal quantifier\<close>
 
 lemma ballI [intro!]: "\<lbrakk>\<And>x. x\<in>A \<Longrightarrow> P(x)\<rbrakk> \<Longrightarrow> \<forall>x\<in>A. P(x)"
 by (simp add: Ball_def)
 
 lemmas strip = impI allI ballI
 
 lemma bspec [dest?]: "\<lbrakk>\<forall>x\<in>A. P(x);  x: A\<rbrakk> \<Longrightarrow> P(x)"
 by (simp add: Ball_def)
 
 (*Instantiates x first: better for automatic theorem proving?*)
 lemma rev_ballE [elim]:
     "\<lbrakk>\<forall>x\<in>A. P(x);  x\<notin>A \<Longrightarrow> Q;  P(x) \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
 by (simp add: Ball_def, blast)
 
 lemma ballE: "\<lbrakk>\<forall>x\<in>A. P(x);  P(x) \<Longrightarrow> Q;  x\<notin>A \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
 by blast
 
 (*Used in the datatype package*)
 lemma rev_bspec: "\<lbrakk>x: A;  \<forall>x\<in>A. P(x)\<rbrakk> \<Longrightarrow> P(x)"
 by (simp add: Ball_def)
 
 (*Trival rewrite rule;   @{term"(\<forall>x\<in>A.P)<->P"} holds only if A is nonempty!*)
 lemma ball_triv [simp]: "(\<forall>x\<in>A. P) <-> ((\<exists>x. x\<in>A) \<longrightarrow> P)"
 by (simp add: Ball_def)
 
 (*Congruence rule for rewriting*)
 lemma ball_cong [cong]:
     "\<lbrakk>A=A';  \<And>x. x\<in>A' \<Longrightarrow> P(x) <-> P'(x)\<rbrakk> \<Longrightarrow> (\<forall>x\<in>A. P(x)) <-> (\<forall>x\<in>A'. P'(x))"
 by (simp add: Ball_def)
 
 lemma atomize_ball:
     "(\<And>x. x \<in> A \<Longrightarrow> P(x)) \<equiv> Trueprop (\<forall>x\<in>A. P(x))"
   by (simp only: Ball_def atomize_all atomize_imp)
 
 lemmas [symmetric, rulify] = atomize_ball
   and [symmetric, defn] = atomize_ball
 
 
 subsection\<open>Bounded existential quantifier\<close>
 
 lemma bexI [intro]: "\<lbrakk>P(x);  x: A\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. P(x)"
 by (simp add: Bex_def, blast)
 
 (*The best argument order when there is only one @{term"x\<in>A"}*)
 lemma rev_bexI: "\<lbrakk>x\<in>A;  P(x)\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. P(x)"
 by blast
 
 (*Not of the general form for such rules. The existential quanitifer becomes universal. *)
 lemma bexCI: "\<lbrakk>\<forall>x\<in>A. \<not>P(x) \<Longrightarrow> P(a);  a: A\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. P(x)"
 by blast
 
 lemma bexE [elim!]: "\<lbrakk>\<exists>x\<in>A. P(x);  \<And>x. \<lbrakk>x\<in>A; P(x)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
 by (simp add: Bex_def, blast)
 
 (*We do not even have @{term"(\<exists>x\<in>A. True) <-> True"} unless @{term"A" is nonempty\<And>*)
 lemma bex_triv [simp]: "(\<exists>x\<in>A. P) <-> ((\<exists>x. x\<in>A) \<and> P)"
 by (simp add: Bex_def)
 
 lemma bex_cong [cong]:
     "\<lbrakk>A=A';  \<And>x. x\<in>A' \<Longrightarrow> P(x) <-> P'(x)\<rbrakk>
      \<Longrightarrow> (\<exists>x\<in>A. P(x)) <-> (\<exists>x\<in>A'. P'(x))"
 by (simp add: Bex_def cong: conj_cong)
 
 
 
 subsection\<open>Rules for subsets\<close>
 
 lemma subsetI [intro!]:
     "(\<And>x. x\<in>A \<Longrightarrow> x\<in>B) \<Longrightarrow> A \<subseteq> B"
 by (simp add: subset_def)
 
 (*Rule in Modus Ponens style [was called subsetE] *)
 lemma subsetD [elim]: "\<lbrakk>A \<subseteq> B;  c\<in>A\<rbrakk> \<Longrightarrow> c\<in>B"
   unfolding subset_def
 apply (erule bspec, assumption)
 done
 
 (*Classical elimination rule*)
 lemma subsetCE [elim]:
     "\<lbrakk>A \<subseteq> B;  c\<notin>A \<Longrightarrow> P;  c\<in>B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
 by (simp add: subset_def, blast)
 
 (*Sometimes useful with premises in this order*)
 lemma rev_subsetD: "\<lbrakk>c\<in>A; A<=B\<rbrakk> \<Longrightarrow> c\<in>B"
 by blast
 
 lemma contra_subsetD: "\<lbrakk>A \<subseteq> B; c \<notin> B\<rbrakk> \<Longrightarrow> c \<notin> A"
 by blast
 
 lemma rev_contra_subsetD: "\<lbrakk>c \<notin> B;  A \<subseteq> B\<rbrakk> \<Longrightarrow> c \<notin> A"
 by blast
 
 lemma subset_refl [simp]: "A \<subseteq> A"
 by blast
 
 lemma subset_trans: "\<lbrakk>A<=B;  B<=C\<rbrakk> \<Longrightarrow> A<=C"
 by blast
 
 (*Useful for proving A<=B by rewriting in some cases*)
 lemma subset_iff:
      "A<=B <-> (\<forall>x. x\<in>A \<longrightarrow> x\<in>B)"
-apply (unfold subset_def Ball_def)
+  unfolding subset_def Ball_def
 apply (rule iff_refl)
 done
 
 text\<open>For calculations\<close>
 declare subsetD [trans] rev_subsetD [trans] subset_trans [trans]
 
 
 subsection\<open>Rules for equality\<close>
 
 (*Anti-symmetry of the subset relation*)
 lemma equalityI [intro]: "\<lbrakk>A \<subseteq> B;  B \<subseteq> A\<rbrakk> \<Longrightarrow> A = B"
 by (rule extension [THEN iffD2], rule conjI)
 
 
 lemma equality_iffI: "(\<And>x. x\<in>A <-> x\<in>B) \<Longrightarrow> A = B"
 by (rule equalityI, blast+)
 
 lemmas equalityD1 = extension [THEN iffD1, THEN conjunct1]
 lemmas equalityD2 = extension [THEN iffD1, THEN conjunct2]
 
 lemma equalityE: "\<lbrakk>A = B;  \<lbrakk>A<=B; B<=A\<rbrakk> \<Longrightarrow> P\<rbrakk>  \<Longrightarrow>  P"
 by (blast dest: equalityD1 equalityD2)
 
 lemma equalityCE:
     "\<lbrakk>A = B;  \<lbrakk>c\<in>A; c\<in>B\<rbrakk> \<Longrightarrow> P;  \<lbrakk>c\<notin>A; c\<notin>B\<rbrakk> \<Longrightarrow> P\<rbrakk>  \<Longrightarrow>  P"
 by (erule equalityE, blast)
 
 lemma equality_iffD:
   "A = B \<Longrightarrow> (\<And>x. x \<in> A <-> x \<in> B)"
   by auto
 
 
 subsection\<open>Rules for Replace -- the derived form of replacement\<close>
 
 lemma Replace_iff:
     "b \<in> {y. x\<in>A, P(x,y)}  <->  (\<exists>x\<in>A. P(x,b) \<and> (\<forall>y. P(x,y) \<longrightarrow> y=b))"
   unfolding Replace_def
 apply (rule replacement [THEN iff_trans], blast+)
 done
 
 (*Introduction; there must be a unique y such that P(x,y), namely y=b. *)
 lemma ReplaceI [intro]:
     "\<lbrakk>P(x,b);  x: A;  \<And>y. P(x,y) \<Longrightarrow> y=b\<rbrakk> \<Longrightarrow>
      b \<in> {y. x\<in>A, P(x,y)}"
 by (rule Replace_iff [THEN iffD2], blast)
 
 (*Elimination; may asssume there is a unique y such that P(x,y), namely y=b. *)
 lemma ReplaceE:
     "\<lbrakk>b \<in> {y. x\<in>A, P(x,y)};
         \<And>x. \<lbrakk>x: A;  P(x,b);  \<forall>y. P(x,y)\<longrightarrow>y=b\<rbrakk> \<Longrightarrow> R
 \<rbrakk> \<Longrightarrow> R"
 by (rule Replace_iff [THEN iffD1, THEN bexE], simp+)
 
 (*As above but without the (generally useless) 3rd assumption*)
 lemma ReplaceE2 [elim!]:
     "\<lbrakk>b \<in> {y. x\<in>A, P(x,y)};
         \<And>x. \<lbrakk>x: A;  P(x,b)\<rbrakk> \<Longrightarrow> R
 \<rbrakk> \<Longrightarrow> R"
 by (erule ReplaceE, blast)
 
 lemma Replace_cong [cong]:
     "\<lbrakk>A=B;  \<And>x y. x\<in>B \<Longrightarrow> P(x,y) <-> Q(x,y)\<rbrakk> \<Longrightarrow>
      Replace(A,P) = Replace(B,Q)"
 apply (rule equality_iffI)
 apply (simp add: Replace_iff)
 done
 
 
 subsection\<open>Rules for RepFun\<close>
 
 lemma RepFunI: "a \<in> A \<Longrightarrow> f(a) \<in> {f(x). x\<in>A}"
 by (simp add: RepFun_def Replace_iff, blast)
 
 (*Useful for coinduction proofs*)
 lemma RepFun_eqI [intro]: "\<lbrakk>b=f(a);  a \<in> A\<rbrakk> \<Longrightarrow> b \<in> {f(x). x\<in>A}"
 apply (erule ssubst)
 apply (erule RepFunI)
 done
 
 lemma RepFunE [elim!]:
     "\<lbrakk>b \<in> {f(x). x\<in>A};
         \<And>x.\<lbrakk>x\<in>A;  b=f(x)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow>
      P"
 by (simp add: RepFun_def Replace_iff, blast)
 
 lemma RepFun_cong [cong]:
     "\<lbrakk>A=B;  \<And>x. x\<in>B \<Longrightarrow> f(x)=g(x)\<rbrakk> \<Longrightarrow> RepFun(A,f) = RepFun(B,g)"
 by (simp add: RepFun_def)
 
 lemma RepFun_iff [simp]: "b \<in> {f(x). x\<in>A} <-> (\<exists>x\<in>A. b=f(x))"
 by (unfold Bex_def, blast)
 
 lemma triv_RepFun [simp]: "{x. x\<in>A} = A"
 by blast
 
 
 subsection\<open>Rules for Collect -- forming a subset by separation\<close>
 
 (*Separation is derivable from Replacement*)
 lemma separation [simp]: "a \<in> {x\<in>A. P(x)} <-> a\<in>A \<and> P(a)"
 by (unfold Collect_def, blast)
 
 lemma CollectI [intro!]: "\<lbrakk>a\<in>A;  P(a)\<rbrakk> \<Longrightarrow> a \<in> {x\<in>A. P(x)}"
 by simp
 
 lemma CollectE [elim!]: "\<lbrakk>a \<in> {x\<in>A. P(x)};  \<lbrakk>a\<in>A; P(a)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
 by simp
 
 lemma CollectD1: "a \<in> {x\<in>A. P(x)} \<Longrightarrow> a\<in>A"
 by (erule CollectE, assumption)
 
 lemma CollectD2: "a \<in> {x\<in>A. P(x)} \<Longrightarrow> P(a)"
 by (erule CollectE, assumption)
 
 lemma Collect_cong [cong]:
     "\<lbrakk>A=B;  \<And>x. x\<in>B \<Longrightarrow> P(x) <-> Q(x)\<rbrakk>
      \<Longrightarrow> Collect(A, \<lambda>x. P(x)) = Collect(B, \<lambda>x. Q(x))"
 by (simp add: Collect_def)
 
 
 subsection\<open>Rules for Unions\<close>
 
 declare Union_iff [simp]
 
 (*The order of the premises presupposes that C is rigid; A may be flexible*)
 lemma UnionI [intro]: "\<lbrakk>B: C;  A: B\<rbrakk> \<Longrightarrow> A: \<Union>(C)"
 by (simp, blast)
 
 lemma UnionE [elim!]: "\<lbrakk>A \<in> \<Union>(C);  \<And>B.\<lbrakk>A: B;  B: C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
 by (simp, blast)
 
 
 subsection\<open>Rules for Unions of families\<close>
 (* @{term"\<Union>x\<in>A. B(x)"} abbreviates @{term"\<Union>({B(x). x\<in>A})"} *)
 
 lemma UN_iff [simp]: "b \<in> (\<Union>x\<in>A. B(x)) <-> (\<exists>x\<in>A. b \<in> B(x))"
 by (simp add: Bex_def, blast)
 
 (*The order of the premises presupposes that A is rigid; b may be flexible*)
 lemma UN_I: "\<lbrakk>a: A;  b: B(a)\<rbrakk> \<Longrightarrow> b: (\<Union>x\<in>A. B(x))"
 by (simp, blast)
 
 
 lemma UN_E [elim!]:
     "\<lbrakk>b \<in> (\<Union>x\<in>A. B(x));  \<And>x.\<lbrakk>x: A;  b: B(x)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
 by blast
 
 lemma UN_cong:
     "\<lbrakk>A=B;  \<And>x. x\<in>B \<Longrightarrow> C(x)=D(x)\<rbrakk> \<Longrightarrow> (\<Union>x\<in>A. C(x)) = (\<Union>x\<in>B. D(x))"
 by simp
 
 
 (*No "Addcongs [UN_cong]" because @{term\<Union>} is a combination of constants*)
 
 (* UN_E appears before UnionE so that it is tried first, to avoid expensive
   calls to hyp_subst_tac.  Cannot include UN_I as it is unsafe: would enlarge
   the search space.*)
 
 
 subsection\<open>Rules for the empty set\<close>
 
 (*The set @{term"{x\<in>0. False}"} is empty; by foundation it equals 0
   See Suppes, page 21.*)
 lemma not_mem_empty [simp]: "a \<notin> 0"
 apply (cut_tac foundation)
 apply (best dest: equalityD2)
 done
 
 lemmas emptyE [elim!] = not_mem_empty [THEN notE]
 
 
 lemma empty_subsetI [simp]: "0 \<subseteq> A"
 by blast
 
 lemma equals0I: "\<lbrakk>\<And>y. y\<in>A \<Longrightarrow> False\<rbrakk> \<Longrightarrow> A=0"
 by blast
 
 lemma equals0D [dest]: "A=0 \<Longrightarrow> a \<notin> A"
 by blast
 
 declare sym [THEN equals0D, dest]
 
 lemma not_emptyI: "a\<in>A \<Longrightarrow> A \<noteq> 0"
 by blast
 
 lemma not_emptyE:  "\<lbrakk>A \<noteq> 0;  \<And>x. x\<in>A \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
 by blast
 
 
 subsection\<open>Rules for Inter\<close>
 
 (*Not obviously useful for proving InterI, InterD, InterE*)
 lemma Inter_iff: "A \<in> \<Inter>(C) <-> (\<forall>x\<in>C. A: x) \<and> C\<noteq>0"
 by (simp add: Inter_def Ball_def, blast)
 
 (* Intersection is well-behaved only if the family is non-empty! *)
 lemma InterI [intro!]:
     "\<lbrakk>\<And>x. x: C \<Longrightarrow> A: x;  C\<noteq>0\<rbrakk> \<Longrightarrow> A \<in> \<Inter>(C)"
 by (simp add: Inter_iff)
 
 (*A "destruct" rule -- every B in C contains A as an element, but
   A\<in>B can hold when B\<in>C does not!  This rule is analogous to "spec". *)
 lemma InterD [elim, Pure.elim]: "\<lbrakk>A \<in> \<Inter>(C);  B \<in> C\<rbrakk> \<Longrightarrow> A \<in> B"
 by (unfold Inter_def, blast)
 
 (*"Classical" elimination rule -- does not require exhibiting @{term"B\<in>C"} *)
 lemma InterE [elim]:
     "\<lbrakk>A \<in> \<Inter>(C);  B\<notin>C \<Longrightarrow> R;  A\<in>B \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
 by (simp add: Inter_def, blast)
 
 
 subsection\<open>Rules for Intersections of families\<close>
 
 (* @{term"\<Inter>x\<in>A. B(x)"} abbreviates @{term"\<Inter>({B(x). x\<in>A})"} *)
 
 lemma INT_iff: "b \<in> (\<Inter>x\<in>A. B(x)) <-> (\<forall>x\<in>A. b \<in> B(x)) \<and> A\<noteq>0"
 by (force simp add: Inter_def)
 
 lemma INT_I: "\<lbrakk>\<And>x. x: A \<Longrightarrow> b: B(x);  A\<noteq>0\<rbrakk> \<Longrightarrow> b: (\<Inter>x\<in>A. B(x))"
 by blast
 
 lemma INT_E: "\<lbrakk>b \<in> (\<Inter>x\<in>A. B(x));  a: A\<rbrakk> \<Longrightarrow> b \<in> B(a)"
 by blast
 
 lemma INT_cong:
     "\<lbrakk>A=B;  \<And>x. x\<in>B \<Longrightarrow> C(x)=D(x)\<rbrakk> \<Longrightarrow> (\<Inter>x\<in>A. C(x)) = (\<Inter>x\<in>B. D(x))"
 by simp
 
 (*No "Addcongs [INT_cong]" because @{term\<Inter>} is a combination of constants*)
 
 
 subsection\<open>Rules for Powersets\<close>
 
 lemma PowI: "A \<subseteq> B \<Longrightarrow> A \<in> Pow(B)"
 by (erule Pow_iff [THEN iffD2])
 
 lemma PowD: "A \<in> Pow(B)  \<Longrightarrow>  A<=B"
 by (erule Pow_iff [THEN iffD1])
 
 declare Pow_iff [iff]
 
 lemmas Pow_bottom = empty_subsetI [THEN PowI]    \<comment> \<open>\<^term>\<open>0 \<in> Pow(B)\<close>\<close>
 lemmas Pow_top = subset_refl [THEN PowI]         \<comment> \<open>\<^term>\<open>A \<in> Pow(A)\<close>\<close>
 
 
 subsection\<open>Cantor's Theorem: There is no surjection from a set to its powerset.\<close>
 
 (*The search is undirected.  Allowing redundant introduction rules may
   make it diverge.  Variable b represents ANY map, such as
   (lam x\<in>A.b(x)): A->Pow(A). *)
 lemma cantor: "\<exists>S \<in> Pow(A). \<forall>x\<in>A. b(x) \<noteq> S"
 by (best elim!: equalityCE del: ReplaceI RepFun_eqI)
 
 end
diff --git a/src/ZF/Zorn.thy b/src/ZF/Zorn.thy
--- a/src/ZF/Zorn.thy
+++ b/src/ZF/Zorn.thy
@@ -1,517 +1,517 @@
 (*  Title:      ZF/Zorn.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section\<open>Zorn's Lemma\<close>
 
 theory Zorn imports OrderArith AC Inductive begin
 
 text\<open>Based upon the unpublished article ``Towards the Mechanization of the
 Proofs of Some Classical Theorems of Set Theory,'' by Abrial and Laffitte.\<close>
 
 definition
   Subset_rel :: "i\<Rightarrow>i"  where
    "Subset_rel(A) \<equiv> {z \<in> A*A . \<exists>x y. z=\<langle>x,y\<rangle> \<and> x<=y \<and> x\<noteq>y}"
 
 definition
   chain      :: "i\<Rightarrow>i"  where
    "chain(A)      \<equiv> {F \<in> Pow(A). \<forall>X\<in>F. \<forall>Y\<in>F. X<=Y | Y<=X}"
 
 definition
   super      :: "[i,i]\<Rightarrow>i"  where
    "super(A,c)    \<equiv> {d \<in> chain(A). c<=d \<and> c\<noteq>d}"
 
 definition
   maxchain   :: "i\<Rightarrow>i"  where
    "maxchain(A)   \<equiv> {c \<in> chain(A). super(A,c)=0}"
 
 definition
   increasing :: "i\<Rightarrow>i"  where
     "increasing(A) \<equiv> {f \<in> Pow(A)->Pow(A). \<forall>x. x<=A \<longrightarrow> x<=f`x}"
 
 
 text\<open>Lemma for the inductive definition below\<close>
 lemma Union_in_Pow: "Y \<in> Pow(Pow(A)) \<Longrightarrow> \<Union>(Y) \<in> Pow(A)"
 by blast
 
 
 text\<open>We could make the inductive definition conditional on
     \<^term>\<open>next \<in> increasing(S)\<close>
     but instead we make this a side-condition of an introduction rule.  Thus
     the induction rule lets us assume that condition!  Many inductive proofs
     are therefore unconditional.\<close>
 consts
   "TFin" :: "[i,i]\<Rightarrow>i"
 
 inductive
   domains       "TFin(S,next)" \<subseteq> "Pow(S)"
   intros
     nextI:       "\<lbrakk>x \<in> TFin(S,next);  next \<in> increasing(S)\<rbrakk>
                   \<Longrightarrow> next`x \<in> TFin(S,next)"
 
     Pow_UnionI: "Y \<in> Pow(TFin(S,next)) \<Longrightarrow> \<Union>(Y) \<in> TFin(S,next)"
 
   monos         Pow_mono
   con_defs      increasing_def
   type_intros   CollectD1 [THEN apply_funtype] Union_in_Pow
 
 
 subsection\<open>Mathematical Preamble\<close>
 
 lemma Union_lemma0: "(\<forall>x\<in>C. x<=A | B<=x) \<Longrightarrow> \<Union>(C)<=A | B<=\<Union>(C)"
 by blast
 
 lemma Inter_lemma0:
      "\<lbrakk>c \<in> C; \<forall>x\<in>C. A<=x | x<=B\<rbrakk> \<Longrightarrow> A \<subseteq> \<Inter>(C) | \<Inter>(C) \<subseteq> B"
 by blast
 
 
 subsection\<open>The Transfinite Construction\<close>
 
 lemma increasingD1: "f \<in> increasing(A) \<Longrightarrow> f \<in> Pow(A)->Pow(A)"
   unfolding increasing_def
 apply (erule CollectD1)
 done
 
 lemma increasingD2: "\<lbrakk>f \<in> increasing(A); x<=A\<rbrakk> \<Longrightarrow> x \<subseteq> f`x"
 by (unfold increasing_def, blast)
 
 lemmas TFin_UnionI = PowI [THEN TFin.Pow_UnionI]
 
 lemmas TFin_is_subset = TFin.dom_subset [THEN subsetD, THEN PowD]
 
 
 text\<open>Structural induction on \<^term>\<open>TFin(S,next)\<close>\<close>
 lemma TFin_induct:
   "\<lbrakk>n \<in> TFin(S,next);
       \<And>x. \<lbrakk>x \<in> TFin(S,next);  P(x);  next \<in> increasing(S)\<rbrakk> \<Longrightarrow> P(next`x);
       \<And>Y. \<lbrakk>Y \<subseteq> TFin(S,next);  \<forall>y\<in>Y. P(y)\<rbrakk> \<Longrightarrow> P(\<Union>(Y))
 \<rbrakk> \<Longrightarrow> P(n)"
 by (erule TFin.induct, blast+)
 
 
 subsection\<open>Some Properties of the Transfinite Construction\<close>
 
 lemmas increasing_trans = subset_trans [OF _ increasingD2,
                                         OF _ _ TFin_is_subset]
 
 text\<open>Lemma 1 of section 3.1\<close>
 lemma TFin_linear_lemma1:
      "\<lbrakk>n \<in> TFin(S,next);  m \<in> TFin(S,next);
          \<forall>x \<in> TFin(S,next) . x<=m \<longrightarrow> x=m | next`x<=m\<rbrakk>
       \<Longrightarrow> n<=m | next`m<=n"
 apply (erule TFin_induct)
 apply (erule_tac [2] Union_lemma0) (*or just Blast_tac*)
 (*downgrade subsetI from intro! to intro*)
 apply (blast dest: increasing_trans)
 done
 
 text\<open>Lemma 2 of section 3.2.  Interesting in its own right!
   Requires \<^term>\<open>next \<in> increasing(S)\<close> in the second induction step.\<close>
 lemma TFin_linear_lemma2:
     "\<lbrakk>m \<in> TFin(S,next);  next \<in> increasing(S)\<rbrakk>
      \<Longrightarrow> \<forall>n \<in> TFin(S,next). n<=m \<longrightarrow> n=m | next`n \<subseteq> m"
 apply (erule TFin_induct)
 apply (rule impI [THEN ballI])
 txt\<open>case split using \<open>TFin_linear_lemma1\<close>\<close>
 apply (rule_tac n1 = n and m1 = x in TFin_linear_lemma1 [THEN disjE],
        assumption+)
 apply (blast del: subsetI
              intro: increasing_trans subsetI, blast)
 txt\<open>second induction step\<close>
 apply (rule impI [THEN ballI])
 apply (rule Union_lemma0 [THEN disjE])
 apply (erule_tac [3] disjI2)
 prefer 2 apply blast
 apply (rule ballI)
 apply (drule bspec, assumption)
 apply (drule subsetD, assumption)
 apply (rule_tac n1 = n and m1 = x in TFin_linear_lemma1 [THEN disjE],
        assumption+, blast)
 apply (erule increasingD2 [THEN subset_trans, THEN disjI1])
 apply (blast dest: TFin_is_subset)+
 done
 
 text\<open>a more convenient form for Lemma 2\<close>
 lemma TFin_subsetD:
      "\<lbrakk>n<=m;  m \<in> TFin(S,next);  n \<in> TFin(S,next);  next \<in> increasing(S)\<rbrakk>
       \<Longrightarrow> n=m | next`n \<subseteq> m"
 by (blast dest: TFin_linear_lemma2 [rule_format])
 
 text\<open>Consequences from section 3.3 -- Property 3.2, the ordering is total\<close>
 lemma TFin_subset_linear:
      "\<lbrakk>m \<in> TFin(S,next);  n \<in> TFin(S,next);  next \<in> increasing(S)\<rbrakk>
       \<Longrightarrow> n \<subseteq> m | m<=n"
 apply (rule disjE)
 apply (rule TFin_linear_lemma1 [OF _ _TFin_linear_lemma2])
 apply (assumption+, erule disjI2)
 apply (blast del: subsetI
              intro: subsetI increasingD2 [THEN subset_trans] TFin_is_subset)
 done
 
 
 text\<open>Lemma 3 of section 3.3\<close>
 lemma equal_next_upper:
      "\<lbrakk>n \<in> TFin(S,next);  m \<in> TFin(S,next);  m = next`m\<rbrakk> \<Longrightarrow> n \<subseteq> m"
 apply (erule TFin_induct)
 apply (drule TFin_subsetD)
 apply (assumption+, force, blast)
 done
 
 text\<open>Property 3.3 of section 3.3\<close>
 lemma equal_next_Union:
      "\<lbrakk>m \<in> TFin(S,next);  next \<in> increasing(S)\<rbrakk>
       \<Longrightarrow> m = next`m <-> m = \<Union>(TFin(S,next))"
 apply (rule iffI)
 apply (rule Union_upper [THEN equalityI])
 apply (rule_tac [2] equal_next_upper [THEN Union_least])
 apply (assumption+)
 apply (erule ssubst)
 apply (rule increasingD2 [THEN equalityI], assumption)
 apply (blast del: subsetI
              intro: subsetI TFin_UnionI TFin.nextI TFin_is_subset)+
 done
 
 
 subsection\<open>Hausdorff's Theorem: Every Set Contains a Maximal Chain\<close>
 
 text\<open>NOTE: We assume the partial ordering is \<open>\<subseteq>\<close>, the subset
 relation!\<close>
 
 text\<open>* Defining the "next" operation for Hausdorff's Theorem *\<close>
 
 lemma chain_subset_Pow: "chain(A) \<subseteq> Pow(A)"
   unfolding chain_def
 apply (rule Collect_subset)
 done
 
 lemma super_subset_chain: "super(A,c) \<subseteq> chain(A)"
   unfolding super_def
 apply (rule Collect_subset)
 done
 
 lemma maxchain_subset_chain: "maxchain(A) \<subseteq> chain(A)"
   unfolding maxchain_def
 apply (rule Collect_subset)
 done
 
 lemma choice_super:
      "\<lbrakk>ch \<in> (\<Prod>X \<in> Pow(chain(S)) - {0}. X); X \<in> chain(S);  X \<notin> maxchain(S)\<rbrakk>
       \<Longrightarrow> ch ` super(S,X) \<in> super(S,X)"
 apply (erule apply_type)
 apply (unfold super_def maxchain_def, blast)
 done
 
 lemma choice_not_equals:
      "\<lbrakk>ch \<in> (\<Prod>X \<in> Pow(chain(S)) - {0}. X); X \<in> chain(S);  X \<notin> maxchain(S)\<rbrakk>
       \<Longrightarrow> ch ` super(S,X) \<noteq> X"
 apply (rule notI)
 apply (drule choice_super, assumption, assumption)
 apply (simp add: super_def)
 done
 
 text\<open>This justifies Definition 4.4\<close>
 lemma Hausdorff_next_exists:
      "ch \<in> (\<Prod>X \<in> Pow(chain(S))-{0}. X) \<Longrightarrow>
       \<exists>next \<in> increasing(S). \<forall>X \<in> Pow(S).
                    next`X = if(X \<in> chain(S)-maxchain(S), ch`super(S,X), X)"
 apply (rule_tac x="\<lambda>X\<in>Pow(S).
                    if X \<in> chain(S) - maxchain(S) then ch ` super(S, X) else X"
        in bexI)
 apply force
   unfolding increasing_def
 apply (rule CollectI)
 apply (rule lam_type)
 apply (simp (no_asm_simp))
 apply (blast dest: super_subset_chain [THEN subsetD] 
                    chain_subset_Pow [THEN subsetD] choice_super)
 txt\<open>Now, verify that it increases\<close>
 apply (simp (no_asm_simp) add: Pow_iff subset_refl)
 apply safe
 apply (drule choice_super)
 apply (assumption+)
 apply (simp add: super_def, blast)
 done
 
 text\<open>Lemma 4\<close>
 lemma TFin_chain_lemma4:
      "\<lbrakk>c \<in> TFin(S,next);
          ch \<in> (\<Prod>X \<in> Pow(chain(S))-{0}. X);
          next \<in> increasing(S);
          \<forall>X \<in> Pow(S). next`X =
                           if(X \<in> chain(S)-maxchain(S), ch`super(S,X), X)\<rbrakk>
      \<Longrightarrow> c \<in> chain(S)"
 apply (erule TFin_induct)
 apply (simp (no_asm_simp) add: chain_subset_Pow [THEN subsetD, THEN PowD]
             choice_super [THEN super_subset_chain [THEN subsetD]])
   unfolding chain_def
 apply (rule CollectI, blast, safe)
 apply (rule_tac m1=B and n1=Ba in TFin_subset_linear [THEN disjE], fast+)
       txt\<open>\<open>Blast_tac's\<close> slow\<close>
 done
 
 theorem Hausdorff: "\<exists>c. c \<in> maxchain(S)"
 apply (rule AC_Pi_Pow [THEN exE])
 apply (rule Hausdorff_next_exists [THEN bexE], assumption)
 apply (rename_tac ch "next")
 apply (subgoal_tac "\<Union>(TFin (S,next)) \<in> chain (S) ")
 prefer 2
  apply (blast intro!: TFin_chain_lemma4 subset_refl [THEN TFin_UnionI])
 apply (rule_tac x = "\<Union>(TFin (S,next))" in exI)
 apply (rule classical)
 apply (subgoal_tac "next ` Union(TFin (S,next)) = \<Union>(TFin (S,next))")
 apply (rule_tac [2] equal_next_Union [THEN iffD2, symmetric])
 apply (rule_tac [2] subset_refl [THEN TFin_UnionI])
 prefer 2 apply assumption
 apply (rule_tac [2] refl)
 apply (simp add: subset_refl [THEN TFin_UnionI,
                               THEN TFin.dom_subset [THEN subsetD, THEN PowD]])
 apply (erule choice_not_equals [THEN notE])
 apply (assumption+)
 done
 
 
 subsection\<open>Zorn's Lemma: If All Chains in S Have Upper Bounds In S,
        then S contains a Maximal Element\<close>
 
 text\<open>Used in the proof of Zorn's Lemma\<close>
 lemma chain_extend:
     "\<lbrakk>c \<in> chain(A);  z \<in> A;  \<forall>x \<in> c. x<=z\<rbrakk> \<Longrightarrow> cons(z,c) \<in> chain(A)"
 by (unfold chain_def, blast)
 
 lemma Zorn: "\<forall>c \<in> chain(S). \<Union>(c) \<in> S \<Longrightarrow> \<exists>y \<in> S. \<forall>z \<in> S. y<=z \<longrightarrow> y=z"
 apply (rule Hausdorff [THEN exE])
 apply (simp add: maxchain_def)
 apply (rename_tac c)
 apply (rule_tac x = "\<Union>(c)" in bexI)
 prefer 2 apply blast
 apply safe
 apply (rename_tac z)
 apply (rule classical)
 apply (subgoal_tac "cons (z,c) \<in> super (S,c) ")
 apply (blast elim: equalityE)
 apply (unfold super_def, safe)
 apply (fast elim: chain_extend)
 apply (fast elim: equalityE)
 done
 
 text \<open>Alternative version of Zorn's Lemma\<close>
 
 theorem Zorn2:
   "\<forall>c \<in> chain(S). \<exists>y \<in> S. \<forall>x \<in> c. x \<subseteq> y \<Longrightarrow> \<exists>y \<in> S. \<forall>z \<in> S. y<=z \<longrightarrow> y=z"
 apply (cut_tac Hausdorff maxchain_subset_chain)
 apply (erule exE)
 apply (drule subsetD, assumption)
 apply (drule bspec, assumption, erule bexE)
 apply (rule_tac x = y in bexI)
   prefer 2 apply assumption
 apply clarify
 apply rule apply assumption
 apply rule
 apply (rule ccontr)
 apply (frule_tac z=z in chain_extend)
   apply (assumption, blast)
-apply (unfold maxchain_def super_def)
+  unfolding maxchain_def super_def
 apply (blast elim!: equalityCE)
 done
 
 
 subsection\<open>Zermelo's Theorem: Every Set can be Well-Ordered\<close>
 
 text\<open>Lemma 5\<close>
 lemma TFin_well_lemma5:
      "\<lbrakk>n \<in> TFin(S,next);  Z \<subseteq> TFin(S,next);  z:Z;  \<not> \<Inter>(Z) \<in> Z\<rbrakk>
       \<Longrightarrow> \<forall>m \<in> Z. n \<subseteq> m"
 apply (erule TFin_induct)
 prefer 2 apply blast txt\<open>second induction step is easy\<close>
 apply (rule ballI)
 apply (rule bspec [THEN TFin_subsetD, THEN disjE], auto)
 apply (subgoal_tac "m = \<Inter>(Z) ")
 apply blast+
 done
 
 text\<open>Well-ordering of \<^term>\<open>TFin(S,next)\<close>\<close>
 lemma well_ord_TFin_lemma: "\<lbrakk>Z \<subseteq> TFin(S,next);  z \<in> Z\<rbrakk> \<Longrightarrow> \<Inter>(Z) \<in> Z"
 apply (rule classical)
 apply (subgoal_tac "Z = {\<Union>(TFin (S,next))}")
 apply (simp (no_asm_simp) add: Inter_singleton)
 apply (erule equal_singleton)
 apply (rule Union_upper [THEN equalityI])
 apply (rule_tac [2] subset_refl [THEN TFin_UnionI, THEN TFin_well_lemma5, THEN bspec], blast+)
 done
 
 text\<open>This theorem just packages the previous result\<close>
 lemma well_ord_TFin:
      "next \<in> increasing(S) 
       \<Longrightarrow> well_ord(TFin(S,next), Subset_rel(TFin(S,next)))"
 apply (rule well_ordI)
-apply (unfold Subset_rel_def linear_def)
+  unfolding Subset_rel_def linear_def
 txt\<open>Prove the well-foundedness goal\<close>
 apply (rule wf_onI)
 apply (frule well_ord_TFin_lemma, assumption)
 apply (drule_tac x = "\<Inter>(Z) " in bspec, assumption)
 apply blast
 txt\<open>Now prove the linearity goal\<close>
 apply (intro ballI)
 apply (case_tac "x=y")
  apply blast
 txt\<open>The \<^term>\<open>x\<noteq>y\<close> case remains\<close>
 apply (rule_tac n1=x and m1=y in TFin_subset_linear [THEN disjE],
        assumption+, blast+)
 done
 
 text\<open>* Defining the "next" operation for Zermelo's Theorem *\<close>
 
 lemma choice_Diff:
      "\<lbrakk>ch \<in> (\<Prod>X \<in> Pow(S) - {0}. X);  X \<subseteq> S;  X\<noteq>S\<rbrakk> \<Longrightarrow> ch ` (S-X) \<in> S-X"
 apply (erule apply_type)
 apply (blast elim!: equalityE)
 done
 
 text\<open>This justifies Definition 6.1\<close>
 lemma Zermelo_next_exists:
      "ch \<in> (\<Prod>X \<in> Pow(S)-{0}. X) \<Longrightarrow>
            \<exists>next \<in> increasing(S). \<forall>X \<in> Pow(S).
                       next`X = (if X=S then S else cons(ch`(S-X), X))"
 apply (rule_tac x="\<lambda>X\<in>Pow(S). if X=S then S else cons(ch`(S-X), X)"
        in bexI)
 apply force
   unfolding increasing_def
 apply (rule CollectI)
 apply (rule lam_type)
 txt\<open>Type checking is surprisingly hard!\<close>
 apply (simp (no_asm_simp) add: Pow_iff cons_subset_iff subset_refl)
 apply (blast intro!: choice_Diff [THEN DiffD1])
 txt\<open>Verify that it increases\<close>
 apply (intro allI impI)
 apply (simp add: Pow_iff subset_consI subset_refl)
 done
 
 
 text\<open>The construction of the injection\<close>
 lemma choice_imp_injection:
      "\<lbrakk>ch \<in> (\<Prod>X \<in> Pow(S)-{0}. X);
          next \<in> increasing(S);
          \<forall>X \<in> Pow(S). next`X = if(X=S, S, cons(ch`(S-X), X))\<rbrakk>
       \<Longrightarrow> (\<lambda> x \<in> S. \<Union>({y \<in> TFin(S,next). x \<notin> y}))
                \<in> inj(S, TFin(S,next) - {S})"
 apply (rule_tac d = "\<lambda>y. ch` (S-y) " in lam_injective)
 apply (rule DiffI)
 apply (rule Collect_subset [THEN TFin_UnionI])
 apply (blast intro!: Collect_subset [THEN TFin_UnionI] elim: equalityE)
 apply (subgoal_tac "x \<notin> \<Union>({y \<in> TFin (S,next) . x \<notin> y}) ")
 prefer 2 apply (blast elim: equalityE)
 apply (subgoal_tac "\<Union>({y \<in> TFin (S,next) . x \<notin> y}) \<noteq> S")
 prefer 2 apply (blast elim: equalityE)
 txt\<open>For proving \<open>x \<in> next`\<Union>(...)\<close>.
   Abrial and Laffitte's justification appears to be faulty.\<close>
 apply (subgoal_tac "\<not> next ` Union({y \<in> TFin (S,next) . x \<notin> y}) 
                     \<subseteq> \<Union>({y \<in> TFin (S,next) . x \<notin> y}) ")
  prefer 2
  apply (simp del: Union_iff
              add: Collect_subset [THEN TFin_UnionI, THEN TFin_is_subset]
              Pow_iff cons_subset_iff subset_refl choice_Diff [THEN DiffD2])
 apply (subgoal_tac "x \<in> next ` Union({y \<in> TFin (S,next) . x \<notin> y}) ")
  prefer 2
  apply (blast intro!: Collect_subset [THEN TFin_UnionI] TFin.nextI)
 txt\<open>End of the lemmas!\<close>
 apply (simp add: Collect_subset [THEN TFin_UnionI, THEN TFin_is_subset])
 done
 
 text\<open>The wellordering theorem\<close>
 theorem AC_well_ord: "\<exists>r. well_ord(S,r)"
 apply (rule AC_Pi_Pow [THEN exE])
 apply (rule Zermelo_next_exists [THEN bexE], assumption)
 apply (rule exI)
 apply (rule well_ord_rvimage)
 apply (erule_tac [2] well_ord_TFin)
 apply (rule choice_imp_injection [THEN inj_weaken_type], blast+)
 done
 
 
 subsection \<open>Zorn's Lemma for Partial Orders\<close>
 
 text \<open>Reimported from HOL by Clemens Ballarin.\<close>
 
 
 definition Chain :: "i \<Rightarrow> i" where
   "Chain(r) = {A \<in> Pow(field(r)). \<forall>a\<in>A. \<forall>b\<in>A. \<langle>a, b\<rangle> \<in> r | \<langle>b, a\<rangle> \<in> r}"
 
 lemma mono_Chain:
   "r \<subseteq> s \<Longrightarrow> Chain(r) \<subseteq> Chain(s)"
   unfolding Chain_def
   by blast
 
 theorem Zorn_po:
   assumes po: "Partial_order(r)"
     and u: "\<forall>C\<in>Chain(r). \<exists>u\<in>field(r). \<forall>a\<in>C. \<langle>a, u\<rangle> \<in> r"
   shows "\<exists>m\<in>field(r). \<forall>a\<in>field(r). \<langle>m, a\<rangle> \<in> r \<longrightarrow> a = m"
 proof -
   have "Preorder(r)" using po by (simp add: partial_order_on_def)
   \<comment> \<open>Mirror r in the set of subsets below (wrt r) elements of A (?).\<close>
   let ?B = "\<lambda>x\<in>field(r). r -`` {x}" let ?S = "?B `` field(r)"
   have "\<forall>C\<in>chain(?S). \<exists>U\<in>?S. \<forall>A\<in>C. A \<subseteq> U"
   proof (clarsimp simp: chain_def Subset_rel_def bex_image_simp)
     fix C
     assume 1: "C \<subseteq> ?S" and 2: "\<forall>A\<in>C. \<forall>B\<in>C. A \<subseteq> B | B \<subseteq> A"
     let ?A = "{x \<in> field(r). \<exists>M\<in>C. M = ?B`x}"
     have "C = ?B `` ?A" using 1
       apply (auto simp: image_def)
       apply rule
       apply rule
       apply (drule subsetD) apply assumption
       apply (erule CollectE)
       apply rule apply assumption
       apply (erule bexE)
       apply rule prefer 2 apply assumption
       apply rule
       apply (erule lamE) apply simp
       apply assumption
 
       apply (thin_tac "C \<subseteq> X" for X)
       apply (fast elim: lamE)
       done
     have "?A \<in> Chain(r)"
     proof (simp add: Chain_def subsetI, intro conjI ballI impI)
       fix a b
       assume "a \<in> field(r)" "r -`` {a} \<in> C" "b \<in> field(r)" "r -`` {b} \<in> C"
       hence "r -`` {a} \<subseteq> r -`` {b} | r -`` {b} \<subseteq> r -`` {a}" using 2 by auto
       then show "\<langle>a, b\<rangle> \<in> r | \<langle>b, a\<rangle> \<in> r"
         using \<open>Preorder(r)\<close> \<open>a \<in> field(r)\<close> \<open>b \<in> field(r)\<close>
         by (simp add: subset_vimage1_vimage1_iff)
     qed
     then obtain u where uA: "u \<in> field(r)" "\<forall>a\<in>?A. \<langle>a, u\<rangle> \<in> r"
       using u
       apply auto
       apply (drule bspec) apply assumption
       apply auto
       done
     have "\<forall>A\<in>C. A \<subseteq> r -`` {u}"
     proof (auto intro!: vimageI)
       fix a B
       assume aB: "B \<in> C" "a \<in> B"
       with 1 obtain x where "x \<in> field(r)" "B = r -`` {x}"
         apply -
         apply (drule subsetD) apply assumption
         apply (erule imageE)
         apply (erule lamE)
         apply simp
         done
       then show "\<langle>a, u\<rangle> \<in> r" using uA aB \<open>Preorder(r)\<close>
         by (auto simp: preorder_on_def refl_def) (blast dest: trans_onD)+
     qed
     then show "\<exists>U\<in>field(r). \<forall>A\<in>C. A \<subseteq> r -`` {U}"
       using \<open>u \<in> field(r)\<close> ..
   qed
   from Zorn2 [OF this]
   obtain m B where "m \<in> field(r)" "B = r -`` {m}"
     "\<forall>x\<in>field(r). B \<subseteq> r -`` {x} \<longrightarrow> B = r -`` {x}"
     by (auto elim!: lamE simp: ball_image_simp)
   then have "\<forall>a\<in>field(r). \<langle>m, a\<rangle> \<in> r \<longrightarrow> a = m"
     using po \<open>Preorder(r)\<close> \<open>m \<in> field(r)\<close>
     by (auto simp: subset_vimage1_vimage1_iff Partial_order_eq_vimage1_vimage1_iff)
   then show ?thesis using \<open>m \<in> field(r)\<close> by blast
 qed
 
 end
diff --git a/src/ZF/ex/CoUnit.thy b/src/ZF/ex/CoUnit.thy
--- a/src/ZF/ex/CoUnit.thy
+++ b/src/ZF/ex/CoUnit.thy
@@ -1,102 +1,102 @@
 (*  Title:      ZF/ex/CoUnit.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 *)
 
 section \<open>Trivial codatatype definitions, one of which goes wrong!\<close>
 
 theory CoUnit imports ZF begin
 
 text \<open>
   See discussion in: L C Paulson.  A Concrete Final Coalgebra Theorem
   for ZF Set Theory.  Report 334, Cambridge University Computer
   Laboratory.  1994.
 
   \bigskip
 
   This degenerate definition does not work well because the one
   constructor's definition is trivial!  The same thing occurs with
   Aczel's Special Final Coalgebra Theorem.
 \<close>
 
 consts
   counit :: i
 codatatype
   "counit" = Con ("x \<in> counit")
 
 inductive_cases ConE: "Con(x) \<in> counit"
   \<comment> \<open>USELESS because folding on \<^term>\<open>Con(xa) \<equiv> xa\<close> fails.\<close>
 
 lemma Con_iff: "Con(x) = Con(y) \<longleftrightarrow> x = y"
   \<comment> \<open>Proving freeness results.\<close>
   by (auto elim!: counit.free_elims)
 
 lemma counit_eq_univ: "counit = quniv(0)"
   \<comment> \<open>Should be a singleton, not everything!\<close>
   apply (rule counit.dom_subset [THEN equalityI])
   apply (rule subsetI)
   apply (erule counit.coinduct)
    apply (rule subset_refl)
-  apply (unfold counit.con_defs)
+    unfolding counit.con_defs
   apply fast
   done
 
 
 text \<open>
   \medskip A similar example, but the constructor is non-degenerate
   and it works!  The resulting set is a singleton.
 \<close>
 
 consts
   counit2 :: i
 codatatype
   "counit2" = Con2 ("x \<in> counit2", "y \<in> counit2")
 
 
 inductive_cases Con2E: "Con2(x, y) \<in> counit2"
 
 lemma Con2_iff: "Con2(x, y) = Con2(x', y') \<longleftrightarrow> x = x' \<and> y = y'"
   \<comment> \<open>Proving freeness results.\<close>
   by (fast elim!: counit2.free_elims)
 
 lemma Con2_bnd_mono: "bnd_mono(univ(0), \<lambda>x. Con2(x, x))"
-  apply (unfold counit2.con_defs)
+    unfolding counit2.con_defs
   apply (rule bnd_monoI)
    apply (assumption | rule subset_refl QPair_subset_univ QPair_mono)+
   done
 
 lemma lfp_Con2_in_counit2: "lfp(univ(0), \<lambda>x. Con2(x,x)) \<in> counit2"
   apply (rule singletonI [THEN counit2.coinduct])
   apply (rule qunivI [THEN singleton_subsetI])
   apply (rule subset_trans [OF lfp_subset empty_subsetI [THEN univ_mono]])
   apply (fast intro!: Con2_bnd_mono [THEN lfp_unfold])
   done
 
 lemma counit2_Int_Vset_subset [rule_format]:
   "Ord(i) \<Longrightarrow> \<forall>x y. x \<in> counit2 \<longrightarrow> y \<in> counit2 \<longrightarrow> x \<inter> Vset(i) \<subseteq> y"
   \<comment> \<open>Lemma for proving finality.\<close>
   apply (erule trans_induct)
   apply (tactic "safe_tac (put_claset subset_cs \<^context>)")
   apply (erule counit2.cases)
   apply (erule counit2.cases)
-  apply (unfold counit2.con_defs)
+    unfolding counit2.con_defs
   apply (tactic \<open>fast_tac (put_claset subset_cs \<^context>
     addSIs [@{thm QPair_Int_Vset_subset_UN} RS @{thm subset_trans}, @{thm QPair_mono}]
     addSEs [@{thm Ord_in_Ord}, @{thm Pair_inject}]) 1\<close>)
   done
 
 lemma counit2_implies_equal: "\<lbrakk>x \<in> counit2;  y \<in> counit2\<rbrakk> \<Longrightarrow> x = y"
   apply (rule equalityI)
   apply (assumption | rule conjI counit2_Int_Vset_subset [THEN Int_Vset_subset])+
   done
 
 lemma counit2_eq_univ: "counit2 = {lfp(univ(0), \<lambda>x. Con2(x,x))}"
   apply (rule equalityI)
    apply (rule_tac [2] lfp_Con2_in_counit2 [THEN singleton_subsetI])
   apply (rule subsetI)
   apply (drule lfp_Con2_in_counit2 [THEN counit2_implies_equal])
   apply (erule subst)
   apply (rule singletonI)
   done
 
 end
diff --git a/src/ZF/ex/Commutation.thy b/src/ZF/ex/Commutation.thy
--- a/src/ZF/ex/Commutation.thy
+++ b/src/ZF/ex/Commutation.thy
@@ -1,142 +1,142 @@
 (*  Title:      ZF/ex/Commutation.thy
     Author:     Tobias Nipkow \<and> Sidi Ould Ehmety
     Copyright   1995  TU Muenchen
 
 Commutation theory for proving the Church Rosser theorem.
 *)
 
 theory Commutation imports ZF begin
 
 definition
   square  :: "[i, i, i, i] \<Rightarrow> o" where
   "square(r,s,t,u) \<equiv>
     (\<forall>a b. \<langle>a,b\<rangle> \<in> r \<longrightarrow> (\<forall>c. \<langle>a, c\<rangle> \<in> s \<longrightarrow> (\<exists>x. \<langle>b,x\<rangle> \<in> t \<and> \<langle>c,x\<rangle> \<in> u)))"
 
 definition
   commute :: "[i, i] \<Rightarrow> o" where
   "commute(r,s) \<equiv> square(r,s,s,r)"
 
 definition
   diamond :: "i\<Rightarrow>o" where
   "diamond(r)   \<equiv> commute(r, r)"
 
 definition
   strip :: "i\<Rightarrow>o" where
   "strip(r) \<equiv> commute(r^*, r)"
 
 definition
   Church_Rosser :: "i \<Rightarrow> o" where
   "Church_Rosser(r) \<equiv> (\<forall>x y. \<langle>x,y\<rangle> \<in>  (r \<union> converse(r))^* \<longrightarrow>
                         (\<exists>z. \<langle>x,z\<rangle> \<in> r^* \<and> \<langle>y,z\<rangle> \<in> r^*))"
 
 definition
   confluent :: "i\<Rightarrow>o" where
   "confluent(r) \<equiv> diamond(r^*)"
 
 
 lemma square_sym: "square(r,s,t,u) \<Longrightarrow> square(s,r,u,t)"
   unfolding square_def by blast
 
 lemma square_subset: "\<lbrakk>square(r,s,t,u); t \<subseteq> t'\<rbrakk> \<Longrightarrow> square(r,s,t',u)"
   unfolding square_def by blast
 
 
 lemma square_rtrancl:
   "square(r,s,s,t) \<Longrightarrow> field(s)<=field(t) \<Longrightarrow> square(r^*,s,s,t^*)"
 apply (unfold square_def, clarify)
 apply (erule rtrancl_induct)
 apply (blast intro: rtrancl_refl)
 apply (blast intro: rtrancl_into_rtrancl)
 done
 
 (* A special case of square_rtrancl_on *)
 lemma diamond_strip:
   "diamond(r) \<Longrightarrow> strip(r)"
-apply (unfold diamond_def commute_def strip_def)
+  unfolding diamond_def commute_def strip_def
 apply (rule square_rtrancl, simp_all)
 done
 
 (*** commute ***)
 
 lemma commute_sym: "commute(r,s) \<Longrightarrow> commute(s,r)"
   unfolding commute_def by (blast intro: square_sym)
 
 lemma commute_rtrancl:
   "commute(r,s) \<Longrightarrow> field(r)=field(s) \<Longrightarrow> commute(r^*,s^*)"
   unfolding commute_def
 apply (rule square_rtrancl)
 apply (rule square_sym [THEN square_rtrancl, THEN square_sym])
 apply (simp_all add: rtrancl_field)
 done
 
 
 lemma confluentD: "confluent(r) \<Longrightarrow> diamond(r^*)"
 by (simp add: confluent_def)
 
 lemma strip_confluent: "strip(r) \<Longrightarrow> confluent(r)"
-apply (unfold strip_def confluent_def diamond_def)
+  unfolding strip_def confluent_def diamond_def
 apply (drule commute_rtrancl)
 apply (simp_all add: rtrancl_field)
 done
 
 lemma commute_Un: "\<lbrakk>commute(r,t); commute(s,t)\<rbrakk> \<Longrightarrow> commute(r \<union> s, t)"
   unfolding commute_def square_def by blast
 
 lemma diamond_Un:
      "\<lbrakk>diamond(r); diamond(s); commute(r, s)\<rbrakk> \<Longrightarrow> diamond(r \<union> s)"
   unfolding diamond_def by (blast intro: commute_Un commute_sym)
 
 lemma diamond_confluent:
     "diamond(r) \<Longrightarrow> confluent(r)"
-apply (unfold diamond_def confluent_def)
+  unfolding diamond_def confluent_def
 apply (erule commute_rtrancl, simp)
 done
 
 lemma confluent_Un:
  "\<lbrakk>confluent(r); confluent(s); commute(r^*, s^*);
      relation(r); relation(s)\<rbrakk> \<Longrightarrow> confluent(r \<union> s)"
   unfolding confluent_def
 apply (rule rtrancl_Un_rtrancl [THEN subst], auto)
 apply (blast dest: diamond_Un intro: diamond_confluent [THEN confluentD])
 done
 
 
 lemma diamond_to_confluence:
      "\<lbrakk>diamond(r); s \<subseteq> r; r<= s^*\<rbrakk> \<Longrightarrow> confluent(s)"
 apply (drule rtrancl_subset [symmetric], assumption)
 apply (simp_all add: confluent_def)
 apply (blast intro: diamond_confluent [THEN confluentD])
 done
 
 
 (*** Church_Rosser ***)
 
 lemma Church_Rosser1:
      "Church_Rosser(r) \<Longrightarrow> confluent(r)"
 apply (unfold confluent_def Church_Rosser_def square_def
               commute_def diamond_def, auto)
 apply (drule converseI)
 apply (simp (no_asm_use) add: rtrancl_converse [symmetric])
 apply (drule_tac x = b in spec)
 apply (drule_tac x1 = c in spec [THEN mp])
 apply (rule_tac b = a in rtrancl_trans)
 apply (blast intro: rtrancl_mono [THEN subsetD])+
 done
 
 
 lemma Church_Rosser2:
      "confluent(r) \<Longrightarrow> Church_Rosser(r)"
 apply (unfold confluent_def Church_Rosser_def square_def
               commute_def diamond_def, auto)
 apply (frule fieldI1)
 apply (simp add: rtrancl_field)
 apply (erule rtrancl_induct, auto)
 apply (blast intro: rtrancl_refl)
 apply (blast del: rtrancl_refl intro: r_into_rtrancl rtrancl_trans)+
 done
 
 
 lemma Church_Rosser: "Church_Rosser(r) \<longleftrightarrow> confluent(r)"
   by (blast intro: Church_Rosser1 Church_Rosser2)
 
 end
diff --git a/src/ZF/ex/Group.thy b/src/ZF/ex/Group.thy
--- a/src/ZF/ex/Group.thy
+++ b/src/ZF/ex/Group.thy
@@ -1,1231 +1,1231 @@
 (*  Title:      ZF/ex/Group.thy *)
 
 section \<open>Groups\<close>
 
 theory Group imports ZF begin
 
 text\<open>Based on work by Clemens Ballarin, Florian Kammueller, L C Paulson and
 Markus Wenzel.\<close>
 
 
 subsection \<open>Monoids\<close>
 
 (*First, we must simulate a record declaration:
 record monoid =
   carrier :: i
   mult :: "[i,i] \<Rightarrow> i" (infixl "\<cdot>\<index>" 70)
   one :: i ("\<one>\<index>")
 *)
 
 definition
   carrier :: "i \<Rightarrow> i" where
   "carrier(M) \<equiv> fst(M)"
 
 definition
   mmult :: "[i, i, i] \<Rightarrow> i" (infixl \<open>\<cdot>\<index>\<close> 70) where
   "mmult(M,x,y) \<equiv> fst(snd(M)) ` \<langle>x,y\<rangle>"
 
 definition
   one :: "i \<Rightarrow> i" (\<open>\<one>\<index>\<close>) where
   "one(M) \<equiv> fst(snd(snd(M)))"
 
 definition
   update_carrier :: "[i,i] \<Rightarrow> i" where
   "update_carrier(M,A) \<equiv> <A,snd(M)>"
 
 definition
   m_inv :: "i \<Rightarrow> i \<Rightarrow> i" (\<open>inv\<index> _\<close> [81] 80) where
   "inv\<^bsub>G\<^esub> x \<equiv> (THE y. y \<in> carrier(G) \<and> y \<cdot>\<^bsub>G\<^esub> x = \<one>\<^bsub>G\<^esub> \<and> x \<cdot>\<^bsub>G\<^esub> y = \<one>\<^bsub>G\<^esub>)"
 
 locale monoid = fixes G (structure)
   assumes m_closed [intro, simp]:
          "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> carrier(G)"
       and m_assoc:
          "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
           \<Longrightarrow> (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
       and one_closed [intro, simp]: "\<one> \<in> carrier(G)"
       and l_one [simp]: "x \<in> carrier(G) \<Longrightarrow> \<one> \<cdot> x = x"
       and r_one [simp]: "x \<in> carrier(G) \<Longrightarrow> x \<cdot> \<one> = x"
 
 text\<open>Simulating the record\<close>
 lemma carrier_eq [simp]: "carrier(\<langle>A,Z\<rangle>) = A"
   by (simp add: carrier_def)
 
 lemma mult_eq [simp]: "mmult(<A,M,Z>, x, y) = M ` \<langle>x,y\<rangle>"
   by (simp add: mmult_def)
 
 lemma one_eq [simp]: "one(<A,M,I,Z>) = I"
   by (simp add: one_def)
 
 lemma update_carrier_eq [simp]: "update_carrier(\<langle>A,Z\<rangle>,B) = \<langle>B,Z\<rangle>"
   by (simp add: update_carrier_def)
 
 lemma carrier_update_carrier [simp]: "carrier(update_carrier(M,B)) = B"
   by (simp add: update_carrier_def)
 
 lemma mult_update_carrier [simp]: "mmult(update_carrier(M,B),x,y) = mmult(M,x,y)"
   by (simp add: update_carrier_def mmult_def)
 
 lemma one_update_carrier [simp]: "one(update_carrier(M,B)) = one(M)"
   by (simp add: update_carrier_def one_def)
 
 
 lemma (in monoid) inv_unique:
   assumes eq: "y \<cdot> x = \<one>"  "x \<cdot> y' = \<one>"
     and G: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "y' \<in> carrier(G)"
   shows "y = y'"
 proof -
   from G eq have "y = y \<cdot> (x \<cdot> y')" by simp
   also from G have "... = (y \<cdot> x) \<cdot> y'" by (simp add: m_assoc)
   also from G eq have "... = y'" by simp
   finally show ?thesis .
 qed
 
 text \<open>
   A group is a monoid all of whose elements are invertible.
 \<close>
 
 locale group = monoid +
   assumes inv_ex:
      "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<exists>y \<in> carrier(G). y \<cdot> x = \<one> \<and> x \<cdot> y = \<one>"
 
 lemma (in group) is_group [simp]: "group(G)" by (rule group_axioms)
 
 theorem groupI:
   fixes G (structure)
   assumes m_closed [simp]:
       "\<And>x y. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> carrier(G)"
     and one_closed [simp]: "\<one> \<in> carrier(G)"
     and m_assoc:
       "\<And>x y z. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
       (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
     and l_one [simp]: "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<one> \<cdot> x = x"
     and l_inv_ex: "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<exists>y \<in> carrier(G). y \<cdot> x = \<one>"
   shows "group(G)"
 proof -
   have l_cancel [simp]:
     "\<And>x y z. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
     (x \<cdot> y = x \<cdot> z) \<longleftrightarrow> (y = z)"
   proof
     fix x y z
     assume G: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "z \<in> carrier(G)"
     {
       assume eq: "x \<cdot> y = x \<cdot> z"
       with G l_inv_ex obtain x_inv where xG: "x_inv \<in> carrier(G)"
         and l_inv: "x_inv \<cdot> x = \<one>" by fast
       from G eq xG have "(x_inv \<cdot> x) \<cdot> y = (x_inv \<cdot> x) \<cdot> z"
         by (simp add: m_assoc)
       with G show "y = z" by (simp add: l_inv)
     next
       assume eq: "y = z"
       with G show "x \<cdot> y = x \<cdot> z" by simp
     }
   qed
   have r_one:
     "\<And>x. x \<in> carrier(G) \<Longrightarrow> x \<cdot> \<one> = x"
   proof -
     fix x
     assume x: "x \<in> carrier(G)"
     with l_inv_ex obtain x_inv where xG: "x_inv \<in> carrier(G)"
       and l_inv: "x_inv \<cdot> x = \<one>" by fast
     from x xG have "x_inv \<cdot> (x \<cdot> \<one>) = x_inv \<cdot> x"
       by (simp add: m_assoc [symmetric] l_inv)
     with x xG show "x \<cdot> \<one> = x" by simp
   qed
   have inv_ex:
     "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<exists>y \<in> carrier(G). y \<cdot> x = \<one> \<and> x \<cdot> y = \<one>"
   proof -
     fix x
     assume x: "x \<in> carrier(G)"
     with l_inv_ex obtain y where y: "y \<in> carrier(G)"
       and l_inv: "y \<cdot> x = \<one>" by fast
     from x y have "y \<cdot> (x \<cdot> y) = y \<cdot> \<one>"
       by (simp add: m_assoc [symmetric] l_inv r_one)
     with x y have r_inv: "x \<cdot> y = \<one>"
       by simp
     from x y show "\<exists>y \<in> carrier(G). y \<cdot> x = \<one> \<and> x \<cdot> y = \<one>"
       by (fast intro: l_inv r_inv)
   qed
   show ?thesis
     by (blast intro: group.intro monoid.intro group_axioms.intro
                      assms r_one inv_ex)
 qed
 
 lemma (in group) inv [simp]:
   "x \<in> carrier(G) \<Longrightarrow> inv x \<in> carrier(G) \<and> inv x \<cdot> x = \<one> \<and> x \<cdot> inv x = \<one>"
   apply (frule inv_ex)
-  apply (unfold Bex_def m_inv_def)
+    unfolding Bex_def m_inv_def
   apply (erule exE)
   apply (rule theI)
   apply (rule ex1I, assumption)
    apply (blast intro: inv_unique)
   done
 
 lemma (in group) inv_closed [intro!]:
   "x \<in> carrier(G) \<Longrightarrow> inv x \<in> carrier(G)"
   by simp
 
 lemma (in group) l_inv:
   "x \<in> carrier(G) \<Longrightarrow> inv x \<cdot> x = \<one>"
   by simp
 
 lemma (in group) r_inv:
   "x \<in> carrier(G) \<Longrightarrow> x \<cdot> inv x = \<one>"
   by simp
 
 
 subsection \<open>Cancellation Laws and Basic Properties\<close>
 
 lemma (in group) l_cancel [simp]:
   assumes "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
   shows "(x \<cdot> y = x \<cdot> z) \<longleftrightarrow> (y = z)"
 proof
   assume eq: "x \<cdot> y = x \<cdot> z"
   hence  "(inv x \<cdot> x) \<cdot> y = (inv x \<cdot> x) \<cdot> z"
     by (simp only: m_assoc inv_closed assms)
   thus "y = z" by (simp add: assms)
 next
   assume eq: "y = z"
   then show "x \<cdot> y = x \<cdot> z" by simp
 qed
 
 lemma (in group) r_cancel [simp]:
   assumes "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
   shows "(y \<cdot> x = z \<cdot> x) \<longleftrightarrow> (y = z)"
 proof
   assume eq: "y \<cdot> x = z \<cdot> x"
   then have "y \<cdot> (x \<cdot> inv x) = z \<cdot> (x \<cdot> inv x)"
     by (simp only: m_assoc [symmetric] inv_closed assms)
   thus "y = z" by (simp add: assms)
 next
   assume eq: "y = z"
   thus  "y \<cdot> x = z \<cdot> x" by simp
 qed
 
 lemma (in group) inv_comm:
   assumes "x \<cdot> y = \<one>"
       and G: "x \<in> carrier(G)"  "y \<in> carrier(G)"
   shows "y \<cdot> x = \<one>"
 proof -
   from G have "x \<cdot> y \<cdot> x = x \<cdot> \<one>" by (auto simp add: assms)
   with G show ?thesis by (simp del: r_one add: m_assoc)
 qed
 
 lemma (in group) inv_equality:
      "\<lbrakk>y \<cdot> x = \<one>; x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv x = y"
 apply (simp add: m_inv_def)
 apply (rule the_equality)
  apply (simp add: inv_comm [of y x])
 apply (rule r_cancel [THEN iffD1], auto)
 done
 
 lemma (in group) inv_one [simp]:
   "inv \<one> = \<one>"
   by (auto intro: inv_equality)
 
 lemma (in group) inv_inv [simp]: "x \<in> carrier(G) \<Longrightarrow> inv (inv x) = x"
   by (auto intro: inv_equality)
 
 text\<open>This proof is by cancellation\<close>
 lemma (in group) inv_mult_group:
   "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv (x \<cdot> y) = inv y \<cdot> inv x"
 proof -
   assume G: "x \<in> carrier(G)"  "y \<in> carrier(G)"
   then have "inv (x \<cdot> y) \<cdot> (x \<cdot> y) = (inv y \<cdot> inv x) \<cdot> (x \<cdot> y)"
     by (simp add: m_assoc l_inv) (simp add: m_assoc [symmetric] l_inv)
   with G show ?thesis by (simp_all del: inv add: inv_closed)
 qed
 
 
 subsection \<open>Substructures\<close>
 
 locale subgroup = fixes H and G (structure)
   assumes subset: "H \<subseteq> carrier(G)"
     and m_closed [intro, simp]: "\<lbrakk>x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> H"
     and  one_closed [simp]: "\<one> \<in> H"
     and m_inv_closed [intro,simp]: "x \<in> H \<Longrightarrow> inv x \<in> H"
 
 
 lemma (in subgroup) mem_carrier [simp]:
   "x \<in> H \<Longrightarrow> x \<in> carrier(G)"
   using subset by blast
 
 
 lemma subgroup_imp_subset:
   "subgroup(H,G) \<Longrightarrow> H \<subseteq> carrier(G)"
   by (rule subgroup.subset)
 
 lemma (in subgroup) group_axiomsI [intro]:
   assumes "group(G)"
   shows "group_axioms (update_carrier(G,H))"
 proof -
   interpret group G by fact
   show ?thesis by (force intro: group_axioms.intro l_inv r_inv)
 qed
 
 lemma (in subgroup) is_group [intro]:
   assumes "group(G)"
   shows "group (update_carrier(G,H))"
 proof -
   interpret group G by fact
   show ?thesis
   by (rule groupI) (auto intro: m_assoc l_inv mem_carrier)
 qed
 
 text \<open>
   Since \<^term>\<open>H\<close> is nonempty, it contains some element \<^term>\<open>x\<close>.  Since
   it is closed under inverse, it contains \<open>inv x\<close>.  Since
   it is closed under product, it contains \<open>x \<cdot> inv x = \<one>\<close>.
 \<close>
 
 text \<open>
   Since \<^term>\<open>H\<close> is nonempty, it contains some element \<^term>\<open>x\<close>.  Since
   it is closed under inverse, it contains \<open>inv x\<close>.  Since
   it is closed under product, it contains \<open>x \<cdot> inv x = \<one>\<close>.
 \<close>
 
 lemma (in group) one_in_subset:
   "\<lbrakk>H \<subseteq> carrier(G); H \<noteq> 0; \<forall>a \<in> H. inv a \<in> H; \<forall>a\<in>H. \<forall>b\<in>H. a \<cdot> b \<in> H\<rbrakk>
    \<Longrightarrow> \<one> \<in> H"
 by (force simp add: l_inv)
 
 text \<open>A characterization of subgroups: closed, non-empty subset.\<close>
 
 declare monoid.one_closed [simp] group.inv_closed [simp]
   monoid.l_one [simp] monoid.r_one [simp] group.inv_inv [simp]
 
 lemma subgroup_nonempty:
   "\<not> subgroup(0,G)"
   by (blast dest: subgroup.one_closed)
 
 
 subsection \<open>Direct Products\<close>
 
 definition
   DirProdGroup :: "[i,i] \<Rightarrow> i"  (infixr \<open>\<Otimes>\<close> 80) where
   "G \<Otimes> H \<equiv> <carrier(G) \<times> carrier(H),
               (\<lambda><\<langle>g,h\<rangle>, <g', h'>>
                    \<in> (carrier(G) \<times> carrier(H)) \<times> (carrier(G) \<times> carrier(H)).
                 <g \<cdot>\<^bsub>G\<^esub> g', h \<cdot>\<^bsub>H\<^esub> h'>),
               <\<one>\<^bsub>G\<^esub>, \<one>\<^bsub>H\<^esub>>, 0>"
 
 lemma DirProdGroup_group:
   assumes "group(G)" and "group(H)"
   shows "group (G \<Otimes> H)"
 proof -
   interpret G: group G by fact
   interpret H: group H by fact
   show ?thesis by (force intro!: groupI G.m_assoc H.m_assoc G.l_inv H.l_inv
           simp add: DirProdGroup_def)
 qed
 
 lemma carrier_DirProdGroup [simp]:
      "carrier (G \<Otimes> H) = carrier(G) \<times> carrier(H)"
   by (simp add: DirProdGroup_def)
 
 lemma one_DirProdGroup [simp]:
      "\<one>\<^bsub>G \<Otimes> H\<^esub> = <\<one>\<^bsub>G\<^esub>, \<one>\<^bsub>H\<^esub>>"
   by (simp add: DirProdGroup_def)
 
 lemma mult_DirProdGroup [simp]:
      "\<lbrakk>g \<in> carrier(G); h \<in> carrier(H); g' \<in> carrier(G); h' \<in> carrier(H)\<rbrakk>
       \<Longrightarrow> \<langle>g, h\<rangle> \<cdot>\<^bsub>G \<Otimes> H\<^esub> <g', h'> = <g \<cdot>\<^bsub>G\<^esub> g', h \<cdot>\<^bsub>H\<^esub> h'>"
   by (simp add: DirProdGroup_def)
 
 lemma inv_DirProdGroup [simp]:
   assumes "group(G)" and "group(H)"
   assumes g: "g \<in> carrier(G)"
       and h: "h \<in> carrier(H)"
   shows "inv \<^bsub>G \<Otimes> H\<^esub> \<langle>g, h\<rangle> = <inv\<^bsub>G\<^esub> g, inv\<^bsub>H\<^esub> h>"
   apply (rule group.inv_equality [OF DirProdGroup_group])
   apply (simp_all add: assms group.l_inv)
   done
 
 subsection \<open>Isomorphisms\<close>
 
 definition
   hom :: "[i,i] \<Rightarrow> i" where
   "hom(G,H) \<equiv>
     {h \<in> carrier(G) -> carrier(H).
       (\<forall>x \<in> carrier(G). \<forall>y \<in> carrier(G). h ` (x \<cdot>\<^bsub>G\<^esub> y) = (h ` x) \<cdot>\<^bsub>H\<^esub> (h ` y))}"
 
 lemma hom_mult:
   "\<lbrakk>h \<in> hom(G,H); x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
    \<Longrightarrow> h ` (x \<cdot>\<^bsub>G\<^esub> y) = h ` x \<cdot>\<^bsub>H\<^esub> h ` y"
   by (simp add: hom_def)
 
 lemma hom_closed:
   "\<lbrakk>h \<in> hom(G,H); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> h ` x \<in> carrier(H)"
   by (auto simp add: hom_def)
 
 lemma (in group) hom_compose:
      "\<lbrakk>h \<in> hom(G,H); i \<in> hom(H,I)\<rbrakk> \<Longrightarrow> i O h \<in> hom(G,I)"
 by (force simp add: hom_def comp_fun)
 
 lemma hom_is_fun:
   "h \<in> hom(G,H) \<Longrightarrow> h \<in> carrier(G) -> carrier(H)"
   by (simp add: hom_def)
 
 
 subsection \<open>Isomorphisms\<close>
 
 definition
   iso :: "[i,i] \<Rightarrow> i"  (infixr \<open>\<cong>\<close> 60) where
   "G \<cong> H \<equiv> hom(G,H) \<inter> bij(carrier(G), carrier(H))"
 
 lemma (in group) iso_refl: "id(carrier(G)) \<in> G \<cong> G"
   by (simp add: iso_def hom_def id_type id_bij)
 
 
 lemma (in group) iso_sym:
      "h \<in> G \<cong> H \<Longrightarrow> converse(h) \<in> H \<cong> G"
 apply (simp add: iso_def bij_converse_bij, clarify)
 apply (subgoal_tac "converse(h) \<in> carrier(H) \<rightarrow> carrier(G)")
  prefer 2 apply (simp add: bij_converse_bij bij_is_fun)
 apply (auto intro: left_inverse_eq [of _ "carrier(G)" "carrier(H)"]
             simp add: hom_def bij_is_inj right_inverse_bij)
 done
 
 lemma (in group) iso_trans:
      "\<lbrakk>h \<in> G \<cong> H; i \<in> H \<cong> I\<rbrakk> \<Longrightarrow> i O h \<in> G \<cong> I"
   by (auto simp add: iso_def hom_compose comp_bij)
 
 lemma DirProdGroup_commute_iso:
   assumes "group(G)" and "group(H)"
   shows "(\<lambda>\<langle>x,y\<rangle> \<in> carrier(G \<Otimes> H). \<langle>y,x\<rangle>) \<in> (G \<Otimes> H) \<cong> (H \<Otimes> G)"
 proof -
   interpret group G by fact
   interpret group H by fact
   show ?thesis by (auto simp add: iso_def hom_def inj_def surj_def bij_def)
 qed
 
 lemma DirProdGroup_assoc_iso:
   assumes "group(G)" and "group(H)" and "group(I)"
   shows "(\<lambda><\<langle>x,y\<rangle>,z> \<in> carrier((G \<Otimes> H) \<Otimes> I). <x,\<langle>y,z\<rangle>>)
           \<in> ((G \<Otimes> H) \<Otimes> I) \<cong> (G \<Otimes> (H \<Otimes> I))"
 proof -
   interpret group G by fact
   interpret group H by fact
   interpret group I by fact
   show ?thesis
     by (auto intro: lam_type simp add: iso_def hom_def inj_def surj_def bij_def)
 qed
 
 text\<open>Basis for homomorphism proofs: we assume two groups \<^term>\<open>G\<close> and
   \<^term>\<open>H\<close>, with a homomorphism \<^term>\<open>h\<close> between them\<close>
 locale group_hom = G: group G + H: group H
   for G (structure) and H (structure) and h +
   assumes homh: "h \<in> hom(G,H)"
   notes hom_mult [simp] = hom_mult [OF homh]
     and hom_closed [simp] = hom_closed [OF homh]
     and hom_is_fun [simp] = hom_is_fun [OF homh]
 
 lemma (in group_hom) one_closed [simp]:
   "h ` \<one> \<in> carrier(H)"
   by simp
 
 lemma (in group_hom) hom_one [simp]:
   "h ` \<one> = \<one>\<^bsub>H\<^esub>"
 proof -
   have "h ` \<one> \<cdot>\<^bsub>H\<^esub> \<one>\<^bsub>H\<^esub> = (h ` \<one>) \<cdot>\<^bsub>H\<^esub> (h ` \<one>)"
     by (simp add: hom_mult [symmetric] del: hom_mult)
   then show ?thesis by (simp del: H.r_one)
 qed
 
 lemma (in group_hom) inv_closed [simp]:
   "x \<in> carrier(G) \<Longrightarrow> h ` (inv x) \<in> carrier(H)"
   by simp
 
 lemma (in group_hom) hom_inv [simp]:
   "x \<in> carrier(G) \<Longrightarrow> h ` (inv x) = inv\<^bsub>H\<^esub> (h ` x)"
 proof -
   assume x: "x \<in> carrier(G)"
   then have "h ` x \<cdot>\<^bsub>H\<^esub> h ` (inv x) = \<one>\<^bsub>H\<^esub>"
     by (simp add: hom_mult [symmetric] G.r_inv del: hom_mult)
   also from x have "... = h ` x \<cdot>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h ` x)"
     by (simp add: hom_mult [symmetric] H.r_inv del: hom_mult)
   finally have "h ` x \<cdot>\<^bsub>H\<^esub> h ` (inv x) = h ` x \<cdot>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h ` x)" .
   with x show ?thesis by (simp del: H.inv)
 qed
 
 subsection \<open>Commutative Structures\<close>
 
 text \<open>
   Naming convention: multiplicative structures that are commutative
   are called \emph{commutative}, additive structures are called
   \emph{Abelian}.
 \<close>
 
 subsection \<open>Definition\<close>
 
 locale comm_monoid = monoid +
   assumes m_comm: "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y = y \<cdot> x"
 
 lemma (in comm_monoid) m_lcomm:
   "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
    x \<cdot> (y \<cdot> z) = y \<cdot> (x \<cdot> z)"
 proof -
   assume xyz: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "z \<in> carrier(G)"
   from xyz have "x \<cdot> (y \<cdot> z) = (x \<cdot> y) \<cdot> z" by (simp add: m_assoc)
   also from xyz have "... = (y \<cdot> x) \<cdot> z" by (simp add: m_comm)
   also from xyz have "... = y \<cdot> (x \<cdot> z)" by (simp add: m_assoc)
   finally show ?thesis .
 qed
 
 lemmas (in comm_monoid) m_ac = m_assoc m_comm m_lcomm
 
 locale comm_group = comm_monoid + group
 
 lemma (in comm_group) inv_mult:
   "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv (x \<cdot> y) = inv x \<cdot> inv y"
   by (simp add: m_ac inv_mult_group)
 
 
 lemma (in group) subgroup_self: "subgroup (carrier(G),G)"
 by (simp add: subgroup_def)
 
 lemma (in group) subgroup_imp_group:
   "subgroup(H,G) \<Longrightarrow> group (update_carrier(G,H))"
 by (simp add: subgroup.is_group)
 
 lemma (in group) subgroupI:
   assumes subset: "H \<subseteq> carrier(G)" and non_empty: "H \<noteq> 0"
     and "\<And>a. a \<in> H \<Longrightarrow> inv a \<in> H"
     and "\<And>a b. \<lbrakk>a \<in> H; b \<in> H\<rbrakk> \<Longrightarrow> a \<cdot> b \<in> H"
   shows "subgroup(H,G)"
 proof (simp add: subgroup_def assms)
   show "\<one> \<in> H"
     by (rule one_in_subset) (auto simp only: assms)
 qed
 
 
 subsection \<open>Bijections of a Set, Permutation Groups, Automorphism Groups\<close>
 
 definition
   BijGroup :: "i\<Rightarrow>i" where
   "BijGroup(S) \<equiv>
     <bij(S,S),
      \<lambda>\<langle>g,f\<rangle> \<in> bij(S,S) \<times> bij(S,S). g O f,
      id(S), 0>"
 
 
 subsection \<open>Bijections Form a Group\<close>
 
 theorem group_BijGroup: "group(BijGroup(S))"
 apply (simp add: BijGroup_def)
 apply (rule groupI)
     apply (simp_all add: id_bij comp_bij comp_assoc)
  apply (simp add: id_bij bij_is_fun left_comp_id [of _ S S] fun_is_rel)
 apply (blast intro: left_comp_inverse bij_is_inj bij_converse_bij)
 done
 
 
 subsection\<open>Automorphisms Form a Group\<close>
 
 lemma Bij_Inv_mem: "\<lbrakk>f \<in> bij(S,S);  x \<in> S\<rbrakk> \<Longrightarrow> converse(f) ` x \<in> S"
 by (blast intro: apply_funtype bij_is_fun bij_converse_bij)
 
 lemma inv_BijGroup: "f \<in> bij(S,S) \<Longrightarrow> m_inv (BijGroup(S), f) = converse(f)"
 apply (rule group.inv_equality)
 apply (rule group_BijGroup)
 apply (simp_all add: BijGroup_def bij_converse_bij
           left_comp_inverse [OF bij_is_inj])
 done
 
 lemma iso_is_bij: "h \<in> G \<cong> H \<Longrightarrow> h \<in> bij(carrier(G), carrier(H))"
 by (simp add: iso_def)
 
 
 definition
   auto :: "i\<Rightarrow>i" where
   "auto(G) \<equiv> iso(G,G)"
 
 definition
   AutoGroup :: "i\<Rightarrow>i" where
   "AutoGroup(G) \<equiv> update_carrier(BijGroup(carrier(G)), auto(G))"
 
 
 lemma (in group) id_in_auto: "id(carrier(G)) \<in> auto(G)"
   by (simp add: iso_refl auto_def)
 
 lemma (in group) subgroup_auto:
       "subgroup (auto(G)) (BijGroup (carrier(G)))"
 proof (rule subgroup.intro)
   show "auto(G) \<subseteq> carrier (BijGroup (carrier(G)))"
     by (auto simp add: auto_def BijGroup_def iso_def)
 next
   fix x y
   assume "x \<in> auto(G)" "y \<in> auto(G)"
   thus "x \<cdot>\<^bsub>BijGroup (carrier(G))\<^esub> y \<in> auto(G)"
     by (auto simp add: BijGroup_def auto_def iso_def bij_is_fun
                        group.hom_compose comp_bij)
 next
   show "\<one>\<^bsub>BijGroup (carrier(G))\<^esub> \<in> auto(G)" by (simp add:  BijGroup_def id_in_auto)
 next
   fix x
   assume "x \<in> auto(G)"
   thus "inv\<^bsub>BijGroup (carrier(G))\<^esub> x \<in> auto(G)"
     by (simp add: auto_def inv_BijGroup iso_is_bij iso_sym)
 qed
 
 theorem (in group) AutoGroup: "group (AutoGroup(G))"
 by (simp add: AutoGroup_def subgroup.is_group subgroup_auto group_BijGroup)
 
 
 
 subsection\<open>Cosets and Quotient Groups\<close>
 
 definition
   r_coset  :: "[i,i,i] \<Rightarrow> i"  (infixl \<open>#>\<index>\<close> 60) where
   "H #>\<^bsub>G\<^esub> a \<equiv> \<Union>h\<in>H. {h \<cdot>\<^bsub>G\<^esub> a}"
 
 definition
   l_coset  :: "[i,i,i] \<Rightarrow> i"  (infixl \<open><#\<index>\<close> 60) where
   "a <#\<^bsub>G\<^esub> H \<equiv> \<Union>h\<in>H. {a \<cdot>\<^bsub>G\<^esub> h}"
 
 definition
   RCOSETS  :: "[i,i] \<Rightarrow> i"  (\<open>rcosets\<index> _\<close> [81] 80) where
   "rcosets\<^bsub>G\<^esub> H \<equiv> \<Union>a\<in>carrier(G). {H #>\<^bsub>G\<^esub> a}"
 
 definition
   set_mult :: "[i,i,i] \<Rightarrow> i"  (infixl \<open><#>\<index>\<close> 60) where
   "H <#>\<^bsub>G\<^esub> K \<equiv> \<Union>h\<in>H. \<Union>k\<in>K. {h \<cdot>\<^bsub>G\<^esub> k}"
 
 definition
   SET_INV  :: "[i,i] \<Rightarrow> i"  (\<open>set'_inv\<index> _\<close> [81] 80) where
   "set_inv\<^bsub>G\<^esub> H \<equiv> \<Union>h\<in>H. {inv\<^bsub>G\<^esub> h}"
 
 
 locale normal = subgroup + group +
   assumes coset_eq: "(\<forall>x \<in> carrier(G). H #> x = x <# H)"
 
 notation
   normal  (infixl \<open>\<lhd>\<close> 60)
 
 
 subsection \<open>Basic Properties of Cosets\<close>
 
 lemma (in group) coset_mult_assoc:
      "\<lbrakk>M \<subseteq> carrier(G); g \<in> carrier(G); h \<in> carrier(G)\<rbrakk>
       \<Longrightarrow> (M #> g) #> h = M #> (g \<cdot> h)"
 by (force simp add: r_coset_def m_assoc)
 
 lemma (in group) coset_mult_one [simp]: "M \<subseteq> carrier(G) \<Longrightarrow> M #> \<one> = M"
 by (force simp add: r_coset_def)
 
 lemma (in group) solve_equation:
     "\<lbrakk>subgroup(H,G); x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> \<exists>h\<in>H. y = h \<cdot> x"
 apply (rule bexI [of _ "y \<cdot> (inv x)"])
 apply (auto simp add: subgroup.m_closed subgroup.m_inv_closed m_assoc
                       subgroup.subset [THEN subsetD])
 done
 
 lemma (in group) repr_independence:
      "\<lbrakk>y \<in> H #> x;  x \<in> carrier(G); subgroup(H,G)\<rbrakk> \<Longrightarrow> H #> x = H #> y"
 by (auto simp add: r_coset_def m_assoc [symmetric]
                    subgroup.subset [THEN subsetD]
                    subgroup.m_closed solve_equation)
 
 lemma (in group) coset_join2:
      "\<lbrakk>x \<in> carrier(G);  subgroup(H,G);  x\<in>H\<rbrakk> \<Longrightarrow> H #> x = H"
   \<comment> \<open>Alternative proof is to put \<^term>\<open>x=\<one>\<close> in \<open>repr_independence\<close>.\<close>
 by (force simp add: subgroup.m_closed r_coset_def solve_equation)
 
 lemma (in group) r_coset_subset_G:
      "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> H #> x \<subseteq> carrier(G)"
 by (auto simp add: r_coset_def)
 
 lemma (in group) rcosI:
      "\<lbrakk>h \<in> H; H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> h \<cdot> x \<in> H #> x"
 by (auto simp add: r_coset_def)
 
 lemma (in group) rcosetsI:
      "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> H #> x \<in> rcosets H"
 by (auto simp add: RCOSETS_def)
 
 
 text\<open>Really needed?\<close>
 lemma (in group) transpose_inv:
      "\<lbrakk>x \<cdot> y = z;  x \<in> carrier(G);  y \<in> carrier(G);  z \<in> carrier(G)\<rbrakk>
       \<Longrightarrow> (inv x) \<cdot> z = y"
 by (force simp add: m_assoc [symmetric])
 
 
 
 subsection \<open>Normal subgroups\<close>
 
 lemma normal_imp_subgroup: "H \<lhd> G \<Longrightarrow> subgroup(H,G)"
   by (simp add: normal_def subgroup_def)
 
 lemma (in group) normalI:
   "subgroup(H,G) \<Longrightarrow> (\<forall>x \<in> carrier(G). H #> x = x <# H) \<Longrightarrow> H \<lhd> G"
   by (simp add: normal_def normal_axioms_def)
 
 lemma (in normal) inv_op_closed1:
      "\<lbrakk>x \<in> carrier(G); h \<in> H\<rbrakk> \<Longrightarrow> (inv x) \<cdot> h \<cdot> x \<in> H"
 apply (insert coset_eq)
 apply (auto simp add: l_coset_def r_coset_def)
 apply (drule bspec, assumption)
 apply (drule equalityD1 [THEN subsetD], blast, clarify)
 apply (simp add: m_assoc)
 apply (simp add: m_assoc [symmetric])
 done
 
 lemma (in normal) inv_op_closed2:
      "\<lbrakk>x \<in> carrier(G); h \<in> H\<rbrakk> \<Longrightarrow> x \<cdot> h \<cdot> (inv x) \<in> H"
 apply (subgoal_tac "inv (inv x) \<cdot> h \<cdot> (inv x) \<in> H")
 apply simp
 apply (blast intro: inv_op_closed1)
 done
 
 text\<open>Alternative characterization of normal subgroups\<close>
 lemma (in group) normal_inv_iff:
      "(N \<lhd> G) \<longleftrightarrow>
       (subgroup(N,G) \<and> (\<forall>x \<in> carrier(G). \<forall>h \<in> N. x \<cdot> h \<cdot> (inv x) \<in> N))"
       (is "_ \<longleftrightarrow> ?rhs")
 proof
   assume N: "N \<lhd> G"
   show ?rhs
     by (blast intro: N normal.inv_op_closed2 normal_imp_subgroup)
 next
   assume ?rhs
   hence sg: "subgroup(N,G)"
     and closed: "\<And>x. x\<in>carrier(G) \<Longrightarrow> \<forall>h\<in>N. x \<cdot> h \<cdot> inv x \<in> N" by auto
   hence sb: "N \<subseteq> carrier(G)" by (simp add: subgroup.subset)
   show "N \<lhd> G"
   proof (intro normalI [OF sg], simp add: l_coset_def r_coset_def, clarify)
     fix x
     assume x: "x \<in> carrier(G)"
     show "(\<Union>h\<in>N. {h \<cdot> x}) = (\<Union>h\<in>N. {x \<cdot> h})"
     proof
       show "(\<Union>h\<in>N. {h \<cdot> x}) \<subseteq> (\<Union>h\<in>N. {x \<cdot> h})"
       proof clarify
         fix n
         assume n: "n \<in> N"
         show "n \<cdot> x \<in> (\<Union>h\<in>N. {x \<cdot> h})"
         proof (rule UN_I)
           from closed [of "inv x"]
           show "inv x \<cdot> n \<cdot> x \<in> N" by (simp add: x n)
           show "n \<cdot> x \<in> {x \<cdot> (inv x \<cdot> n \<cdot> x)}"
             by (simp add: x n m_assoc [symmetric] sb [THEN subsetD])
         qed
       qed
     next
       show "(\<Union>h\<in>N. {x \<cdot> h}) \<subseteq> (\<Union>h\<in>N. {h \<cdot> x})"
       proof clarify
         fix n
         assume n: "n \<in> N"
         show "x \<cdot> n \<in> (\<Union>h\<in>N. {h \<cdot> x})"
         proof (rule UN_I)
           show "x \<cdot> n \<cdot> inv x \<in> N" by (simp add: x n closed)
           show "x \<cdot> n \<in> {x \<cdot> n \<cdot> inv x \<cdot> x}"
             by (simp add: x n m_assoc sb [THEN subsetD])
         qed
       qed
     qed
   qed
 qed
 
 
 subsection\<open>More Properties of Cosets\<close>
 
 lemma (in group) l_coset_subset_G:
      "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> x <# H \<subseteq> carrier(G)"
 by (auto simp add: l_coset_def subsetD)
 
 lemma (in group) l_coset_swap:
      "\<lbrakk>y \<in> x <# H;  x \<in> carrier(G);  subgroup(H,G)\<rbrakk> \<Longrightarrow> x \<in> y <# H"
 proof (simp add: l_coset_def)
   assume "\<exists>h\<in>H. y = x \<cdot> h"
     and x: "x \<in> carrier(G)"
     and sb: "subgroup(H,G)"
   then obtain h' where h': "h' \<in> H \<and> x \<cdot> h' = y" by blast
   show "\<exists>h\<in>H. x = y \<cdot> h"
   proof
     show "x = y \<cdot> inv h'" using h' x sb
       by (auto simp add: m_assoc subgroup.subset [THEN subsetD])
     show "inv h' \<in> H" using h' sb
       by (auto simp add: subgroup.subset [THEN subsetD] subgroup.m_inv_closed)
   qed
 qed
 
 lemma (in group) l_coset_carrier:
      "\<lbrakk>y \<in> x <# H;  x \<in> carrier(G);  subgroup(H,G)\<rbrakk> \<Longrightarrow> y \<in> carrier(G)"
 by (auto simp add: l_coset_def m_assoc
                    subgroup.subset [THEN subsetD] subgroup.m_closed)
 
 lemma (in group) l_repr_imp_subset:
   assumes y: "y \<in> x <# H" and x: "x \<in> carrier(G)" and sb: "subgroup(H,G)"
   shows "y <# H \<subseteq> x <# H"
 proof -
   from y
   obtain h' where "h' \<in> H" "x \<cdot> h' = y" by (auto simp add: l_coset_def)
   thus ?thesis using x sb
     by (auto simp add: l_coset_def m_assoc
                        subgroup.subset [THEN subsetD] subgroup.m_closed)
 qed
 
 lemma (in group) l_repr_independence:
   assumes y: "y \<in> x <# H" and x: "x \<in> carrier(G)" and sb: "subgroup(H,G)"
   shows "x <# H = y <# H"
 proof
   show "x <# H \<subseteq> y <# H"
     by (rule l_repr_imp_subset,
         (blast intro: l_coset_swap l_coset_carrier y x sb)+)
   show "y <# H \<subseteq> x <# H" by (rule l_repr_imp_subset [OF y x sb])
 qed
 
 lemma (in group) setmult_subset_G:
      "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G)\<rbrakk> \<Longrightarrow> H <#> K \<subseteq> carrier(G)"
 by (auto simp add: set_mult_def subsetD)
 
 lemma (in group) subgroup_mult_id: "subgroup(H,G) \<Longrightarrow> H <#> H = H"
 apply (rule equalityI)
 apply (auto simp add: subgroup.m_closed set_mult_def Sigma_def image_def)
 apply (rule_tac x = x in bexI)
 apply (rule bexI [of _ "\<one>"])
 apply (auto simp add: subgroup.one_closed subgroup.subset [THEN subsetD])
 done
 
 
 subsubsection \<open>Set of inverses of an \<open>r_coset\<close>.\<close>
 
 lemma (in normal) rcos_inv:
   assumes x:     "x \<in> carrier(G)"
   shows "set_inv (H #> x) = H #> (inv x)"
 proof (simp add: r_coset_def SET_INV_def x inv_mult_group, safe intro!: equalityI)
   fix h
   assume h: "h \<in> H"
   {
     show "inv x \<cdot> inv h \<in> (\<Union>j\<in>H. {j \<cdot> inv x})"
     proof (rule UN_I)
       show "inv x \<cdot> inv h \<cdot> x \<in> H"
         by (simp add: inv_op_closed1 h x)
       show "inv x \<cdot> inv h \<in> {inv x \<cdot> inv h \<cdot> x \<cdot> inv x}"
         by (simp add: h x m_assoc)
     qed
   next
     show "h \<cdot> inv x \<in> (\<Union>j\<in>H. {inv x \<cdot> inv j})"
     proof (rule UN_I)
       show "x \<cdot> inv h \<cdot> inv x \<in> H"
         by (simp add: inv_op_closed2 h x)
       show "h \<cdot> inv x \<in> {inv x \<cdot> inv (x \<cdot> inv h \<cdot> inv x)}"
         by (simp add: h x m_assoc [symmetric] inv_mult_group)
     qed
   }
 qed
 
 
 
 subsubsection \<open>Theorems for \<open><#>\<close> with \<open>#>\<close> or \<open><#\<close>.\<close>
 
 lemma (in group) setmult_rcos_assoc:
      "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk>
       \<Longrightarrow> H <#> (K #> x) = (H <#> K) #> x"
 by (force simp add: r_coset_def set_mult_def m_assoc)
 
 lemma (in group) rcos_assoc_lcos:
      "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk>
       \<Longrightarrow> (H #> x) <#> K = H <#> (x <# K)"
 by (force simp add: r_coset_def l_coset_def set_mult_def m_assoc)
 
 lemma (in normal) rcos_mult_step1:
      "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
       \<Longrightarrow> (H #> x) <#> (H #> y) = (H <#> (x <# H)) #> y"
 by (simp add: setmult_rcos_assoc subset
               r_coset_subset_G l_coset_subset_G rcos_assoc_lcos)
 
 lemma (in normal) rcos_mult_step2:
      "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
       \<Longrightarrow> (H <#> (x <# H)) #> y = (H <#> (H #> x)) #> y"
 by (insert coset_eq, simp add: normal_def)
 
 lemma (in normal) rcos_mult_step3:
      "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
       \<Longrightarrow> (H <#> (H #> x)) #> y = H #> (x \<cdot> y)"
   by (simp add: setmult_rcos_assoc coset_mult_assoc
               subgroup_mult_id subset normal_axioms normal.axioms)
 
 lemma (in normal) rcos_sum:
      "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
       \<Longrightarrow> (H #> x) <#> (H #> y) = H #> (x \<cdot> y)"
 by (simp add: rcos_mult_step1 rcos_mult_step2 rcos_mult_step3)
 
 lemma (in normal) rcosets_mult_eq: "M \<in> rcosets H \<Longrightarrow> H <#> M = M"
   \<comment> \<open>generalizes \<open>subgroup_mult_id\<close>\<close>
   by (auto simp add: RCOSETS_def subset
         setmult_rcos_assoc subgroup_mult_id normal_axioms normal.axioms)
 
 
 subsubsection\<open>Two distinct right cosets are disjoint\<close>
 
 definition
   r_congruent :: "[i,i] \<Rightarrow> i" (\<open>rcong\<index> _\<close> [60] 60) where
   "rcong\<^bsub>G\<^esub> H \<equiv> {\<langle>x,y\<rangle> \<in> carrier(G) * carrier(G). inv\<^bsub>G\<^esub> x \<cdot>\<^bsub>G\<^esub> y \<in> H}"
 
 
 lemma (in subgroup) equiv_rcong:
    assumes "group(G)"
    shows "equiv (carrier(G), rcong H)"
 proof -
   interpret group G by fact
   show ?thesis proof (simp add: equiv_def, intro conjI)
     show "rcong H \<subseteq> carrier(G) \<times> carrier(G)"
       by (auto simp add: r_congruent_def)
   next
     show "refl (carrier(G), rcong H)"
       by (auto simp add: r_congruent_def refl_def)
   next
     show "sym (rcong H)"
     proof (simp add: r_congruent_def sym_def, clarify)
       fix x y
       assume [simp]: "x \<in> carrier(G)" "y \<in> carrier(G)"
         and "inv x \<cdot> y \<in> H"
       hence "inv (inv x \<cdot> y) \<in> H" by simp
       thus "inv y \<cdot> x \<in> H" by (simp add: inv_mult_group)
     qed
   next
     show "trans (rcong H)"
     proof (simp add: r_congruent_def trans_def, clarify)
       fix x y z
       assume [simp]: "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
         and "inv x \<cdot> y \<in> H" and "inv y \<cdot> z \<in> H"
       hence "(inv x \<cdot> y) \<cdot> (inv y \<cdot> z) \<in> H" by simp
       hence "inv x \<cdot> (y \<cdot> inv y) \<cdot> z \<in> H" by (simp add: m_assoc del: inv)
       thus "inv x \<cdot> z \<in> H" by simp
     qed
   qed
 qed
 
 text\<open>Equivalence classes of \<open>rcong\<close> correspond to left cosets.
   Was there a mistake in the definitions? I'd have expected them to
   correspond to right cosets.\<close>
 lemma (in subgroup) l_coset_eq_rcong:
   assumes "group(G)"
   assumes a: "a \<in> carrier(G)"
   shows "a <# H = (rcong H) `` {a}"
 proof -
   interpret group G by fact
   show ?thesis
     by (force simp add: r_congruent_def l_coset_def m_assoc [symmetric] a
       Collect_image_eq)
 qed
 
 lemma (in group) rcos_equation:
   assumes "subgroup(H, G)"
   shows
      "\<lbrakk>ha \<cdot> a = h \<cdot> b; a \<in> carrier(G);  b \<in> carrier(G);
         h \<in> H;  ha \<in> H;  hb \<in> H\<rbrakk>
       \<Longrightarrow> hb \<cdot> a \<in> (\<Union>h\<in>H. {h \<cdot> b})" (is "PROP ?P")
 proof -
   interpret subgroup H G by fact
   show "PROP ?P"
     apply (rule UN_I [of "hb \<cdot> ((inv ha) \<cdot> h)"], simp)
     apply (simp add: m_assoc transpose_inv)
     done
 qed
 
 lemma (in group) rcos_disjoint:
   assumes "subgroup(H, G)"
   shows "\<lbrakk>a \<in> rcosets H; b \<in> rcosets H; a\<noteq>b\<rbrakk> \<Longrightarrow> a \<inter> b = 0" (is "PROP ?P")
 proof -
   interpret subgroup H G by fact
   show "PROP ?P"
     apply (simp add: RCOSETS_def r_coset_def)
     apply (blast intro: rcos_equation assms sym)
     done
 qed
 
 
 subsection \<open>Order of a Group and Lagrange's Theorem\<close>
 
 definition
   order :: "i \<Rightarrow> i" where
   "order(S) \<equiv> |carrier(S)|"
 
 lemma (in group) rcos_self:
   assumes "subgroup(H, G)"
   shows "x \<in> carrier(G) \<Longrightarrow> x \<in> H #> x" (is "PROP ?P")
 proof -
   interpret subgroup H G by fact
   show "PROP ?P"
     apply (simp add: r_coset_def)
     apply (rule_tac x="\<one>" in bexI) apply (auto)
     done
 qed
 
 lemma (in group) rcosets_part_G:
   assumes "subgroup(H, G)"
   shows "\<Union>(rcosets H) = carrier(G)"
 proof -
   interpret subgroup H G by fact
   show ?thesis
     apply (rule equalityI)
     apply (force simp add: RCOSETS_def r_coset_def)
     apply (auto simp add: RCOSETS_def intro: rcos_self assms)
     done
 qed
 
 lemma (in group) cosets_finite:
      "\<lbrakk>c \<in> rcosets H;  H \<subseteq> carrier(G);  Finite (carrier(G))\<rbrakk> \<Longrightarrow> Finite(c)"
 apply (auto simp add: RCOSETS_def)
 apply (simp add: r_coset_subset_G [THEN subset_Finite])
 done
 
 text\<open>More general than the HOL version, which also requires \<^term>\<open>G\<close> to
       be finite.\<close>
 lemma (in group) card_cosets_equal:
   assumes H:   "H \<subseteq> carrier(G)"
   shows "c \<in> rcosets H \<Longrightarrow> |c| = |H|"
 proof (simp add: RCOSETS_def, clarify)
   fix a
   assume a: "a \<in> carrier(G)"
   show "|H #> a| = |H|"
   proof (rule eqpollI [THEN cardinal_cong])
     show "H #> a \<lesssim> H"
     proof (simp add: lepoll_def, intro exI)
       show "(\<lambda>y \<in> H#>a. y \<cdot> inv a) \<in> inj(H #> a, H)"
         by (auto intro: lam_type
                  simp add: inj_def r_coset_def m_assoc subsetD [OF H] a)
     qed
     show "H \<lesssim> H #> a"
     proof (simp add: lepoll_def, intro exI)
       show "(\<lambda>y\<in> H. y \<cdot> a) \<in> inj(H, H #> a)"
         by (auto intro: lam_type
                  simp add: inj_def r_coset_def  subsetD [OF H] a)
     qed
   qed
 qed
 
 
 lemma (in group) rcosets_subset_PowG:
      "subgroup(H,G) \<Longrightarrow> rcosets H \<subseteq> Pow(carrier(G))"
 apply (simp add: RCOSETS_def)
 apply (blast dest: r_coset_subset_G subgroup.subset)
 done
 
 theorem (in group) lagrange:
      "\<lbrakk>Finite(carrier(G)); subgroup(H,G)\<rbrakk>
       \<Longrightarrow> |rcosets H| #* |H| = order(G)"
 apply (simp (no_asm_simp) add: order_def rcosets_part_G [symmetric])
 apply (subst mult_commute)
 apply (rule card_partition)
    apply (simp add: rcosets_subset_PowG [THEN subset_Finite])
   apply (simp add: rcosets_part_G)
  apply (simp add: card_cosets_equal [OF subgroup.subset])
 apply (simp add: rcos_disjoint)
 done
 
 
 subsection \<open>Quotient Groups: Factorization of a Group\<close>
 
 definition
   FactGroup :: "[i,i] \<Rightarrow> i" (infixl \<open>Mod\<close> 65) where
     \<comment> \<open>Actually defined for groups rather than monoids\<close>
   "G Mod H \<equiv>
      <rcosets\<^bsub>G\<^esub> H, \<lambda>\<langle>K1,K2\<rangle> \<in> (rcosets\<^bsub>G\<^esub> H) \<times> (rcosets\<^bsub>G\<^esub> H). K1 <#>\<^bsub>G\<^esub> K2, H, 0>"
 
 lemma (in normal) setmult_closed:
      "\<lbrakk>K1 \<in> rcosets H; K2 \<in> rcosets H\<rbrakk> \<Longrightarrow> K1 <#> K2 \<in> rcosets H"
 by (auto simp add: rcos_sum RCOSETS_def)
 
 lemma (in normal) setinv_closed:
      "K \<in> rcosets H \<Longrightarrow> set_inv K \<in> rcosets H"
 by (auto simp add: rcos_inv RCOSETS_def)
 
 lemma (in normal) rcosets_assoc:
      "\<lbrakk>M1 \<in> rcosets H; M2 \<in> rcosets H; M3 \<in> rcosets H\<rbrakk>
       \<Longrightarrow> M1 <#> M2 <#> M3 = M1 <#> (M2 <#> M3)"
 by (auto simp add: RCOSETS_def rcos_sum m_assoc)
 
 lemma (in subgroup) subgroup_in_rcosets:
   assumes "group(G)"
   shows "H \<in> rcosets H"
 proof -
   interpret group G by fact
   have "H #> \<one> = H"
     using _ subgroup_axioms by (rule coset_join2) simp_all
   then show ?thesis
     by (auto simp add: RCOSETS_def intro: sym)
 qed
 
 lemma (in normal) rcosets_inv_mult_group_eq:
      "M \<in> rcosets H \<Longrightarrow> set_inv M <#> M = H"
 by (auto simp add: RCOSETS_def rcos_inv rcos_sum subgroup.subset normal_axioms normal.axioms)
 
 theorem (in normal) factorgroup_is_group:
   "group (G Mod H)"
 apply (simp add: FactGroup_def)
 apply (rule groupI)
     apply (simp add: setmult_closed)
    apply (simp add: normal_imp_subgroup subgroup_in_rcosets)
   apply (simp add: setmult_closed rcosets_assoc)
  apply (simp add: normal_imp_subgroup
                   subgroup_in_rcosets rcosets_mult_eq)
 apply (auto dest: rcosets_inv_mult_group_eq simp add: setinv_closed)
 done
 
 lemma (in normal) inv_FactGroup:
      "X \<in> carrier (G Mod H) \<Longrightarrow> inv\<^bsub>G Mod H\<^esub> X = set_inv X"
 apply (rule group.inv_equality [OF factorgroup_is_group])
 apply (simp_all add: FactGroup_def setinv_closed rcosets_inv_mult_group_eq)
 done
 
 text\<open>The coset map is a homomorphism from \<^term>\<open>G\<close> to the quotient group
   \<^term>\<open>G Mod H\<close>\<close>
 lemma (in normal) r_coset_hom_Mod:
   "(\<lambda>a \<in> carrier(G). H #> a) \<in> hom(G, G Mod H)"
 by (auto simp add: FactGroup_def RCOSETS_def hom_def rcos_sum intro: lam_type)
 
 
 subsection\<open>The First Isomorphism Theorem\<close>
 
 text\<open>The quotient by the kernel of a homomorphism is isomorphic to the
   range of that homomorphism.\<close>
 
 definition
   kernel :: "[i,i,i] \<Rightarrow> i" where
     \<comment> \<open>the kernel of a homomorphism\<close>
   "kernel(G,H,h) \<equiv> {x \<in> carrier(G). h ` x = \<one>\<^bsub>H\<^esub>}"
 
 lemma (in group_hom) subgroup_kernel: "subgroup (kernel(G,H,h), G)"
 apply (rule subgroup.intro)
 apply (auto simp add: kernel_def group.intro)
 done
 
 text\<open>The kernel of a homomorphism is a normal subgroup\<close>
 lemma (in group_hom) normal_kernel: "(kernel(G,H,h)) \<lhd> G"
 apply (simp add: group.normal_inv_iff subgroup_kernel group.intro)
 apply (simp add: kernel_def)
 done
 
 lemma (in group_hom) FactGroup_nonempty:
   assumes X: "X \<in> carrier (G Mod kernel(G,H,h))"
   shows "X \<noteq> 0"
 proof -
   from X
   obtain g where "g \<in> carrier(G)"
              and "X = kernel(G,H,h) #> g"
     by (auto simp add: FactGroup_def RCOSETS_def)
   thus ?thesis
    by (auto simp add: kernel_def r_coset_def image_def intro: hom_one)
 qed
 
 
 lemma (in group_hom) FactGroup_contents_mem:
   assumes X: "X \<in> carrier (G Mod (kernel(G,H,h)))"
   shows "contents (h``X) \<in> carrier(H)"
 proof -
   from X
   obtain g where g: "g \<in> carrier(G)"
              and "X = kernel(G,H,h) #> g"
     by (auto simp add: FactGroup_def RCOSETS_def)
   hence "h `` X = {h ` g}"
     by (auto simp add: kernel_def r_coset_def image_UN
                        image_eq_UN [OF hom_is_fun] g)
   thus ?thesis by (auto simp add: g)
 qed
 
 lemma mult_FactGroup:
      "\<lbrakk>X \<in> carrier(G Mod H); X' \<in> carrier(G Mod H)\<rbrakk>
       \<Longrightarrow> X \<cdot>\<^bsub>(G Mod H)\<^esub> X' = X <#>\<^bsub>G\<^esub> X'"
 by (simp add: FactGroup_def)
 
 lemma (in normal) FactGroup_m_closed:
      "\<lbrakk>X \<in> carrier(G Mod H); X' \<in> carrier(G Mod H)\<rbrakk>
       \<Longrightarrow> X <#>\<^bsub>G\<^esub> X' \<in> carrier(G Mod H)"
 by (simp add: FactGroup_def setmult_closed)
 
 lemma (in group_hom) FactGroup_hom:
      "(\<lambda>X \<in> carrier(G Mod (kernel(G,H,h))). contents (h``X))
       \<in> hom (G Mod (kernel(G,H,h)), H)"
 proof (simp add: hom_def FactGroup_contents_mem lam_type mult_FactGroup normal.FactGroup_m_closed [OF normal_kernel], intro ballI)
   fix X and X'
   assume X:  "X  \<in> carrier (G Mod kernel(G,H,h))"
      and X': "X' \<in> carrier (G Mod kernel(G,H,h))"
   then
   obtain g and g'
            where "g \<in> carrier(G)" and "g' \<in> carrier(G)"
              and "X = kernel(G,H,h) #> g" and "X' = kernel(G,H,h) #> g'"
     by (auto simp add: FactGroup_def RCOSETS_def)
   hence all: "\<forall>x\<in>X. h ` x = h ` g" "\<forall>x\<in>X'. h ` x = h ` g'"
     and Xsub: "X \<subseteq> carrier(G)" and X'sub: "X' \<subseteq> carrier(G)"
     by (force simp add: kernel_def r_coset_def image_def)+
   hence "h `` (X <#> X') = {h ` g \<cdot>\<^bsub>H\<^esub> h ` g'}" using X X'
     by (auto dest!: FactGroup_nonempty
              simp add: set_mult_def image_eq_UN [OF hom_is_fun] image_UN
                        subsetD [OF Xsub] subsetD [OF X'sub])
   thus "contents (h `` (X <#> X')) = contents (h `` X) \<cdot>\<^bsub>H\<^esub> contents (h `` X')"
     by (simp add: all image_eq_UN [OF hom_is_fun] FactGroup_nonempty
                   X X' Xsub X'sub)
 qed
 
 
 text\<open>Lemma for the following injectivity result\<close>
 lemma (in group_hom) FactGroup_subset:
      "\<lbrakk>g \<in> carrier(G); g' \<in> carrier(G); h ` g = h ` g'\<rbrakk>
       \<Longrightarrow>  kernel(G,H,h) #> g \<subseteq> kernel(G,H,h) #> g'"
 apply (clarsimp simp add: kernel_def r_coset_def image_def)
 apply (rename_tac y)
 apply (rule_tac x="y \<cdot> g \<cdot> inv g'" in bexI)
 apply (simp_all add: G.m_assoc)
 done
 
 lemma (in group_hom) FactGroup_inj:
      "(\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h `` X))
       \<in> inj(carrier (G Mod kernel(G,H,h)), carrier(H))"
 proof (simp add: inj_def FactGroup_contents_mem lam_type, clarify)
   fix X and X'
   assume X:  "X  \<in> carrier (G Mod kernel(G,H,h))"
      and X': "X' \<in> carrier (G Mod kernel(G,H,h))"
   then
   obtain g and g'
            where gX: "g \<in> carrier(G)"  "g' \<in> carrier(G)"
               "X = kernel(G,H,h) #> g" "X' = kernel(G,H,h) #> g'"
     by (auto simp add: FactGroup_def RCOSETS_def)
   hence all: "\<forall>x\<in>X. h ` x = h ` g" "\<forall>x\<in>X'. h ` x = h ` g'"
     and Xsub: "X \<subseteq> carrier(G)" and X'sub: "X' \<subseteq> carrier(G)"
     by (force simp add: kernel_def r_coset_def image_def)+
   assume "contents (h `` X) = contents (h `` X')"
   hence h: "h ` g = h ` g'"
     by (simp add: all image_eq_UN [OF hom_is_fun] FactGroup_nonempty
                   X X' Xsub X'sub)
   show "X=X'" by (rule equalityI) (simp_all add: FactGroup_subset h gX)
 qed
 
 
 lemma (in group_hom) kernel_rcoset_subset:
   assumes g: "g \<in> carrier(G)"
   shows "kernel(G,H,h) #> g \<subseteq> carrier (G)"
     by (auto simp add: g kernel_def r_coset_def)
 
 
 
 text\<open>If the homomorphism \<^term>\<open>h\<close> is onto \<^term>\<open>H\<close>, then so is the
 homomorphism from the quotient group\<close>
 lemma (in group_hom) FactGroup_surj:
   assumes h: "h \<in> surj(carrier(G), carrier(H))"
   shows "(\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h `` X))
          \<in> surj(carrier (G Mod kernel(G,H,h)), carrier(H))"
 proof (simp add: surj_def FactGroup_contents_mem lam_type, clarify)
   fix y
   assume y: "y \<in> carrier(H)"
   with h obtain g where g: "g \<in> carrier(G)" "h ` g = y"
     by (auto simp add: surj_def)
   hence "(\<Union>x\<in>kernel(G,H,h) #> g. {h ` x}) = {y}"
     by (auto simp add: y kernel_def r_coset_def)
   with g show "\<exists>x\<in>carrier(G Mod kernel(G, H, h)). contents(h `` x) = y"
         \<comment> \<open>The witness is \<^term>\<open>kernel(G,H,h) #> g\<close>\<close>
     by (force simp add: FactGroup_def RCOSETS_def
            image_eq_UN [OF hom_is_fun] kernel_rcoset_subset)
 qed
 
 
 text\<open>If \<^term>\<open>h\<close> is a homomorphism from \<^term>\<open>G\<close> onto \<^term>\<open>H\<close>, then the
  quotient group \<^term>\<open>G Mod (kernel(G,H,h))\<close> is isomorphic to \<^term>\<open>H\<close>.\<close>
 theorem (in group_hom) FactGroup_iso:
   "h \<in> surj(carrier(G), carrier(H))
    \<Longrightarrow> (\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h``X)) \<in> (G Mod (kernel(G,H,h))) \<cong> H"
 by (simp add: iso_def FactGroup_hom FactGroup_inj bij_def FactGroup_surj)
 
 end
diff --git a/src/ZF/ex/LList.thy b/src/ZF/ex/LList.thy
--- a/src/ZF/ex/LList.thy
+++ b/src/ZF/ex/LList.thy
@@ -1,262 +1,262 @@
 (*  Title:      ZF/ex/LList.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1994  University of Cambridge
 
 Codatatype definition of Lazy Lists.
 
 Equality for llist(A) as a greatest fixed point
 
 Functions for Lazy Lists
 
 STILL NEEDS:
 co_recursion for defining lconst, flip, etc.
 a typing rule for it, based on some notion of "productivity..."
 *)
 
 theory LList imports ZF begin
 
 consts
   llist  :: "i\<Rightarrow>i"
 
 codatatype
   "llist(A)" = LNil | LCons ("a \<in> A", "l \<in> llist(A)")
 
 
 (*Coinductive definition of equality*)
 consts
   lleq :: "i\<Rightarrow>i"
 
 (*Previously used <*> in the domain and variant pairs as elements.  But
   standard pairs work just as well.  To use variant pairs, must change prefix
   a q/Q to the Sigma, Pair and converse rules.*)
 coinductive
   domains "lleq(A)" \<subseteq> "llist(A) * llist(A)"
   intros
     LNil:  "\<langle>LNil, LNil\<rangle> \<in> lleq(A)"
     LCons: "\<lbrakk>a \<in> A; <l,l'> \<in> lleq(A)\<rbrakk> 
             \<Longrightarrow> <LCons(a,l), LCons(a,l')> \<in> lleq(A)"
   type_intros  llist.intros
 
 
 (*Lazy list functions; flip is not definitional!*)
 definition
   lconst   :: "i \<Rightarrow> i"  where
   "lconst(a) \<equiv> lfp(univ(a), \<lambda>l. LCons(a,l))"
 
 axiomatization flip :: "i \<Rightarrow> i"
 where
   flip_LNil:   "flip(LNil) = LNil" and
   flip_LCons:  "\<lbrakk>x \<in> bool; l \<in> llist(bool)\<rbrakk> 
                 \<Longrightarrow> flip(LCons(x,l)) = LCons(not(x), flip(l))"
 
 
 (*These commands cause classical reasoning to regard the subset relation
   as primitive, not reducing it to membership*)
   
 declare subsetI [rule del]
         subsetCE [rule del]
 
 declare subset_refl [intro!] 
         cons_subsetI [intro!] 
         subset_consI [intro!]
         Union_least [intro!]
         UN_least [intro!]
         Un_least [intro!]
         Inter_greatest [intro!]
         Int_greatest [intro!]
         RepFun_subset [intro!]
         Un_upper1 [intro!]
         Un_upper2 [intro!]
         Int_lower1 [intro!]
         Int_lower2 [intro!]
 
 (*An elimination rule, for type-checking*)
 inductive_cases LConsE: "LCons(a,l) \<in> llist(A)"
 
 (*Proving freeness results*)
 lemma LCons_iff: "LCons(a,l)=LCons(a',l') \<longleftrightarrow> a=a' \<and> l=l'"
 by auto
 
 lemma LNil_LCons_iff: "\<not> LNil=LCons(a,l)"
 by auto
 
 (*
 lemma llist_unfold: "llist(A) = {0} <+> (A <*> llist(A))";
 let open llist  val rew = rewrite_rule con_defs in  
 by (fast_tac (claset() addSIs (subsetI ::map rew intros) addEs [rew elim]) 1)
 end
 done
 *)
 
 (*** Lemmas to justify using "llist" in other recursive type definitions ***)
 
 lemma llist_mono: "A \<subseteq> B \<Longrightarrow> llist(A) \<subseteq> llist(B)"
-apply (unfold llist.defs )
+  unfolding llist.defs 
 apply (rule gfp_mono)
 apply (rule llist.bnd_mono)
 apply (assumption | rule quniv_mono basic_monos)+
 done
 
 (** Closure of quniv(A) under llist -- why so complex?  Its a gfp... **)
 
 declare QPair_Int_Vset_subset_UN [THEN subset_trans, intro!]
         QPair_subset_univ [intro!]
         empty_subsetI [intro!]
         one_in_quniv [THEN qunivD, intro!]
 declare qunivD [dest!]
 declare Ord_in_Ord [elim!]
 
 lemma llist_quniv_lemma:
      "Ord(i) \<Longrightarrow> l \<in> llist(quniv(A)) \<Longrightarrow> l \<inter> Vset(i) \<subseteq> univ(eclose(A))"
 proof (induct i arbitrary: l rule: trans_induct)
   case (step i l)
   show ?case using \<open>l \<in> llist(quniv(A))\<close>
   proof (cases l rule: llist.cases)
     case LNil thus ?thesis
       by (simp add: QInl_def QInr_def llist.con_defs)
   next
     case (LCons a l) thus ?thesis using step.hyps
     proof (simp add: QInl_def QInr_def llist.con_defs)
       show "<1; <a; l>> \<inter> Vset(i) \<subseteq> univ(eclose(A))" using LCons \<open>Ord(i)\<close>
         by (fast intro: step Ord_trans Int_lower1 [THEN subset_trans])
     qed
   qed
 qed
 
 lemma llist_quniv: "llist(quniv(A)) \<subseteq> quniv(A)"
 apply (rule qunivI [THEN subsetI])
 apply (rule Int_Vset_subset)
 apply (assumption | rule llist_quniv_lemma)+
 done
 
 lemmas llist_subset_quniv =
        subset_trans [OF llist_mono llist_quniv]
 
 
 (*** Lazy List Equality: lleq ***)
 
 declare QPair_Int_Vset_subset_UN [THEN subset_trans, intro!] 
         QPair_mono [intro!]
 
 declare Ord_in_Ord [elim!] 
 
 (*Lemma for proving finality.  Unfold the lazy list; use induction hypothesis*)
 lemma lleq_Int_Vset_subset:
      "Ord(i) \<Longrightarrow> <l,l'> \<in> lleq(A) \<Longrightarrow> l \<inter> Vset(i) \<subseteq> l'"
 proof (induct i arbitrary: l l' rule: trans_induct)
   case (step i l l')
   show ?case using \<open>\<langle>l, l'\<rangle> \<in> lleq(A)\<close>
   proof (cases rule: lleq.cases)
     case LNil thus ?thesis
       by (auto simp add: QInr_def llist.con_defs)
   next
     case (LCons a l l') thus ?thesis using step.hyps
       by (auto simp add: QInr_def llist.con_defs intro: Ord_trans)
   qed
 qed
 
 (*lleq(A) is a symmetric relation because qconverse(lleq(A)) is a fixedpoint*)
 lemma lleq_symmetric: "<l,l'> \<in> lleq(A) \<Longrightarrow> <l',l> \<in> lleq(A)"
 apply (erule lleq.coinduct [OF converseI]) 
 apply (rule lleq.dom_subset [THEN converse_type], safe)
 apply (erule lleq.cases, blast+)
 done
 
 lemma lleq_implies_equal: "<l,l'> \<in> lleq(A) \<Longrightarrow> l=l'"
 apply (rule equalityI)
 apply (assumption | rule lleq_Int_Vset_subset [THEN Int_Vset_subset] | 
        erule lleq_symmetric)+
 done
 
 lemma equal_llist_implies_leq:
      "\<lbrakk>l=l';  l \<in> llist(A)\<rbrakk> \<Longrightarrow> <l,l'> \<in> lleq(A)"
 apply (rule_tac X = "{\<langle>l,l\<rangle>. l \<in> llist (A) }" in lleq.coinduct)
 apply blast
 apply safe
 apply (erule_tac a=la in llist.cases, fast+)
 done
 
 
 (*** Lazy List Functions ***)
 
 (*Examples of coinduction for type-checking and to prove llist equations*)
 
 (*** lconst -- defined directly using lfp, but equivalent to a LList_corec ***)
 
 lemma lconst_fun_bnd_mono: "bnd_mono(univ(a), \<lambda>l. LCons(a,l))"
-apply (unfold llist.con_defs )
+  unfolding llist.con_defs 
 apply (rule bnd_monoI)
 apply (blast intro: A_subset_univ QInr_subset_univ)
 apply (blast intro: subset_refl QInr_mono QPair_mono)
 done
 
 (* lconst(a) = LCons(a,lconst(a)) *)
 lemmas lconst = def_lfp_unfold [OF lconst_def lconst_fun_bnd_mono]
 lemmas lconst_subset = lconst_def [THEN def_lfp_subset]
 lemmas member_subset_Union_eclose = arg_into_eclose [THEN Union_upper]
 
 lemma lconst_in_quniv: "a \<in> A \<Longrightarrow> lconst(a) \<in> quniv(A)"
 apply (rule lconst_subset [THEN subset_trans, THEN qunivI])
 apply (erule arg_into_eclose [THEN eclose_subset, THEN univ_mono])
 done
 
 lemma lconst_type: "a \<in> A \<Longrightarrow> lconst(a): llist(A)"
 apply (rule singletonI [THEN llist.coinduct])
 apply (erule lconst_in_quniv [THEN singleton_subsetI])
 apply (fast intro!: lconst)
 done
 
 (*** flip --- equations merely assumed; certain consequences proved ***)
 
 declare flip_LNil [simp] 
         flip_LCons [simp] 
         not_type [simp]
 
 lemma bool_Int_subset_univ: "b \<in> bool \<Longrightarrow> b \<inter> X \<subseteq> univ(eclose(A))"
 by (fast intro: Int_lower1 [THEN subset_trans] elim!: boolE)
 
 declare not_type [intro!]
 declare bool_Int_subset_univ [intro]
 
 (*Reasoning borrowed from lleq.ML; a similar proof works for all
   "productive" functions -- cf Coquand's "Infinite Objects in Type Theory".*)
 lemma flip_llist_quniv_lemma:
      "Ord(i) \<Longrightarrow> l \<in> llist(bool) \<Longrightarrow> flip(l) \<inter> Vset(i) \<subseteq> univ(eclose(bool))"
 proof (induct i arbitrary: l rule: trans_induct)
   case (step i l)
   show ?case using \<open>l \<in> llist(bool)\<close>
   proof (cases l rule: llist.cases)
     case LNil thus ?thesis
       by (simp, simp add: QInl_def QInr_def llist.con_defs)
   next
     case (LCons a l) thus ?thesis using step.hyps
     proof (simp, simp add: QInl_def QInr_def llist.con_defs)
       show "<1; <not(a); flip(l)>> \<inter> Vset(i) \<subseteq> univ(eclose(bool))" using LCons step.hyps
         by (auto intro: Ord_trans) 
     qed
   qed
 qed
 
 lemma flip_in_quniv: "l \<in> llist(bool) \<Longrightarrow> flip(l) \<in> quniv(bool)"
 by (rule flip_llist_quniv_lemma [THEN Int_Vset_subset, THEN qunivI], assumption+)
 
 lemma flip_type: "l \<in> llist(bool) \<Longrightarrow> flip(l): llist(bool)"
 apply (rule_tac X = "{flip (l) . l \<in> llist (bool) }" in llist.coinduct)
 apply blast
 apply (fast intro!: flip_in_quniv)
 apply (erule RepFunE)
 apply (erule_tac a=la in llist.cases, auto)
 done
 
 lemma flip_flip: "l \<in> llist(bool) \<Longrightarrow> flip(flip(l)) = l"
 apply (rule_tac X1 = "{<flip (flip (l)),l> . l \<in> llist (bool) }" in 
        lleq.coinduct [THEN lleq_implies_equal])
 apply blast
 apply (fast intro!: flip_type)
 apply (erule RepFunE)
 apply (erule_tac a=la in llist.cases)
 apply (simp_all add: flip_type not_not)
 done
 
 end
 
diff --git a/src/ZF/ex/Ramsey.thy b/src/ZF/ex/Ramsey.thy
--- a/src/ZF/ex/Ramsey.thy
+++ b/src/ZF/ex/Ramsey.thy
@@ -1,197 +1,197 @@
 (*  Title:      ZF/ex/Ramsey.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1992  University of Cambridge
 
 Ramsey's Theorem (finite exponent 2 version)
 
 Based upon the article
     D Basin and M Kaufmann,
     The Boyer-Moore Prover and Nuprl: An Experimental Comparison.
     In G Huet and G Plotkin, editors, Logical Frameworks.
     (CUP, 1991), pages 89-119
 
 See also
     M Kaufmann,
     An example in NQTHM: Ramsey's Theorem
     Internal Note, Computational Logic, Inc., Austin, Texas 78703
     Available from the author: kaufmann@cli.com
 
 This function compute Ramsey numbers according to the proof given below
 (which, does not constrain the base case values at all.
 
 fun ram 0 j = 1
   | ram i 0 = 1
   | ram i j = ram (i-1) j + ram i (j-1)
 *)
 
 theory Ramsey imports ZF begin
 
 definition
   Symmetric :: "i\<Rightarrow>o" where
     "Symmetric(E) \<equiv> (\<forall>x y. \<langle>x,y\<rangle>:E \<longrightarrow> \<langle>y,x\<rangle>:E)"
 
 definition
   Atleast :: "[i,i]\<Rightarrow>o" where \<comment> \<open>not really necessary: ZF defines cardinality\<close>
     "Atleast(n,S) \<equiv> (\<exists>f. f \<in> inj(n,S))"
 
 definition
   Clique  :: "[i,i,i]\<Rightarrow>o" where
     "Clique(C,V,E) \<equiv> (C \<subseteq> V) \<and> (\<forall>x \<in> C. \<forall>y \<in> C. x\<noteq>y \<longrightarrow> \<langle>x,y\<rangle> \<in> E)"
 
 definition
   Indept  :: "[i,i,i]\<Rightarrow>o" where
     "Indept(I,V,E) \<equiv> (I \<subseteq> V) \<and> (\<forall>x \<in> I. \<forall>y \<in> I. x\<noteq>y \<longrightarrow> \<langle>x,y\<rangle> \<notin> E)"
   
 definition
   Ramsey  :: "[i,i,i]\<Rightarrow>o" where
     "Ramsey(n,i,j) \<equiv> \<forall>V E. Symmetric(E) \<and> Atleast(n,V) \<longrightarrow>  
          (\<exists>C. Clique(C,V,E) \<and> Atleast(i,C)) |       
          (\<exists>I. Indept(I,V,E) \<and> Atleast(j,I))"
 
 (*** Cliques and Independent sets ***)
 
 lemma Clique0 [intro]: "Clique(0,V,E)"
 by (unfold Clique_def, blast)
 
 lemma Clique_superset: "\<lbrakk>Clique(C,V',E);  V'<=V\<rbrakk> \<Longrightarrow> Clique(C,V,E)"
 by (unfold Clique_def, blast)
 
 lemma Indept0 [intro]: "Indept(0,V,E)"
 by (unfold Indept_def, blast)
 
 lemma Indept_superset: "\<lbrakk>Indept(I,V',E);  V'<=V\<rbrakk> \<Longrightarrow> Indept(I,V,E)"
 by (unfold Indept_def, blast)
 
 (*** Atleast ***)
 
 lemma Atleast0 [intro]: "Atleast(0,A)"
 by (unfold Atleast_def inj_def Pi_def function_def, blast)
 
 lemma Atleast_succD: 
     "Atleast(succ(m),A) \<Longrightarrow> \<exists>x \<in> A. Atleast(m, A-{x})"
   unfolding Atleast_def
 apply (blast dest: inj_is_fun [THEN apply_type] inj_succ_restrict)
 done
 
 lemma Atleast_superset: 
     "\<lbrakk>Atleast(n,A);  A \<subseteq> B\<rbrakk> \<Longrightarrow> Atleast(n,B)"
 by (unfold Atleast_def, blast intro: inj_weaken_type)
 
 lemma Atleast_succI: 
     "\<lbrakk>Atleast(m,B);  b\<notin> B\<rbrakk> \<Longrightarrow> Atleast(succ(m), cons(b,B))"
-apply (unfold Atleast_def succ_def)
+  unfolding Atleast_def succ_def
 apply (blast intro: inj_extend elim: mem_irrefl) 
 done
 
 lemma Atleast_Diff_succI:
      "\<lbrakk>Atleast(m, B-{x});  x \<in> B\<rbrakk> \<Longrightarrow> Atleast(succ(m), B)"
 by (blast intro: Atleast_succI [THEN Atleast_superset]) 
 
 (*** Main Cardinality Lemma ***)
 
 (*The #-succ(0) strengthens the original theorem statement, but precisely
   the same proof could be used\<And>*)
 lemma pigeon2 [rule_format]:
      "m \<in> nat \<Longrightarrow>  
           \<forall>n \<in> nat. \<forall>A B. Atleast((m#+n) #- succ(0), A \<union> B) \<longrightarrow>    
                            Atleast(m,A) | Atleast(n,B)"
 apply (induct_tac "m")
 apply (blast intro!: Atleast0, simp)
 apply (rule ballI)
 apply (rename_tac m' n) (*simplifier does NOT preserve bound names!*)
 apply (induct_tac "n", auto)
 apply (erule Atleast_succD [THEN bexE])
 apply (rename_tac n' A B z)
 apply (erule UnE)
 (**case z \<in> B.  Instantiate the '\<forall>A B' induction hypothesis. **)
 apply (drule_tac [2] x1 = A and x = "B-{z}" in spec [THEN spec])
 apply (erule_tac [2] mp [THEN disjE])
 (*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
 apply (erule_tac [3] asm_rl notE Atleast_Diff_succI)+
 (*proving the condition*)
 prefer 2 apply (blast intro: Atleast_superset)
 (**case z \<in> A.  Instantiate the '\<forall>n \<in> nat. \<forall>A B' induction hypothesis. **)
 apply (drule_tac x2="succ(n')" and x1="A-{z}" and x=B
        in bspec [THEN spec, THEN spec])
 apply (erule nat_succI)
 apply (erule mp [THEN disjE])
 (*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
 apply (erule_tac [2] asm_rl Atleast_Diff_succI notE)+
 (*proving the condition*)
 apply simp
 apply (blast intro: Atleast_superset)
 done
 
 
 (**** Ramsey's Theorem ****)
 
 (** Base cases of induction; they now admit ANY Ramsey number **)
 
 lemma Ramsey0j: "Ramsey(n,0,j)"
 by (unfold Ramsey_def, blast)
 
 lemma Ramseyi0: "Ramsey(n,i,0)"
 by (unfold Ramsey_def, blast)
 
 (** Lemmas for induction step **)
 
 (*The use of succ(m) here, rather than #-succ(0), simplifies the proof of 
   Ramsey_step_lemma.*)
 lemma Atleast_partition: "\<lbrakk>Atleast(m #+ n, A);  m \<in> nat;  n \<in> nat\<rbrakk>   
       \<Longrightarrow> Atleast(succ(m), {x \<in> A. \<not>P(x)}) | Atleast(n, {x \<in> A. P(x)})"
 apply (rule nat_succI [THEN pigeon2], assumption+)
 apply (rule Atleast_superset, auto)
 done
 
 (*For the Atleast part, proves \<not>(a \<in> I) from the second premise!*)
 lemma Indept_succ: 
     "\<lbrakk>Indept(I, {z \<in> V-{a}. \<langle>a,z\<rangle> \<notin> E}, E);  Symmetric(E);  a \<in> V;   
         Atleast(j,I)\<rbrakk> \<Longrightarrow>    
      Indept(cons(a,I), V, E) \<and> Atleast(succ(j), cons(a,I))"
-apply (unfold Symmetric_def Indept_def)
+  unfolding Symmetric_def Indept_def
 apply (blast intro!: Atleast_succI)
 done
 
 
 lemma Clique_succ: 
     "\<lbrakk>Clique(C, {z \<in> V-{a}. \<langle>a,z\<rangle>:E}, E);  Symmetric(E);  a \<in> V;   
         Atleast(j,C)\<rbrakk> \<Longrightarrow>    
      Clique(cons(a,C), V, E) \<and> Atleast(succ(j), cons(a,C))"
-apply (unfold Symmetric_def Clique_def)
+  unfolding Symmetric_def Clique_def
 apply (blast intro!: Atleast_succI)
 done
 
 (** Induction step **)
 
 (*Published proofs gloss over the need for Ramsey numbers to be POSITIVE.*)
 lemma Ramsey_step_lemma:
    "\<lbrakk>Ramsey(succ(m), succ(i), j);  Ramsey(n, i, succ(j));   
        m \<in> nat;  n \<in> nat\<rbrakk> \<Longrightarrow> Ramsey(succ(m#+n), succ(i), succ(j))"
 apply (unfold Ramsey_def, clarify)
 apply (erule Atleast_succD [THEN bexE])
 apply (erule_tac P1 = "\<lambda>z.\<langle>x,z\<rangle>:E" in Atleast_partition [THEN disjE],
        assumption+)
 (*case m*)
 apply (fast dest!: Indept_succ elim: Clique_superset)
 (*case n*)
 apply (fast dest!: Clique_succ elim: Indept_superset)
 done
 
 
 (** The actual proof **)
 
 (*Again, the induction requires Ramsey numbers to be positive.*)
 lemma ramsey_lemma: "i \<in> nat \<Longrightarrow> \<forall>j \<in> nat. \<exists>n \<in> nat. Ramsey(succ(n), i, j)"
 apply (induct_tac "i")
 apply (blast intro!: Ramsey0j)
 apply (rule ballI)
 apply (induct_tac "j")
 apply (blast intro!: Ramseyi0)
 apply (blast intro!: add_type Ramsey_step_lemma)
 done
 
 (*Final statement in a tidy form, without succ(...) *)
 lemma ramsey: "\<lbrakk>i \<in> nat;  j \<in> nat\<rbrakk> \<Longrightarrow> \<exists>n \<in> nat. Ramsey(n,i,j)"
 by (blast dest: ramsey_lemma)
 
 end
diff --git a/src/ZF/func.thy b/src/ZF/func.thy
--- a/src/ZF/func.thy
+++ b/src/ZF/func.thy
@@ -1,611 +1,611 @@
 (*  Title:      ZF/func.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1991  University of Cambridge
 *)
 
 section\<open>Functions, Function Spaces, Lambda-Abstraction\<close>
 
 theory func imports equalities Sum begin
 
 subsection\<open>The Pi Operator: Dependent Function Space\<close>
 
 lemma subset_Sigma_imp_relation: "r \<subseteq> Sigma(A,B) \<Longrightarrow> relation(r)"
 by (simp add: relation_def, blast)
 
 lemma relation_converse_converse [simp]:
      "relation(r) \<Longrightarrow> converse(converse(r)) = r"
 by (simp add: relation_def, blast)
 
 lemma relation_restrict [simp]:  "relation(restrict(r,A))"
 by (simp add: restrict_def relation_def, blast)
 
 lemma Pi_iff:
     "f \<in> Pi(A,B) \<longleftrightarrow> function(f) \<and> f<=Sigma(A,B) \<and> A<=domain(f)"
 by (unfold Pi_def, blast)
 
 (*For upward compatibility with the former definition*)
 lemma Pi_iff_old:
     "f \<in> Pi(A,B) \<longleftrightarrow> f<=Sigma(A,B) \<and> (\<forall>x\<in>A. \<exists>!y. \<langle>x,y\<rangle>: f)"
 by (unfold Pi_def function_def, blast)
 
 lemma fun_is_function: "f \<in> Pi(A,B) \<Longrightarrow> function(f)"
 by (simp only: Pi_iff)
 
 lemma function_imp_Pi:
      "\<lbrakk>function(f); relation(f)\<rbrakk> \<Longrightarrow> f \<in> domain(f) -> range(f)"
 by (simp add: Pi_iff relation_def, blast)
 
 lemma functionI:
      "\<lbrakk>\<And>x y y'. \<lbrakk>\<langle>x,y\<rangle>:r; <x,y'>:r\<rbrakk> \<Longrightarrow> y=y'\<rbrakk> \<Longrightarrow> function(r)"
 by (simp add: function_def, blast)
 
 (*Functions are relations*)
 lemma fun_is_rel: "f \<in> Pi(A,B) \<Longrightarrow> f \<subseteq> Sigma(A,B)"
 by (unfold Pi_def, blast)
 
 lemma Pi_cong:
     "\<lbrakk>A=A';  \<And>x. x \<in> A' \<Longrightarrow> B(x)=B'(x)\<rbrakk> \<Longrightarrow> Pi(A,B) = Pi(A',B')"
 by (simp add: Pi_def cong add: Sigma_cong)
 
 (*Sigma_cong, Pi_cong NOT given to Addcongs: they cause
   flex-flex pairs and the "Check your prover" error.  Most
   Sigmas and Pis are abbreviated as * or -> *)
 
 (*Weakening one function type to another; see also Pi_type*)
 lemma fun_weaken_type: "\<lbrakk>f \<in> A->B;  B<=D\<rbrakk> \<Longrightarrow> f \<in> A->D"
 by (unfold Pi_def, best)
 
 subsection\<open>Function Application\<close>
 
 lemma apply_equality2: "\<lbrakk>\<langle>a,b\<rangle>: f;  \<langle>a,c\<rangle>: f;  f \<in> Pi(A,B)\<rbrakk> \<Longrightarrow> b=c"
 by (unfold Pi_def function_def, blast)
 
 lemma function_apply_equality: "\<lbrakk>\<langle>a,b\<rangle>: f;  function(f)\<rbrakk> \<Longrightarrow> f`a = b"
 by (unfold apply_def function_def, blast)
 
 lemma apply_equality: "\<lbrakk>\<langle>a,b\<rangle>: f;  f \<in> Pi(A,B)\<rbrakk> \<Longrightarrow> f`a = b"
   unfolding Pi_def
 apply (blast intro: function_apply_equality)
 done
 
 (*Applying a function outside its domain yields 0*)
 lemma apply_0: "a \<notin> domain(f) \<Longrightarrow> f`a = 0"
 by (unfold apply_def, blast)
 
 lemma Pi_memberD: "\<lbrakk>f \<in> Pi(A,B);  c \<in> f\<rbrakk> \<Longrightarrow> \<exists>x\<in>A.  c = <x,f`x>"
 apply (frule fun_is_rel)
 apply (blast dest: apply_equality)
 done
 
 lemma function_apply_Pair: "\<lbrakk>function(f);  a \<in> domain(f)\<rbrakk> \<Longrightarrow> <a,f`a>: f"
 apply (simp add: function_def, clarify)
 apply (subgoal_tac "f`a = y", blast)
 apply (simp add: apply_def, blast)
 done
 
 lemma apply_Pair: "\<lbrakk>f \<in> Pi(A,B);  a \<in> A\<rbrakk> \<Longrightarrow> <a,f`a>: f"
 apply (simp add: Pi_iff)
 apply (blast intro: function_apply_Pair)
 done
 
 (*Conclusion is flexible -- use rule_tac or else apply_funtype below!*)
 lemma apply_type [TC]: "\<lbrakk>f \<in> Pi(A,B);  a \<in> A\<rbrakk> \<Longrightarrow> f`a \<in> B(a)"
 by (blast intro: apply_Pair dest: fun_is_rel)
 
 (*This version is acceptable to the simplifier*)
 lemma apply_funtype: "\<lbrakk>f \<in> A->B;  a \<in> A\<rbrakk> \<Longrightarrow> f`a \<in> B"
 by (blast dest: apply_type)
 
 lemma apply_iff: "f \<in> Pi(A,B) \<Longrightarrow> \<langle>a,b\<rangle>: f \<longleftrightarrow> a \<in> A \<and> f`a = b"
 apply (frule fun_is_rel)
 apply (blast intro!: apply_Pair apply_equality)
 done
 
 (*Refining one Pi type to another*)
 lemma Pi_type: "\<lbrakk>f \<in> Pi(A,C);  \<And>x. x \<in> A \<Longrightarrow> f`x \<in> B(x)\<rbrakk> \<Longrightarrow> f \<in> Pi(A,B)"
 apply (simp only: Pi_iff)
 apply (blast dest: function_apply_equality)
 done
 
 (*Such functions arise in non-standard datatypes, ZF/ex/Ntree for instance*)
 lemma Pi_Collect_iff:
      "(f \<in> Pi(A, \<lambda>x. {y \<in> B(x). P(x,y)}))
       \<longleftrightarrow>  f \<in> Pi(A,B) \<and> (\<forall>x\<in>A. P(x, f`x))"
 by (blast intro: Pi_type dest: apply_type)
 
 lemma Pi_weaken_type:
         "\<lbrakk>f \<in> Pi(A,B);  \<And>x. x \<in> A \<Longrightarrow> B(x)<=C(x)\<rbrakk> \<Longrightarrow> f \<in> Pi(A,C)"
 by (blast intro: Pi_type dest: apply_type)
 
 
 (** Elimination of membership in a function **)
 
 lemma domain_type: "\<lbrakk>\<langle>a,b\<rangle> \<in> f;  f \<in> Pi(A,B)\<rbrakk> \<Longrightarrow> a \<in> A"
 by (blast dest: fun_is_rel)
 
 lemma range_type: "\<lbrakk>\<langle>a,b\<rangle> \<in> f;  f \<in> Pi(A,B)\<rbrakk> \<Longrightarrow> b \<in> B(a)"
 by (blast dest: fun_is_rel)
 
 lemma Pair_mem_PiD: "\<lbrakk>\<langle>a,b\<rangle>: f;  f \<in> Pi(A,B)\<rbrakk> \<Longrightarrow> a \<in> A \<and> b \<in> B(a) \<and> f`a = b"
 by (blast intro: domain_type range_type apply_equality)
 
 subsection\<open>Lambda Abstraction\<close>
 
 lemma lamI: "a \<in> A \<Longrightarrow> <a,b(a)> \<in> (\<lambda>x\<in>A. b(x))"
   unfolding lam_def
 apply (erule RepFunI)
 done
 
 lemma lamE:
     "\<lbrakk>p: (\<lambda>x\<in>A. b(x));  \<And>x.\<lbrakk>x \<in> A; p=<x,b(x)>\<rbrakk> \<Longrightarrow> P
 \<rbrakk> \<Longrightarrow>  P"
 by (simp add: lam_def, blast)
 
 lemma lamD: "\<lbrakk>\<langle>a,c\<rangle>: (\<lambda>x\<in>A. b(x))\<rbrakk> \<Longrightarrow> c = b(a)"
 by (simp add: lam_def)
 
 lemma lam_type [TC]:
     "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> b(x): B(x)\<rbrakk> \<Longrightarrow> (\<lambda>x\<in>A. b(x)) \<in> Pi(A,B)"
 by (simp add: lam_def Pi_def function_def, blast)
 
 lemma lam_funtype: "(\<lambda>x\<in>A. b(x)) \<in> A -> {b(x). x \<in> A}"
 by (blast intro: lam_type)
 
 lemma function_lam: "function (\<lambda>x\<in>A. b(x))"
 by (simp add: function_def lam_def)
 
 lemma relation_lam: "relation (\<lambda>x\<in>A. b(x))"
 by (simp add: relation_def lam_def)
 
 lemma beta_if [simp]: "(\<lambda>x\<in>A. b(x)) ` a = (if a \<in> A then b(a) else 0)"
 by (simp add: apply_def lam_def, blast)
 
 lemma beta: "a \<in> A \<Longrightarrow> (\<lambda>x\<in>A. b(x)) ` a = b(a)"
 by (simp add: apply_def lam_def, blast)
 
 lemma lam_empty [simp]: "(\<lambda>x\<in>0. b(x)) = 0"
 by (simp add: lam_def)
 
 lemma domain_lam [simp]: "domain(Lambda(A,b)) = A"
 by (simp add: lam_def, blast)
 
 (*congruence rule for lambda abstraction*)
 lemma lam_cong [cong]:
     "\<lbrakk>A=A';  \<And>x. x \<in> A' \<Longrightarrow> b(x)=b'(x)\<rbrakk> \<Longrightarrow> Lambda(A,b) = Lambda(A',b')"
 by (simp only: lam_def cong add: RepFun_cong)
 
 lemma lam_theI:
     "(\<And>x. x \<in> A \<Longrightarrow> \<exists>!y. Q(x,y)) \<Longrightarrow> \<exists>f. \<forall>x\<in>A. Q(x, f`x)"
 apply (rule_tac x = "\<lambda>x\<in>A. THE y. Q (x,y)" in exI)
 apply simp
 apply (blast intro: theI)
 done
 
 lemma lam_eqE: "\<lbrakk>(\<lambda>x\<in>A. f(x)) = (\<lambda>x\<in>A. g(x));  a \<in> A\<rbrakk> \<Longrightarrow> f(a)=g(a)"
 by (fast intro!: lamI elim: equalityE lamE)
 
 
 (*Empty function spaces*)
 lemma Pi_empty1 [simp]: "Pi(0,A) = {0}"
 by (unfold Pi_def function_def, blast)
 
 (*The singleton function*)
 lemma singleton_fun [simp]: "{\<langle>a,b\<rangle>} \<in> {a} -> {b}"
 by (unfold Pi_def function_def, blast)
 
 lemma Pi_empty2 [simp]: "(A->0) = (if A=0 then {0} else 0)"
 by (unfold Pi_def function_def, force)
 
 lemma  fun_space_empty_iff [iff]: "(A->X)=0 \<longleftrightarrow> X=0 \<and> (A \<noteq> 0)"
 apply auto
 apply (fast intro!: equals0I intro: lam_type)
 done
 
 
 subsection\<open>Extensionality\<close>
 
 (*Semi-extensionality!*)
 
 lemma fun_subset:
     "\<lbrakk>f \<in> Pi(A,B);  g \<in> Pi(C,D);  A<=C;
         \<And>x. x \<in> A \<Longrightarrow> f`x = g`x\<rbrakk> \<Longrightarrow> f<=g"
 by (force dest: Pi_memberD intro: apply_Pair)
 
 lemma fun_extension:
     "\<lbrakk>f \<in> Pi(A,B);  g \<in> Pi(A,D);
         \<And>x. x \<in> A \<Longrightarrow> f`x = g`x\<rbrakk> \<Longrightarrow> f=g"
 by (blast del: subsetI intro: subset_refl sym fun_subset)
 
 lemma eta [simp]: "f \<in> Pi(A,B) \<Longrightarrow> (\<lambda>x\<in>A. f`x) = f"
 apply (rule fun_extension)
 apply (auto simp add: lam_type apply_type beta)
 done
 
 lemma fun_extension_iff:
      "\<lbrakk>f \<in> Pi(A,B); g \<in> Pi(A,C)\<rbrakk> \<Longrightarrow> (\<forall>a\<in>A. f`a = g`a) \<longleftrightarrow> f=g"
 by (blast intro: fun_extension)
 
 (*thm by Mark Staples, proof by lcp*)
 lemma fun_subset_eq: "\<lbrakk>f \<in> Pi(A,B); g \<in> Pi(A,C)\<rbrakk> \<Longrightarrow> f \<subseteq> g \<longleftrightarrow> (f = g)"
 by (blast dest: apply_Pair
           intro: fun_extension apply_equality [symmetric])
 
 
 (*Every element of Pi(A,B) may be expressed as a lambda abstraction!*)
 lemma Pi_lamE:
   assumes major: "f \<in> Pi(A,B)"
       and minor: "\<And>b. \<lbrakk>\<forall>x\<in>A. b(x):B(x);  f = (\<lambda>x\<in>A. b(x))\<rbrakk> \<Longrightarrow> P"
   shows "P"
 apply (rule minor)
 apply (rule_tac [2] eta [symmetric])
 apply (blast intro: major apply_type)+
 done
 
 
 subsection\<open>Images of Functions\<close>
 
 lemma image_lam: "C \<subseteq> A \<Longrightarrow> (\<lambda>x\<in>A. b(x)) `` C = {b(x). x \<in> C}"
 by (unfold lam_def, blast)
 
 lemma Repfun_function_if:
      "function(f)
       \<Longrightarrow> {f`x. x \<in> C} = (if C \<subseteq> domain(f) then f``C else cons(0,f``C))"
 apply simp
 apply (intro conjI impI)
  apply (blast dest: function_apply_equality intro: function_apply_Pair)
 apply (rule equalityI)
  apply (blast intro!: function_apply_Pair apply_0)
 apply (blast dest: function_apply_equality intro: apply_0 [symmetric])
 done
 
 (*For this lemma and the next, the right-hand side could equivalently
   be written \<Union>x\<in>C. {f`x} *)
 lemma image_function:
      "\<lbrakk>function(f);  C \<subseteq> domain(f)\<rbrakk> \<Longrightarrow> f``C = {f`x. x \<in> C}"
 by (simp add: Repfun_function_if)
 
 lemma image_fun: "\<lbrakk>f \<in> Pi(A,B);  C \<subseteq> A\<rbrakk> \<Longrightarrow> f``C = {f`x. x \<in> C}"
 apply (simp add: Pi_iff)
 apply (blast intro: image_function)
 done
 
 lemma image_eq_UN:
   assumes f: "f \<in> Pi(A,B)" "C \<subseteq> A" shows "f``C = (\<Union>x\<in>C. {f ` x})"
 by (auto simp add: image_fun [OF f])
 
 lemma Pi_image_cons:
      "\<lbrakk>f \<in> Pi(A,B);  x \<in> A\<rbrakk> \<Longrightarrow> f `` cons(x,y) = cons(f`x, f``y)"
 by (blast dest: apply_equality apply_Pair)
 
 
 subsection\<open>Properties of \<^term>\<open>restrict(f,A)\<close>\<close>
 
 lemma restrict_subset: "restrict(f,A) \<subseteq> f"
 by (unfold restrict_def, blast)
 
 lemma function_restrictI:
     "function(f) \<Longrightarrow> function(restrict(f,A))"
 by (unfold restrict_def function_def, blast)
 
 lemma restrict_type2: "\<lbrakk>f \<in> Pi(C,B);  A<=C\<rbrakk> \<Longrightarrow> restrict(f,A) \<in> Pi(A,B)"
 by (simp add: Pi_iff function_def restrict_def, blast)
 
 lemma restrict: "restrict(f,A) ` a = (if a \<in> A then f`a else 0)"
 by (simp add: apply_def restrict_def, blast)
 
 lemma restrict_empty [simp]: "restrict(f,0) = 0"
 by (unfold restrict_def, simp)
 
 lemma restrict_iff: "z \<in> restrict(r,A) \<longleftrightarrow> z \<in> r \<and> (\<exists>x\<in>A. \<exists>y. z = \<langle>x, y\<rangle>)"
 by (simp add: restrict_def)
 
 lemma restrict_restrict [simp]:
      "restrict(restrict(r,A),B) = restrict(r, A \<inter> B)"
 by (unfold restrict_def, blast)
 
 lemma domain_restrict [simp]: "domain(restrict(f,C)) = domain(f) \<inter> C"
   unfolding restrict_def
 apply (auto simp add: domain_def)
 done
 
 lemma restrict_idem: "f \<subseteq> Sigma(A,B) \<Longrightarrow> restrict(f,A) = f"
 by (simp add: restrict_def, blast)
 
 
 (*converse probably holds too*)
 lemma domain_restrict_idem:
      "\<lbrakk>domain(r) \<subseteq> A; relation(r)\<rbrakk> \<Longrightarrow> restrict(r,A) = r"
 by (simp add: restrict_def relation_def, blast)
 
 lemma domain_restrict_lam [simp]: "domain(restrict(Lambda(A,f),C)) = A \<inter> C"
-apply (unfold restrict_def lam_def)
+  unfolding restrict_def lam_def
 apply (rule equalityI)
 apply (auto simp add: domain_iff)
 done
 
 lemma restrict_if [simp]: "restrict(f,A) ` a = (if a \<in> A then f`a else 0)"
 by (simp add: restrict apply_0)
 
 lemma restrict_lam_eq:
     "A<=C \<Longrightarrow> restrict(\<lambda>x\<in>C. b(x), A) = (\<lambda>x\<in>A. b(x))"
 by (unfold restrict_def lam_def, auto)
 
 lemma fun_cons_restrict_eq:
      "f \<in> cons(a, b) -> B \<Longrightarrow> f = cons(<a, f ` a>, restrict(f, b))"
 apply (rule equalityI)
  prefer 2 apply (blast intro: apply_Pair restrict_subset [THEN subsetD])
 apply (auto dest!: Pi_memberD simp add: restrict_def lam_def)
 done
 
 
 subsection\<open>Unions of Functions\<close>
 
 (** The Union of a set of COMPATIBLE functions is a function **)
 
 lemma function_Union:
     "\<lbrakk>\<forall>x\<in>S. function(x);
         \<forall>x\<in>S. \<forall>y\<in>S. x<=y | y<=x\<rbrakk>
      \<Longrightarrow> function(\<Union>(S))"
 by (unfold function_def, blast)
 
 lemma fun_Union:
     "\<lbrakk>\<forall>f\<in>S. \<exists>C D. f \<in> C->D;
              \<forall>f\<in>S. \<forall>y\<in>S. f<=y | y<=f\<rbrakk> \<Longrightarrow>
           \<Union>(S) \<in> domain(\<Union>(S)) -> range(\<Union>(S))"
   unfolding Pi_def
 apply (blast intro!: rel_Union function_Union)
 done
 
 lemma gen_relation_Union:
      "(\<And>f. f\<in>F \<Longrightarrow> relation(f)) \<Longrightarrow> relation(\<Union>(F))"
 by (simp add: relation_def)
 
 
 (** The Union of 2 disjoint functions is a function **)
 
 lemmas Un_rls = Un_subset_iff SUM_Un_distrib1 prod_Un_distrib2
                 subset_trans [OF _ Un_upper1]
                 subset_trans [OF _ Un_upper2]
 
 lemma fun_disjoint_Un:
      "\<lbrakk>f \<in> A->B;  g \<in> C->D;  A \<inter> C = 0\<rbrakk>
       \<Longrightarrow> (f \<union> g) \<in> (A \<union> C) -> (B \<union> D)"
 (*Prove the product and domain subgoals using distributive laws*)
 apply (simp add: Pi_iff extension Un_rls)
 apply (unfold function_def, blast)
 done
 
 lemma fun_disjoint_apply1: "a \<notin> domain(g) \<Longrightarrow> (f \<union> g)`a = f`a"
 by (simp add: apply_def, blast)
 
 lemma fun_disjoint_apply2: "c \<notin> domain(f) \<Longrightarrow> (f \<union> g)`c = g`c"
 by (simp add: apply_def, blast)
 
 subsection\<open>Domain and Range of a Function or Relation\<close>
 
 lemma domain_of_fun: "f \<in> Pi(A,B) \<Longrightarrow> domain(f)=A"
 by (unfold Pi_def, blast)
 
 lemma apply_rangeI: "\<lbrakk>f \<in> Pi(A,B);  a \<in> A\<rbrakk> \<Longrightarrow> f`a \<in> range(f)"
 by (erule apply_Pair [THEN rangeI], assumption)
 
 lemma range_of_fun: "f \<in> Pi(A,B) \<Longrightarrow> f \<in> A->range(f)"
 by (blast intro: Pi_type apply_rangeI)
 
 subsection\<open>Extensions of Functions\<close>
 
 lemma fun_extend:
      "\<lbrakk>f \<in> A->B;  c\<notin>A\<rbrakk> \<Longrightarrow> cons(\<langle>c,b\<rangle>,f) \<in> cons(c,A) -> cons(b,B)"
 apply (frule singleton_fun [THEN fun_disjoint_Un], blast)
 apply (simp add: cons_eq)
 done
 
 lemma fun_extend3:
      "\<lbrakk>f \<in> A->B;  c\<notin>A;  b \<in> B\<rbrakk> \<Longrightarrow> cons(\<langle>c,b\<rangle>,f) \<in> cons(c,A) -> B"
 by (blast intro: fun_extend [THEN fun_weaken_type])
 
 lemma extend_apply:
      "c \<notin> domain(f) \<Longrightarrow> cons(\<langle>c,b\<rangle>,f)`a = (if a=c then b else f`a)"
 by (auto simp add: apply_def)
 
 lemma fun_extend_apply [simp]:
      "\<lbrakk>f \<in> A->B;  c\<notin>A\<rbrakk> \<Longrightarrow> cons(\<langle>c,b\<rangle>,f)`a = (if a=c then b else f`a)"
 apply (rule extend_apply)
 apply (simp add: Pi_def, blast)
 done
 
 lemmas singleton_apply = apply_equality [OF singletonI singleton_fun, simp]
 
 (*For Finite.ML.  Inclusion of right into left is easy*)
 lemma cons_fun_eq:
      "c \<notin> A \<Longrightarrow> cons(c,A) -> B = (\<Union>f \<in> A->B. \<Union>b\<in>B. {cons(\<langle>c,b\<rangle>, f)})"
 apply (rule equalityI)
 apply (safe elim!: fun_extend3)
 (*Inclusion of left into right*)
 apply (subgoal_tac "restrict (x, A) \<in> A -> B")
  prefer 2 apply (blast intro: restrict_type2)
 apply (rule UN_I, assumption)
 apply (rule apply_funtype [THEN UN_I])
   apply assumption
  apply (rule consI1)
 apply (simp (no_asm))
 apply (rule fun_extension)
   apply assumption
  apply (blast intro: fun_extend)
 apply (erule consE, simp_all)
 done
 
 lemma succ_fun_eq: "succ(n) -> B = (\<Union>f \<in> n->B. \<Union>b\<in>B. {cons(\<langle>n,b\<rangle>, f)})"
 by (simp add: succ_def mem_not_refl cons_fun_eq)
 
 
 subsection\<open>Function Updates\<close>
 
 definition
   update  :: "[i,i,i] \<Rightarrow> i"  where
    "update(f,a,b) \<equiv> \<lambda>x\<in>cons(a, domain(f)). if(x=a, b, f`x)"
 
 nonterminal updbinds and updbind
 
 syntax
 
   (* Let expressions *)
 
   "_updbind"    :: "[i, i] \<Rightarrow> updbind"               (\<open>(2_ :=/ _)\<close>)
   ""            :: "updbind \<Rightarrow> updbinds"             (\<open>_\<close>)
   "_updbinds"   :: "[updbind, updbinds] \<Rightarrow> updbinds" (\<open>_,/ _\<close>)
   "_Update"     :: "[i, updbinds] \<Rightarrow> i"              (\<open>_/'((_)')\<close> [900,0] 900)
 
 translations
   "_Update (f, _updbinds(b,bs))"  == "_Update (_Update(f,b), bs)"
   "f(x:=y)"                       == "CONST update(f,x,y)"
 
 
 lemma update_apply [simp]: "f(x:=y) ` z = (if z=x then y else f`z)"
 apply (simp add: update_def)
 apply (case_tac "z \<in> domain(f)")
 apply (simp_all add: apply_0)
 done
 
 lemma update_idem: "\<lbrakk>f`x = y;  f \<in> Pi(A,B);  x \<in> A\<rbrakk> \<Longrightarrow> f(x:=y) = f"
   unfolding update_def
 apply (simp add: domain_of_fun cons_absorb)
 apply (rule fun_extension)
 apply (best intro: apply_type if_type lam_type, assumption, simp)
 done
 
 
 (* \<lbrakk>f \<in> Pi(A, B); x \<in> A\<rbrakk> \<Longrightarrow> f(x := f`x) = f *)
 declare refl [THEN update_idem, simp]
 
 lemma domain_update [simp]: "domain(f(x:=y)) = cons(x, domain(f))"
 by (unfold update_def, simp)
 
 lemma update_type: "\<lbrakk>f \<in> Pi(A,B);  x \<in> A;  y \<in> B(x)\<rbrakk> \<Longrightarrow> f(x:=y) \<in> Pi(A, B)"
   unfolding update_def
 apply (simp add: domain_of_fun cons_absorb apply_funtype lam_type)
 done
 
 
 subsection\<open>Monotonicity Theorems\<close>
 
 subsubsection\<open>Replacement in its Various Forms\<close>
 
 (*Not easy to express monotonicity in P, since any "bigger" predicate
   would have to be single-valued*)
 lemma Replace_mono: "A<=B \<Longrightarrow> Replace(A,P) \<subseteq> Replace(B,P)"
 by (blast elim!: ReplaceE)
 
 lemma RepFun_mono: "A<=B \<Longrightarrow> {f(x). x \<in> A} \<subseteq> {f(x). x \<in> B}"
 by blast
 
 lemma Pow_mono: "A<=B \<Longrightarrow> Pow(A) \<subseteq> Pow(B)"
 by blast
 
 lemma Union_mono: "A<=B \<Longrightarrow> \<Union>(A) \<subseteq> \<Union>(B)"
 by blast
 
 lemma UN_mono:
     "\<lbrakk>A<=C;  \<And>x. x \<in> A \<Longrightarrow> B(x)<=D(x)\<rbrakk> \<Longrightarrow> (\<Union>x\<in>A. B(x)) \<subseteq> (\<Union>x\<in>C. D(x))"
 by blast
 
 (*Intersection is ANTI-monotonic.  There are TWO premises! *)
 lemma Inter_anti_mono: "\<lbrakk>A<=B;  A\<noteq>0\<rbrakk> \<Longrightarrow> \<Inter>(B) \<subseteq> \<Inter>(A)"
 by blast
 
 lemma cons_mono: "C<=D \<Longrightarrow> cons(a,C) \<subseteq> cons(a,D)"
 by blast
 
 lemma Un_mono: "\<lbrakk>A<=C;  B<=D\<rbrakk> \<Longrightarrow> A \<union> B \<subseteq> C \<union> D"
 by blast
 
 lemma Int_mono: "\<lbrakk>A<=C;  B<=D\<rbrakk> \<Longrightarrow> A \<inter> B \<subseteq> C \<inter> D"
 by blast
 
 lemma Diff_mono: "\<lbrakk>A<=C;  D<=B\<rbrakk> \<Longrightarrow> A-B \<subseteq> C-D"
 by blast
 
 subsubsection\<open>Standard Products, Sums and Function Spaces\<close>
 
 lemma Sigma_mono [rule_format]:
      "\<lbrakk>A<=C;  \<And>x. x \<in> A \<longrightarrow> B(x) \<subseteq> D(x)\<rbrakk> \<Longrightarrow> Sigma(A,B) \<subseteq> Sigma(C,D)"
 by blast
 
 lemma sum_mono: "\<lbrakk>A<=C;  B<=D\<rbrakk> \<Longrightarrow> A+B \<subseteq> C+D"
 by (unfold sum_def, blast)
 
 (*Note that B->A and C->A are typically disjoint!*)
 lemma Pi_mono: "B<=C \<Longrightarrow> A->B \<subseteq> A->C"
 by (blast intro: lam_type elim: Pi_lamE)
 
 lemma lam_mono: "A<=B \<Longrightarrow> Lambda(A,c) \<subseteq> Lambda(B,c)"
   unfolding lam_def
 apply (erule RepFun_mono)
 done
 
 subsubsection\<open>Converse, Domain, Range, Field\<close>
 
 lemma converse_mono: "r<=s \<Longrightarrow> converse(r) \<subseteq> converse(s)"
 by blast
 
 lemma domain_mono: "r<=s \<Longrightarrow> domain(r)<=domain(s)"
 by blast
 
 lemmas domain_rel_subset = subset_trans [OF domain_mono domain_subset]
 
 lemma range_mono: "r<=s \<Longrightarrow> range(r)<=range(s)"
 by blast
 
 lemmas range_rel_subset = subset_trans [OF range_mono range_subset]
 
 lemma field_mono: "r<=s \<Longrightarrow> field(r)<=field(s)"
 by blast
 
 lemma field_rel_subset: "r \<subseteq> A*A \<Longrightarrow> field(r) \<subseteq> A"
 by (erule field_mono [THEN subset_trans], blast)
 
 
 subsubsection\<open>Images\<close>
 
 lemma image_pair_mono:
     "\<lbrakk>\<And>x y. \<langle>x,y\<rangle>:r \<Longrightarrow> \<langle>x,y\<rangle>:s;  A<=B\<rbrakk> \<Longrightarrow> r``A \<subseteq> s``B"
 by blast
 
 lemma vimage_pair_mono:
     "\<lbrakk>\<And>x y. \<langle>x,y\<rangle>:r \<Longrightarrow> \<langle>x,y\<rangle>:s;  A<=B\<rbrakk> \<Longrightarrow> r-``A \<subseteq> s-``B"
 by blast
 
 lemma image_mono: "\<lbrakk>r<=s;  A<=B\<rbrakk> \<Longrightarrow> r``A \<subseteq> s``B"
 by blast
 
 lemma vimage_mono: "\<lbrakk>r<=s;  A<=B\<rbrakk> \<Longrightarrow> r-``A \<subseteq> s-``B"
 by blast
 
 lemma Collect_mono:
     "\<lbrakk>A<=B;  \<And>x. x \<in> A \<Longrightarrow> P(x) \<longrightarrow> Q(x)\<rbrakk> \<Longrightarrow> Collect(A,P) \<subseteq> Collect(B,Q)"
 by blast
 
 (*Used in intr_elim.ML and in individual datatype definitions*)
 lemmas basic_monos = subset_refl imp_refl disj_mono conj_mono ex_mono
                      Collect_mono Part_mono in_mono
 
 (* Useful with simp; contributed by Clemens Ballarin. *)
 
 lemma bex_image_simp:
   "\<lbrakk>f \<in> Pi(X, Y); A \<subseteq> X\<rbrakk>  \<Longrightarrow> (\<exists>x\<in>f``A. P(x)) \<longleftrightarrow> (\<exists>x\<in>A. P(f`x))"
   apply safe
    apply rule
     prefer 2 apply assumption
    apply (simp add: apply_equality)
   apply (blast intro: apply_Pair)
   done
 
 lemma ball_image_simp:
   "\<lbrakk>f \<in> Pi(X, Y); A \<subseteq> X\<rbrakk>  \<Longrightarrow> (\<forall>x\<in>f``A. P(x)) \<longleftrightarrow> (\<forall>x\<in>A. P(f`x))"
   apply safe
    apply (blast intro: apply_Pair)
   apply (drule bspec) apply assumption
   apply (simp add: apply_equality)
   done
 
 end