(*  Title:      ZF/Constructible/Relative.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section {*Relativization and Absoluteness*}

theory Relative imports Main begin

subsection{* Relativized versions of standard set-theoretic concepts *}

definition
  empty :: "[i=>o,i] => o" where
    "empty(M,z) == \<forall>x[M]. x \<notin> z"

definition
  subset :: "[i=>o,i,i] => o" where
    "subset(M,A,B) == \<forall>x[M]. x\<in>A \<longrightarrow> x \<in> B"

definition
  upair :: "[i=>o,i,i,i] => o" where
    "upair(M,a,b,z) == a \<in> z & b \<in> z & (\<forall>x[M]. x\<in>z \<longrightarrow> x = a | x = b)"

definition
  pair :: "[i=>o,i,i,i] => o" where
    "pair(M,a,b,z) == \<exists>x[M]. upair(M,a,a,x) &
                     (\<exists>y[M]. upair(M,a,b,y) & upair(M,x,y,z))"

definition
  union :: "[i=>o,i,i,i] => o" where
    "union(M,a,b,z) == \<forall>x[M]. x \<in> z \<longleftrightarrow> x \<in> a | x \<in> b"

definition
  is_cons :: "[i=>o,i,i,i] => o" where
    "is_cons(M,a,b,z) == \<exists>x[M]. upair(M,a,a,x) & union(M,x,b,z)"

definition
  successor :: "[i=>o,i,i] => o" where
    "successor(M,a,z) == is_cons(M,a,a,z)"

definition
  number1 :: "[i=>o,i] => o" where
    "number1(M,a) == \<exists>x[M]. empty(M,x) & successor(M,x,a)"

definition
  number2 :: "[i=>o,i] => o" where
    "number2(M,a) == \<exists>x[M]. number1(M,x) & successor(M,x,a)"

definition
  number3 :: "[i=>o,i] => o" where
    "number3(M,a) == \<exists>x[M]. number2(M,x) & successor(M,x,a)"

definition
  powerset :: "[i=>o,i,i] => o" where
    "powerset(M,A,z) == \<forall>x[M]. x \<in> z \<longleftrightarrow> subset(M,x,A)"

definition
  is_Collect :: "[i=>o,i,i=>o,i] => o" where
    "is_Collect(M,A,P,z) == \<forall>x[M]. x \<in> z \<longleftrightarrow> x \<in> A & P(x)"

definition
  is_Replace :: "[i=>o,i,[i,i]=>o,i] => o" where
    "is_Replace(M,A,P,z) == \<forall>u[M]. u \<in> z \<longleftrightarrow> (\<exists>x[M]. x\<in>A & P(x,u))"

definition
  inter :: "[i=>o,i,i,i] => o" where
    "inter(M,a,b,z) == \<forall>x[M]. x \<in> z \<longleftrightarrow> x \<in> a & x \<in> b"

definition
  setdiff :: "[i=>o,i,i,i] => o" where
    "setdiff(M,a,b,z) == \<forall>x[M]. x \<in> z \<longleftrightarrow> x \<in> a & x \<notin> b"

definition
  big_union :: "[i=>o,i,i] => o" where
    "big_union(M,A,z) == \<forall>x[M]. x \<in> z \<longleftrightarrow> (\<exists>y[M]. y\<in>A & x \<in> y)"

definition
  big_inter :: "[i=>o,i,i] => o" where
    "big_inter(M,A,z) ==
             (A=0 \<longrightarrow> z=0) &
             (A\<noteq>0 \<longrightarrow> (\<forall>x[M]. x \<in> z \<longleftrightarrow> (\<forall>y[M]. y\<in>A \<longrightarrow> x \<in> y)))"

definition
  cartprod :: "[i=>o,i,i,i] => o" where
    "cartprod(M,A,B,z) ==
        \<forall>u[M]. u \<in> z \<longleftrightarrow> (\<exists>x[M]. x\<in>A & (\<exists>y[M]. y\<in>B & pair(M,x,y,u)))"

definition
  is_sum :: "[i=>o,i,i,i] => o" where
    "is_sum(M,A,B,Z) ==
       \<exists>A0[M]. \<exists>n1[M]. \<exists>s1[M]. \<exists>B1[M].
       number1(M,n1) & cartprod(M,n1,A,A0) & upair(M,n1,n1,s1) &
       cartprod(M,s1,B,B1) & union(M,A0,B1,Z)"

definition
  is_Inl :: "[i=>o,i,i] => o" where
    "is_Inl(M,a,z) == \<exists>zero[M]. empty(M,zero) & pair(M,zero,a,z)"

definition
  is_Inr :: "[i=>o,i,i] => o" where
    "is_Inr(M,a,z) == \<exists>n1[M]. number1(M,n1) & pair(M,n1,a,z)"

definition
  is_converse :: "[i=>o,i,i] => o" where
    "is_converse(M,r,z) ==
        \<forall>x[M]. x \<in> z \<longleftrightarrow>
             (\<exists>w[M]. w\<in>r & (\<exists>u[M]. \<exists>v[M]. pair(M,u,v,w) & pair(M,v,u,x)))"

definition
  pre_image :: "[i=>o,i,i,i] => o" where
    "pre_image(M,r,A,z) ==
        \<forall>x[M]. x \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r & (\<exists>y[M]. y\<in>A & pair(M,x,y,w)))"

definition
  is_domain :: "[i=>o,i,i] => o" where
    "is_domain(M,r,z) ==
        \<forall>x[M]. x \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r & (\<exists>y[M]. pair(M,x,y,w)))"

definition
  image :: "[i=>o,i,i,i] => o" where
    "image(M,r,A,z) ==
        \<forall>y[M]. y \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r & (\<exists>x[M]. x\<in>A & pair(M,x,y,w)))"

definition
  is_range :: "[i=>o,i,i] => o" where
    --{*the cleaner
      @{term "\<exists>r'[M]. is_converse(M,r,r') & is_domain(M,r',z)"}
      unfortunately needs an instance of separation in order to prove
        @{term "M(converse(r))"}.*}
    "is_range(M,r,z) ==
        \<forall>y[M]. y \<in> z \<longleftrightarrow> (\<exists>w[M]. w\<in>r & (\<exists>x[M]. pair(M,x,y,w)))"

definition
  is_field :: "[i=>o,i,i] => o" where
    "is_field(M,r,z) ==
        \<exists>dr[M]. \<exists>rr[M]. is_domain(M,r,dr) & is_range(M,r,rr) &
                        union(M,dr,rr,z)"

definition
  is_relation :: "[i=>o,i] => o" where
    "is_relation(M,r) ==
        (\<forall>z[M]. z\<in>r \<longrightarrow> (\<exists>x[M]. \<exists>y[M]. pair(M,x,y,z)))"

definition
  is_function :: "[i=>o,i] => o" where
    "is_function(M,r) ==
        \<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=>o,i,i,i] => o" where
    "fun_apply(M,f,x,y) ==
        (\<exists>xs[M]. \<exists>fxs[M].
         upair(M,x,x,xs) & image(M,f,xs,fxs) & big_union(M,fxs,y))"

definition
  typed_function :: "[i=>o,i,i,i] => o" where
    "typed_function(M,A,B,r) ==
        is_function(M,r) & is_relation(M,r) & is_domain(M,r,A) &
        (\<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=>o,i,i,i] => o" where
    "is_funspace(M,A,B,F) ==
        \<forall>f[M]. f \<in> F \<longleftrightarrow> typed_function(M,A,B,f)"

definition
  composition :: "[i=>o,i,i,i] => o" where
    "composition(M,r,s,t) ==
        \<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) & pair(M,x,y,xy) & pair(M,y,z,yz) &
                xy \<in> s & yz \<in> r)"

definition
  injection :: "[i=>o,i,i,i] => o" where
    "injection(M,A,B,f) ==
        typed_function(M,A,B,f) &
        (\<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=>o,i,i,i] => o" where
    "surjection(M,A,B,f) ==
        typed_function(M,A,B,f) &
        (\<forall>y[M]. y\<in>B \<longrightarrow> (\<exists>x[M]. x\<in>A & fun_apply(M,f,x,y)))"

definition
  bijection :: "[i=>o,i,i,i] => o" where
    "bijection(M,A,B,f) == injection(M,A,B,f) & surjection(M,A,B,f)"

definition
  restriction :: "[i=>o,i,i,i] => o" where
    "restriction(M,r,A,z) ==
        \<forall>x[M]. x \<in> z \<longleftrightarrow> (x \<in> r & (\<exists>u[M]. u\<in>A & (\<exists>v[M]. pair(M,u,v,x))))"

definition
  transitive_set :: "[i=>o,i] => o" where
    "transitive_set(M,a) == \<forall>x[M]. x\<in>a \<longrightarrow> subset(M,x,a)"

definition
  ordinal :: "[i=>o,i] => o" where
     --{*an ordinal is a transitive set of transitive sets*}
    "ordinal(M,a) == transitive_set(M,a) & (\<forall>x[M]. x\<in>a \<longrightarrow> transitive_set(M,x))"

definition
  limit_ordinal :: "[i=>o,i] => o" where
    --{*a limit ordinal is a non-empty, successor-closed ordinal*}
    "limit_ordinal(M,a) ==
        ordinal(M,a) & ~ empty(M,a) &
        (\<forall>x[M]. x\<in>a \<longrightarrow> (\<exists>y[M]. y\<in>a & successor(M,x,y)))"

definition
  successor_ordinal :: "[i=>o,i] => o" where
    --{*a successor ordinal is any ordinal that is neither empty nor limit*}
    "successor_ordinal(M,a) ==
        ordinal(M,a) & ~ empty(M,a) & ~ limit_ordinal(M,a)"

definition
  finite_ordinal :: "[i=>o,i] => o" where
    --{*an ordinal is finite if neither it nor any of its elements are limit*}
    "finite_ordinal(M,a) ==
        ordinal(M,a) & ~ limit_ordinal(M,a) &
        (\<forall>x[M]. x\<in>a \<longrightarrow> ~ limit_ordinal(M,x))"

definition
  omega :: "[i=>o,i] => o" where
    --{*omega is a limit ordinal none of whose elements are limit*}
    "omega(M,a) == limit_ordinal(M,a) & (\<forall>x[M]. x\<in>a \<longrightarrow> ~ limit_ordinal(M,x))"

definition
  is_quasinat :: "[i=>o,i] => o" where
    "is_quasinat(M,z) == empty(M,z) | (\<exists>m[M]. successor(M,m,z))"

definition
  is_nat_case :: "[i=>o, i, [i,i]=>o, i, i] => o" where
    "is_nat_case(M, a, is_b, k, z) ==
       (empty(M,k) \<longrightarrow> z=a) &
       (\<forall>m[M]. successor(M,m,k) \<longrightarrow> is_b(m,z)) &
       (is_quasinat(M,k) | empty(M,z))"

definition
  relation1 :: "[i=>o, [i,i]=>o, i=>i] => o" where
    "relation1(M,is_f,f) == \<forall>x[M]. \<forall>y[M]. is_f(x,y) \<longleftrightarrow> y = f(x)"

definition
  Relation1 :: "[i=>o, i, [i,i]=>o, i=>i] => o" where
    --{*as above, but typed*}
    "Relation1(M,A,is_f,f) ==
        \<forall>x[M]. \<forall>y[M]. x\<in>A \<longrightarrow> is_f(x,y) \<longleftrightarrow> y = f(x)"

definition
  relation2 :: "[i=>o, [i,i,i]=>o, [i,i]=>i] => o" where
    "relation2(M,is_f,f) == \<forall>x[M]. \<forall>y[M]. \<forall>z[M]. is_f(x,y,z) \<longleftrightarrow> z = f(x,y)"

definition
  Relation2 :: "[i=>o, i, i, [i,i,i]=>o, [i,i]=>i] => o" where
    "Relation2(M,A,B,is_f,f) ==
        \<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=>o, [i,i,i,i]=>o, [i,i,i]=>i] => o" where
    "relation3(M,is_f,f) ==
       \<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=>o, i, i, i, [i,i,i,i]=>o, [i,i,i]=>i] => o" where
    "Relation3(M,A,B,C,is_f,f) ==
       \<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=>o, [i,i,i,i,i]=>o, [i,i,i,i]=>i] => o" where
    "relation4(M,is_f,f) ==
       \<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{*Useful when absoluteness reasoning has replaced the predicates by terms*}
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 {*The relativized ZF axioms*}

definition
  extensionality :: "(i=>o) => o" where
    "extensionality(M) ==
        \<forall>x[M]. \<forall>y[M]. (\<forall>z[M]. z \<in> x \<longleftrightarrow> z \<in> y) \<longrightarrow> x=y"

definition
  separation :: "[i=>o, i=>o] => o" where
    --{*The formula @{text P} should only involve parameters
        belonging to @{text M} and all its quantifiers must be relativized
        to @{text M}.  We do not have separation as a scheme; every instance
        that we need must be assumed (and later proved) separately.*}
    "separation(M,P) ==
        \<forall>z[M]. \<exists>y[M]. \<forall>x[M]. x \<in> y \<longleftrightarrow> x \<in> z & P(x)"

definition
  upair_ax :: "(i=>o) => o" where
    "upair_ax(M) == \<forall>x[M]. \<forall>y[M]. \<exists>z[M]. upair(M,x,y,z)"

definition
  Union_ax :: "(i=>o) => o" where
    "Union_ax(M) == \<forall>x[M]. \<exists>z[M]. big_union(M,x,z)"

definition
  power_ax :: "(i=>o) => o" where
    "power_ax(M) == \<forall>x[M]. \<exists>z[M]. powerset(M,x,z)"

definition
  univalent :: "[i=>o, i, [i,i]=>o] => o" where
    "univalent(M,A,P) ==
        \<forall>x[M]. x\<in>A \<longrightarrow> (\<forall>y[M]. \<forall>z[M]. P(x,y) & P(x,z) \<longrightarrow> y=z)"

definition
  replacement :: "[i=>o, [i,i]=>o] => o" where
    "replacement(M,P) ==
      \<forall>A[M]. univalent(M,A,P) \<longrightarrow>
      (\<exists>Y[M]. \<forall>b[M]. (\<exists>x[M]. x\<in>A & P(x,b)) \<longrightarrow> b \<in> Y)"

definition
  strong_replacement :: "[i=>o, [i,i]=>o] => o" where
    "strong_replacement(M,P) ==
      \<forall>A[M]. univalent(M,A,P) \<longrightarrow>
      (\<exists>Y[M]. \<forall>b[M]. b \<in> Y \<longleftrightarrow> (\<exists>x[M]. x\<in>A & P(x,b)))"

definition
  foundation_ax :: "(i=>o) => o" where
    "foundation_ax(M) ==
        \<forall>x[M]. (\<exists>y[M]. y\<in>x) \<longrightarrow> (\<exists>y[M]. y\<in>x & ~(\<exists>z[M]. z\<in>x & z \<in> y))"

subsection{*A trivial consistency proof for $V_\omega$ *}

text{*We prove that $V_\omega$
      (or @{text univ} in Isabelle) satisfies some ZF axioms.
     Kunen, Theorem IV 3.13, page 123.*}

lemma univ0_downwards_mem: "[| y \<in> x; x \<in> univ(0) |] ==> 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) ==> (\<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) ==> (\<exists>x\<in>A. x \<in> univ(0) & P(x)) \<longleftrightarrow> (\<exists>x\<in>A. P(x))"
by (blast intro: univ0_downwards_mem)

text{*Congruence rule for separation: can assume the variable is in @{text M}*}
lemma separation_cong [cong]:
     "(!!x. M(x) ==> P(x) \<longleftrightarrow> P'(x))
      ==> separation(M, %x. P(x)) \<longleftrightarrow> separation(M, %x. P'(x))"
by (simp add: separation_def)

lemma univalent_cong [cong]:
     "[| A=A'; !!x y. [| x\<in>A; M(x); M(y) |] ==> P(x,y) \<longleftrightarrow> P'(x,y) |]
      ==> univalent(M, A, %x y. P(x,y)) \<longleftrightarrow> univalent(M, A', %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) ==> univalent(M, A, \<lambda>x y. P(x,y) & Q(x,y))"
by (simp add: univalent_def, blast)

text{*Congruence rule for replacement*}
lemma strong_replacement_cong [cong]:
     "[| !!x y. [| M(x); M(y) |] ==> P(x,y) \<longleftrightarrow> P'(x,y) |]
      ==> strong_replacement(M, %x y. P(x,y)) \<longleftrightarrow>
          strong_replacement(M, %x y. P'(x,y))"
by (simp add: strong_replacement_def)

text{*The extensionality axiom*}
lemma "extensionality(\<lambda>x. x \<in> univ(0))"
apply (simp add: extensionality_def)
apply (blast intro: univ0_downwards_mem)
done

text{*The separation axiom requires some lemmas*}
lemma Collect_in_Vfrom:
     "[| X \<in> Vfrom(A,j);  Transset(A) |] ==> 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:
     "[| X \<in> Vfrom(A,i);  Limit(i);  Transset(A) |]
      ==> 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:
     "[| X \<in> univ(A);  Transset(A) |] ==> Collect(X,P) \<in> univ(A)"
by (simp add: univ_def Collect_in_VLimit Limit_nat)

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{*Unordered pairing axiom*}
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{*Union axiom*}
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{*Powerset axiom*}

lemma Pow_in_univ:
     "[| X \<in> univ(A);  Transset(A) |] ==> Pow(X) \<in> univ(A)"
apply (simp add: univ_def Pow_in_VLimit Limit_nat)
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{*Foundation axiom*}
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{*no idea: maybe prove by induction on the rank of A?*}

text{*Still missing: Replacement, Choice*}

subsection{*Lemmas Needed to Reduce Some Set Constructions to Instances
      of Separation*}

lemma image_iff_Collect: "r `` A = {y \<in> \<Union>(\<Union>(r)). \<exists>p\<in>r. \<exists>x\<in>A. p=<x,y>}"
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=<x,y>}"
apply (rule equalityI, auto)
apply (simp add: Pair_def, blast)
done

text{*These two lemmas lets us prove @{text domain_closed} and
      @{text range_closed} without new instances of separation*}

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:
    "[| replacement(M,P); M(A);  univalent(M,A,P) |]
     ==> \<exists>Y[M]. (\<forall>b[M]. ((\<exists>x[M]. x\<in>A & P(x,b)) \<longrightarrow> b \<in> Y))"
by (simp add: replacement_def)

lemma strong_replacementD:
    "[| strong_replacement(M,P); M(A);  univalent(M,A,P) |]
     ==> \<exists>Y[M]. (\<forall>b[M]. (b \<in> Y \<longleftrightarrow> (\<exists>x[M]. x\<in>A & P(x,b))))"
by (simp add: strong_replacement_def)

lemma separationD:
    "[| separation(M,P); M(z) |] ==> \<exists>y[M]. \<forall>x[M]. x \<in> y \<longleftrightarrow> x \<in> z & P(x)"
by (simp add: separation_def)

text{*More constants, for order types*}

definition
  order_isomorphism :: "[i=>o,i,i,i,i,i] => o" where
    "order_isomorphism(M,A,r,B,s,f) ==
        bijection(M,A,B,f) &
        (\<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=>o,i,i,i,i] => o" where
    "pred_set(M,A,x,r,B) ==
        \<forall>y[M]. y \<in> B \<longleftrightarrow> (\<exists>p[M]. p\<in>r & y \<in> A & pair(M,y,x,p))"

definition
  membership :: "[i=>o,i,i] => o" where --{*membership relation*}
    "membership(M,A,r) ==
        \<forall>p[M]. p \<in> r \<longleftrightarrow> (\<exists>x[M]. x\<in>A & (\<exists>y[M]. y\<in>A & x\<in>y & pair(M,x,y,p)))"

subsection{*Introducing a Transitive Class Model*}

text{*The class M is assumed to be transitive and to satisfy some
      relativized ZF axioms*}
locale M_trivial =
  fixes M
  assumes transM:           "[| y\<in>x; M(x) |] ==> M(y)"
      and upair_ax:         "upair_ax(M)"
      and Union_ax:         "Union_ax(M)"
      and power_ax:         "power_ax(M)"
      and replacement:      "replacement(M,P)"
      and M_nat [iff]:      "M(nat)"           (*i.e. the axiom of infinity*)

text{*Automatically discovers the proof using @{text transM}, @{text nat_0I}
and @{text M_nat}.*}
lemma (in M_trivial) nonempty [simp]: "M(0)"
by (blast intro: transM)

lemma (in M_trivial) rall_abs [simp]:
     "M(A) ==> (\<forall>x[M]. x\<in>A \<longrightarrow> P(x)) \<longleftrightarrow> (\<forall>x\<in>A. P(x))"
by (blast intro: transM)

lemma (in M_trivial) rex_abs [simp]:
     "M(A) ==> (\<exists>x[M]. x\<in>A & P(x)) \<longleftrightarrow> (\<exists>x\<in>A. P(x))"
by (blast intro: transM)

lemma (in M_trivial) ball_iff_equiv:
     "M(A) ==> (\<forall>x[M]. (x\<in>A \<longleftrightarrow> P(x))) \<longleftrightarrow>
               (\<forall>x\<in>A. P(x)) & (\<forall>x. P(x) \<longrightarrow> M(x) \<longrightarrow> x\<in>A)"
by (blast intro: transM)

text{*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 "M(A)"} and  @{term "M(B)"} can be too strong.*}
lemma (in M_trivial) M_equalityI:
     "[| !!x. M(x) ==> x\<in>A \<longleftrightarrow> x\<in>B; M(A); M(B) |] ==> A=B"
by (blast intro!: equalityI dest: transM)

subsubsection{*Trivial Absoluteness Proofs: Empty Set, Pairs, etc.*}

lemma (in M_trivial) empty_abs [simp]:
     "M(z) ==> empty(M,z) \<longleftrightarrow> z=0"
apply (simp add: empty_def)
apply (blast intro: transM)
done

lemma (in M_trivial) subset_abs [simp]:
     "M(A) ==> subset(M,A,B) \<longleftrightarrow> A \<subseteq> B"
apply (simp add: subset_def)
apply (blast intro: transM)
done

lemma (in M_trivial) upair_abs [simp]:
     "M(z) ==> 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_M_iff [iff]:
     "M({a,b}) \<longleftrightarrow> M(a) & M(b)"
apply (insert upair_ax, simp add: upair_ax_def)
apply (blast intro: transM)
done

lemma (in M_trivial) singleton_in_M_iff [iff]:
     "M({a}) \<longleftrightarrow> M(a)"
by (insert upair_in_M_iff [of a a], simp)

lemma (in M_trivial) pair_abs [simp]:
     "M(z) ==> pair(M,a,b,z) \<longleftrightarrow> z=<a,b>"
apply (simp add: pair_def ZF.Pair_def)
apply (blast intro: transM)
done

lemma (in M_trivial) pair_in_M_iff [iff]:
     "M(<a,b>) \<longleftrightarrow> M(a) & M(b)"
by (simp add: ZF.Pair_def)

lemma (in M_trivial) pair_components_in_M:
     "[| <x,y> \<in> A; M(A) |] ==> M(x) & M(y)"
apply (simp add: Pair_def)
apply (blast dest: transM)
done

lemma (in M_trivial) cartprod_abs [simp]:
     "[| M(A); M(B); M(z) |] ==> 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{*Absoluteness for Unions and Intersections*}

lemma (in M_trivial) union_abs [simp]:
     "[| M(a); M(b); M(z) |] ==> union(M,a,b,z) \<longleftrightarrow> z = a \<union> b"
apply (simp add: union_def)
apply (blast intro: transM)
done

lemma (in M_trivial) inter_abs [simp]:
     "[| M(a); M(b); M(z) |] ==> inter(M,a,b,z) \<longleftrightarrow> z = a \<inter> b"
apply (simp add: inter_def)
apply (blast intro: transM)
done

lemma (in M_trivial) setdiff_abs [simp]:
     "[| M(a); M(b); M(z) |] ==> setdiff(M,a,b,z) \<longleftrightarrow> z = a-b"
apply (simp add: setdiff_def)
apply (blast intro: transM)
done

lemma (in M_trivial) Union_abs [simp]:
     "[| M(A); M(z) |] ==> big_union(M,A,z) \<longleftrightarrow> z = \<Union>(A)"
apply (simp add: big_union_def)
apply (blast intro!: equalityI dest: transM)
done

lemma (in M_trivial) Union_closed [intro,simp]:
     "M(A) ==> M(\<Union>(A))"
by (insert Union_ax, simp add: Union_ax_def)

lemma (in M_trivial) Un_closed [intro,simp]:
     "[| M(A); M(B) |] ==> M(A \<union> B)"
by (simp only: Un_eq_Union, blast)

lemma (in M_trivial) cons_closed [intro,simp]:
     "[| M(a); M(A) |] ==> M(cons(a,A))"
by (subst cons_eq [symmetric], blast)

lemma (in M_trivial) cons_abs [simp]:
     "[| M(b); M(z) |] ==> 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]:
     "[| M(a); M(z) |] ==> successor(M,a,z) \<longleftrightarrow> z = succ(a)"
by (simp add: successor_def, blast)

lemma (in M_trivial) succ_in_M_iff [iff]:
     "M(succ(a)) \<longleftrightarrow> M(a)"
apply (simp add: succ_def)
apply (blast intro: transM)
done

subsubsection{*Absoluteness for Separation and Replacement*}

lemma (in M_trivial) separation_closed [intro,simp]:
     "[| separation(M,P); M(A) |] ==> 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_trivial) Collect_abs [simp]:
     "[| M(A); M(z) |] ==> is_Collect(M,A,P,z) \<longleftrightarrow> z = Collect(A,P)"
apply (simp add: is_Collect_def)
apply (blast intro!: equalityI dest: transM)
done

text{*Probably the premise and conclusion are equivalent*}
lemma (in M_trivial) strong_replacementI [rule_format]:
    "[| \<forall>B[M]. separation(M, %u. \<exists>x[M]. x\<in>B & P(x,u)) |]
     ==> strong_replacement(M,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

subsubsection{*The Operator @{term is_Replace}*}

lemma is_Replace_cong [cong]:
     "[| A=A';
         !!x y. [| M(x); M(y) |] ==> P(x,y) \<longleftrightarrow> P'(x,y);
         z=z' |]
      ==> is_Replace(M, A, %x y. P(x,y), z) \<longleftrightarrow>
          is_Replace(M, A', %x y. P'(x,y), z')"
by (simp add: is_Replace_def)

lemma (in M_trivial) univalent_Replace_iff:
     "[| M(A); univalent(M,A,P);
         !!x y. [| x\<in>A; P(x,y) |] ==> M(y) |]
      ==> u \<in> Replace(A,P) \<longleftrightarrow> (\<exists>x. x\<in>A & P(x,u))"
apply (simp add: Replace_iff univalent_def)
apply (blast dest: transM)
done

(*The last premise expresses that P takes M to M*)
lemma (in M_trivial) strong_replacement_closed [intro,simp]:
     "[| strong_replacement(M,P); M(A); univalent(M,A,P);
         !!x y. [| x\<in>A; P(x,y) |] ==> M(y) |] ==> 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_trivial) Replace_abs:
     "[| M(A); M(z); univalent(M,A,P);
         !!x y. [| x\<in>A; P(x,y) |] ==> M(y)  |]
      ==> 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_trivial) RepFun_closed:
     "[| strong_replacement(M, \<lambda>x y. y = f(x)); M(A); \<forall>x\<in>A. M(f(x)) |]
      ==> M(RepFun(A,f))"
apply (simp add: RepFun_def)
done

lemma Replace_conj_eq: "{y . x \<in> A, x\<in>A & y=f(x)} = {y . x\<in>A, y=f(x)}"
by simp

text{*Better than @{text RepFun_closed} when having the formula @{term "x\<in>A"}
      makes relativization easier.*}
lemma (in M_trivial) RepFun_closed2:
     "[| strong_replacement(M, \<lambda>x y. x\<in>A & y = f(x)); M(A); \<forall>x\<in>A. M(f(x)) |]
      ==> M(RepFun(A, %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 {*Absoluteness for @{term Lambda}*}

definition
 is_lambda :: "[i=>o, i, [i,i]=>o, i] => o" where
    "is_lambda(M, A, is_b, z) ==
       \<forall>p[M]. p \<in> z \<longleftrightarrow>
        (\<exists>u[M]. \<exists>v[M]. u\<in>A & pair(M,u,v,p) & is_b(u,v))"

lemma (in M_trivial) lam_closed:
     "[| strong_replacement(M, \<lambda>x y. y = <x,b(x)>); M(A); \<forall>x\<in>A. M(b(x)) |]
      ==> M(\<lambda>x\<in>A. b(x))"
by (simp add: lam_def, blast intro: RepFun_closed dest: transM)

text{*Better than @{text lam_closed}: has the formula @{term "x\<in>A"}*}
lemma (in M_trivial) lam_closed2:
  "[|strong_replacement(M, \<lambda>x y. x\<in>A & y = \<langle>x, b(x)\<rangle>);
     M(A); \<forall>m[M]. m\<in>A \<longrightarrow> M(b(m))|] ==> M(Lambda(A,b))"
apply (simp add: lam_def)
apply (blast intro: RepFun_closed2 dest: transM)
done

lemma (in M_trivial) lambda_abs2:
     "[| Relation1(M,A,is_b,b); M(A); \<forall>m[M]. m\<in>A \<longrightarrow> M(b(m)); M(z) |]
      ==> 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]:
     "[| A=A';  z=z';
         !!x y. [| x\<in>A; M(x); M(y) |] ==> is_b(x,y) \<longleftrightarrow> is_b'(x,y) |]
      ==> is_lambda(M, A, %x y. is_b(x,y), z) \<longleftrightarrow>
          is_lambda(M, A', %x y. is_b'(x,y), z')"
by (simp add: is_lambda_def)

lemma (in M_trivial) image_abs [simp]:
     "[| M(r); M(A); M(z) |] ==> 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

text{*What about @{text Pow_abs}?  Powerset is NOT absolute!
      This result is one direction of absoluteness.*}

lemma (in M_trivial) powerset_Pow:
     "powerset(M, x, Pow(x))"
by (simp add: powerset_def)

text{*But we can't prove that the powerset in @{text M} includes the
      real powerset.*}
lemma (in M_trivial) powerset_imp_subset_Pow:
     "[| powerset(M,x,y); M(y) |] ==> y \<subseteq> Pow(x)"
apply (simp add: powerset_def)
apply (blast dest: transM)
done

subsubsection{*Absoluteness for the Natural Numbers*}

lemma (in M_trivial) nat_into_M [intro]:
     "n \<in> nat ==> M(n)"
by (induct n rule: nat_induct, simp_all)

lemma (in M_trivial) nat_case_closed [intro,simp]:
  "[|M(k); M(a); \<forall>m[M]. M(b(m))|] ==> 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) ==> is_quasinat(M,z) \<longleftrightarrow> quasinat(z)"
by (auto simp add: is_quasinat_def quasinat_def)

lemma (in M_trivial) nat_case_abs [simp]:
     "[| relation1(M,is_b,b); M(k); M(z) |]
      ==> 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:
     "[| a = a'; k = k';  z = z';  M(z');
       !!x y. [| M(x); M(y) |] ==> is_b(x,y) \<longleftrightarrow> is_b'(x,y) |]
      ==> 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{*Absoluteness for Ordinals*}
text{*These results constitute Theorem IV 5.1 of Kunen (page 126).*}

lemma (in M_trivial) lt_closed:
     "[| j<i; M(i) |] ==> M(j)"
by (blast dest: ltD intro: transM)

lemma (in M_trivial) transitive_set_abs [simp]:
     "M(a) ==> transitive_set(M,a) \<longleftrightarrow> Transset(a)"
by (simp add: transitive_set_def Transset_def)

lemma (in M_trivial) ordinal_abs [simp]:
     "M(a) ==> ordinal(M,a) \<longleftrightarrow> Ord(a)"
by (simp add: ordinal_def Ord_def)

lemma (in M_trivial) limit_ordinal_abs [simp]:
     "M(a) ==> limit_ordinal(M,a) \<longleftrightarrow> Limit(a)"
apply (unfold 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) ==> successor_ordinal(M,a) \<longleftrightarrow> Ord(a) & (\<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:
      "[| Ord(a); ~ Limit(a); \<forall>x\<in>a. ~ Limit(x) |] ==> a \<in> nat"
by (induct a rule: trans_induct3, simp_all)

lemma (in M_trivial) finite_ordinal_abs [simp]:
     "M(a) ==> 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:
     "[| Limit(a); \<forall>x\<in>a. ~ Limit(x) |] ==> 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) ==> 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) ==> number1(M,a) \<longleftrightarrow> a = 1"
by (simp add: number1_def)

lemma (in M_trivial) number2_abs [simp]:
     "M(a) ==> number2(M,a) \<longleftrightarrow> a = succ(1)"
by (simp add: number2_def)

lemma (in M_trivial) number3_abs [simp]:
     "M(a) ==> number3(M,a) \<longleftrightarrow> a = succ(succ(1))"
by (simp add: number3_def)

text{*Kunen continued to 20...*}

(*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=>o,i] => 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 & successor(M,y,x))
                     then 1 else 0)"

  definition
    natnumber :: "[i=>o,i,i] => o"
      "natnumber(M,n,x) == natnumber_aux(M,n)`x = 1"

  lemma (in M_trivial) [simp]:
       "natnumber(M,0,x) == x=0"
*)

subsection{*Some instances of separation and strong replacement*}

locale M_basic = M_trivial +
assumes Inter_separation:
     "M(A) ==> separation(M, \<lambda>x. \<forall>y[M]. y\<in>A \<longrightarrow> x\<in>y)"
  and Diff_separation:
     "M(B) ==> separation(M, \<lambda>x. x \<notin> B)"
  and cartprod_separation:
     "[| M(A); M(B) |]
      ==> separation(M, \<lambda>z. \<exists>x[M]. x\<in>A & (\<exists>y[M]. y\<in>B & pair(M,x,y,z)))"
  and image_separation:
     "[| M(A); M(r) |]
      ==> separation(M, \<lambda>y. \<exists>p[M]. p\<in>r & (\<exists>x[M]. x\<in>A & pair(M,x,y,p)))"
  and converse_separation:
     "M(r) ==> separation(M,
         \<lambda>z. \<exists>p[M]. p\<in>r & (\<exists>x[M]. \<exists>y[M]. pair(M,x,y,p) & pair(M,y,x,z)))"
  and restrict_separation:
     "M(A) ==> separation(M, \<lambda>z. \<exists>x[M]. x\<in>A & (\<exists>y[M]. pair(M,x,y,z)))"
  and comp_separation:
     "[| M(r); M(s) |]
      ==> separation(M, \<lambda>xz. \<exists>x[M]. \<exists>y[M]. \<exists>z[M]. \<exists>xy[M]. \<exists>yz[M].
                  pair(M,x,z,xz) & pair(M,x,y,xy) & pair(M,y,z,yz) &
                  xy\<in>s & yz\<in>r)"
  and pred_separation:
     "[| M(r); M(x) |] ==> separation(M, \<lambda>y. \<exists>p[M]. p\<in>r & pair(M,y,x,p))"
  and Memrel_separation:
     "separation(M, \<lambda>z. \<exists>x[M]. \<exists>y[M]. pair(M,x,y,z) & x \<in> y)"
  and funspace_succ_replacement:
     "M(n) ==>
      strong_replacement(M, \<lambda>p z. \<exists>f[M]. \<exists>b[M]. \<exists>nb[M]. \<exists>cnbf[M].
                pair(M,f,b,p) & pair(M,n,b,nb) & is_cons(M,nb,f,cnbf) &
                upair(M,cnbf,cnbf,z))"
  and is_recfun_separation:
     --{*for well-founded recursion: used to prove @{text is_recfun_equal}*}
     "[| M(r); M(f); M(g); M(a); M(b) |]
     ==> separation(M,
            \<lambda>x. \<exists>xa[M]. \<exists>xb[M].
                pair(M,x,a,xa) & xa \<in> r & pair(M,x,b,xb) & xb \<in> r &
                (\<exists>fx[M]. \<exists>gx[M]. fun_apply(M,f,x,fx) & fun_apply(M,g,x,gx) &
                                   fx \<noteq> gx))"

lemma (in M_basic) cartprod_iff_lemma:
     "[| 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) |]
       ==> 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:
     "[| M(A); M(B); M(C) |]
      ==> cartprod(M,A,B,C) \<longleftrightarrow>
          (\<exists>p1[M]. \<exists>p2[M]. powerset(M,A \<union> B,p1) & powerset(M,p1,p2) &
                   C = {z \<in> p2. \<exists>x\<in>A. \<exists>y\<in>B. z = <x,y>})"
apply (simp add: Pair_def cartprod_def, safe)
defer 1
  apply (simp add: powerset_def)
 apply blast
txt{*Final, difficult case: the left-to-right direction of the theorem.*}
apply (insert power_ax, simp add: power_ax_def)
apply (frule_tac x="A \<union> B" and P="\<lambda>x. rex(M,?Q(x))" in rspec)
apply (blast, clarify)
apply (drule_tac x=z and P="\<lambda>x. rex(M,?Q(x))" in rspec)
apply assumption
apply (blast intro: cartprod_iff_lemma)
done

lemma (in M_basic) cartprod_closed_lemma:
     "[| M(A); M(B) |] ==> \<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))" in rspec)
apply (blast, clarify)
apply (drule_tac x=z and P="\<lambda>x. rex(M,?Q(x))" in rspec, auto)
apply (intro rexI conjI, simp+)
apply (insert cartprod_separation [of A B], simp)
done

text{*All the lemmas above are necessary because Powerset is not absolute.
      I should have used Replacement instead!*}
lemma (in M_basic) cartprod_closed [intro,simp]:
     "[| M(A); M(B) |] ==> M(A*B)"
by (frule cartprod_closed_lemma, assumption, force)

lemma (in M_basic) sum_closed [intro,simp]:
     "[| M(A); M(B) |] ==> M(A+B)"
by (simp add: sum_def)

lemma (in M_basic) sum_abs [simp]:
     "[| M(A); M(B); M(Z) |] ==> 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) ==> 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) ==> is_Inr(M,a,Z) \<longleftrightarrow> (Z = Inr(a))"
by (simp add: is_Inr_def Inr_def)

subsubsection {*converse of a relation*}

lemma (in M_basic) M_converse_iff:
     "M(r) ==>
      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> & 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) ==> M(converse(r))"
apply (simp add: M_converse_iff)
apply (insert converse_separation [of r], simp)
done

lemma (in M_basic) converse_abs [simp]:
     "[| M(r); M(z) |] ==> 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 {*image, preimage, domain, range*}

lemma (in M_basic) image_closed [intro,simp]:
     "[| M(A); M(r) |] ==> 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]:
     "[| M(r); M(A); M(z) |] ==> 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]:
     "[| M(A); M(r) |] ==> M(r-``A)"
by (simp add: vimage_def)

subsubsection{*Domain, range and field*}

lemma (in M_basic) domain_abs [simp]:
     "[| M(r); M(z) |] ==> 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) ==> M(domain(r))"
apply (simp add: domain_eq_vimage)
done

lemma (in M_basic) range_abs [simp]:
     "[| M(r); M(z) |] ==> 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) ==> M(range(r))"
apply (simp add: range_eq_image)
done

lemma (in M_basic) field_abs [simp]:
     "[| M(r); M(z) |] ==> is_field(M,r,z) \<longleftrightarrow> z = field(r)"
by (simp add: domain_closed range_closed is_field_def field_def)

lemma (in M_basic) field_closed [intro,simp]:
     "M(r) ==> M(field(r))"
by (simp add: domain_closed range_closed Un_closed field_def)

subsubsection{*Relations, functions and application*}

lemma (in M_basic) relation_abs [simp]:
     "M(r) ==> 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_basic) function_abs [simp]:
     "M(r) ==> 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]:
     "[|M(f); M(a)|] ==> M(f`a)"
by (simp add: apply_def)

lemma (in M_basic) apply_abs [simp]:
     "[| M(f); M(x); M(y) |] ==> fun_apply(M,f,x,y) \<longleftrightarrow> f`x = y"
apply (simp add: fun_apply_def apply_def, blast)
done

lemma (in M_basic) typed_function_abs [simp]:
     "[| M(A); M(f) |] ==> 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]:
     "[| M(A); M(f) |] ==> injection(M,A,B,f) \<longleftrightarrow> f \<in> inj(A,B)"
apply (simp add: injection_def apply_iff inj_def apply_closed)
apply (blast dest: transM [of _ A])
done

lemma (in M_basic) surjection_abs [simp]:
     "[| M(A); M(B); M(f) |] ==> 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]:
     "[| M(A); M(B); M(f) |] ==> bijection(M,A,B,f) \<longleftrightarrow> f \<in> bij(A,B)"
by (simp add: bijection_def bij_def)

subsubsection{*Composition of relations*}

lemma (in M_basic) M_comp_iff:
     "[| M(r); M(s) |]
      ==> r O s =
          {xz \<in> domain(s) * range(r).
            \<exists>x[M]. \<exists>y[M]. \<exists>z[M]. xz = \<langle>x,z\<rangle> & \<langle>x,y\<rangle> \<in> s & \<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]:
     "[| M(r); M(s) |] ==> 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]:
     "[| M(r); M(s); M(t) |] ==> composition(M,r,s,t) \<longleftrightarrow> t = r O s"
apply safe
 txt{*Proving @{term "composition(M, r, s, r O s)"}*}
 prefer 2
 apply (simp add: composition_def comp_def)
 apply (blast dest: transM)
txt{*Opposite implication*}
apply (rule M_equalityI)
  apply (simp add: composition_def comp_def)
  apply (blast del: allE dest: transM)+
done

text{*no longer needed*}
lemma (in M_basic) restriction_is_function:
     "[| restriction(M,f,A,z); function(f); M(f); M(A); M(z) |]
      ==> function(z)"
apply (simp add: restriction_def ball_iff_equiv)
apply (unfold function_def, blast)
done

lemma (in M_basic) restriction_abs [simp]:
     "[| M(f); M(A); M(z) |]
      ==> 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_basic) M_restrict_iff:
     "M(r) ==> 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]:
     "[| M(A); M(r) |] ==> M(restrict(r,A))"
apply (simp add: M_restrict_iff)
apply (insert restrict_separation [of A], simp)
done

lemma (in M_basic) Inter_abs [simp]:
     "[| M(A); M(z) |] ==> 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) ==> M(\<Inter>(A))"
by (insert Inter_separation, simp add: Inter_def)

lemma (in M_basic) Int_closed [intro,simp]:
     "[| M(A); M(B) |] ==> M(A \<inter> B)"
apply (subgoal_tac "M({A,B})")
apply (frule Inter_closed, force+)
done

lemma (in M_basic) Diff_closed [intro,simp]:
     "[|M(A); M(B)|] ==> M(A-B)"
by (insert Diff_separation, simp add: Diff_def)

subsubsection{*Some Facts About Separation Axioms*}

lemma (in M_basic) separation_conj:
     "[|separation(M,P); separation(M,Q)|] ==> separation(M, \<lambda>z. P(z) & 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, %x. P(x) | Q(x))"
by blast

lemma Diff_Collect_eq:
     "A - Collect(A,P) = Collect(A, %x. ~ P(x))"
by blast

lemma (in M_trivial) Collect_rall_eq:
     "M(Y) ==> Collect(A, %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)}))"
apply simp
apply (blast intro!: equalityI dest: transM)
done

lemma (in M_basic) separation_disj:
     "[|separation(M,P); separation(M,Q)|] ==> separation(M, \<lambda>z. P(z) | Q(z))"
by (simp del: separation_closed
         add: separation_iff Collect_Un_Collect_eq [symmetric])

lemma (in M_basic) separation_neg:
     "separation(M,P) ==> separation(M, \<lambda>z. ~P(z))"
by (simp del: separation_closed
         add: separation_iff Diff_Collect_eq [symmetric])

lemma (in M_basic) separation_imp:
     "[|separation(M,P); separation(M,Q)|]
      ==> separation(M, \<lambda>z. P(z) \<longrightarrow> Q(z))"
by (simp add: separation_neg separation_disj not_disj_iff_imp [symmetric])

text{*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!*}
lemma (in M_basic) separation_rall:
     "[|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)})|]
      ==> 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!: Inter_closed RepFun_closed dest: transM)
done

subsubsection{*Functions and function space*}

text{*The assumption @{term "M(A->B)"} is unusual, but essential: in
all but trivial cases, A->B cannot be expected to belong to @{term M}.*}
lemma (in M_basic) is_funspace_abs [simp]:
     "[|M(A); M(B); M(F); M(A->B)|] ==> 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:
     "[|M(B); M(n->B)|] ==>
      succ(n) -> B =
      \<Union>{z. p \<in> (n->B)*B, \<exists>f[M]. \<exists>b[M]. p = <f,b> & z = {cons(<n,b>, f)}}"
apply (simp add: succ_fun_eq)
apply (blast dest: transM)
done

lemma (in M_basic) funspace_succ:
     "[|M(n); M(B); M(n->B) |] ==> M(succ(n) -> B)"
apply (insert funspace_succ_replacement [of n], simp)
apply (force simp add: succ_fun_eq2 univalent_def)
done

text{*@{term M} contains all finite function spaces.  Needed to prove the
absoluteness of transitive closure.  See the definition of
@{text rtrancl_alt} in in @{text WF_absolute.thy}.*}
lemma (in M_basic) finite_funspace_closed [intro,simp]:
     "[|n\<in>nat; M(B)|] ==> M(n->B)"
apply (induct_tac n, simp)
apply (simp add: funspace_succ nat_into_M)
done

subsection{*Relativization and Absoluteness for Boolean Operators*}

definition
  is_bool_of_o :: "[i=>o, o, i] => o" where
   "is_bool_of_o(M,P,z) == (P & number1(M,z)) | (~P & empty(M,z))"

definition
  is_not :: "[i=>o, i, i] => o" where
   "is_not(M,a,z) == (number1(M,a)  & empty(M,z)) |
                     (~number1(M,a) & number1(M,z))"

definition
  is_and :: "[i=>o, i, i, i] => o" where
   "is_and(M,a,b,z) == (number1(M,a)  & z=b) |
                       (~number1(M,a) & empty(M,z))"

definition
  is_or :: "[i=>o, i, i, i] => o" where
   "is_or(M,a,b,z) == (number1(M,a)  & number1(M,z)) |
                      (~number1(M,a) & z=b)"

lemma (in M_trivial) bool_of_o_abs [simp]:
     "M(z) ==> 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]:
     "[| M(a); M(z)|] ==> 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]:
     "[| M(a); M(b); M(z)|] ==> 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]:
     "[| M(a); M(b); M(z)|] ==> 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]:
     "[| M(p); M(q) |] ==> M(p and q)"
by (simp add: and_def cond_def)

lemma (in M_trivial) or_closed [intro,simp]:
     "[| M(p); M(q) |] ==> M(p or q)"
by (simp add: or_def cond_def)

lemma (in M_trivial) not_closed [intro,simp]:
     "M(p) ==> M(not(p))"
by (simp add: Bool.not_def cond_def)

subsection{*Relativization and Absoluteness for List Operators*}

definition
  is_Nil :: "[i=>o, i] => o" where
     --{* because @{prop "[] \<equiv> Inl(0)"}*}
    "is_Nil(M,xs) == \<exists>zero[M]. empty(M,zero) & is_Inl(M,zero,xs)"

definition
  is_Cons :: "[i=>o,i,i,i] => o" where
     --{* because @{prop "Cons(a, l) \<equiv> Inr(\<langle>a,l\<rangle>)"}*}
    "is_Cons(M,a,l,Z) == \<exists>p[M]. pair(M,a,l,p) & 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) ==> 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) & M(l)"
by (simp add: Cons_def)

lemma (in M_trivial) Cons_abs [simp]:
     "[|M(a); M(l); M(Z)|] ==> is_Cons(M,a,l,Z) \<longleftrightarrow> (Z = Cons(a,l))"
by (simp add: is_Cons_def Cons_def)

definition
  quasilist :: "i => o" where
    "quasilist(xs) == xs=Nil | (\<exists>x l. xs = Cons(x,l))"

definition
  is_quasilist :: "[i=>o,i] => o" where
    "is_quasilist(M,z) == is_Nil(M,z) | (\<exists>x[M]. \<exists>l[M]. is_Cons(M,x,l,z))"

definition
  list_case' :: "[i, [i,i]=>i, i] => i" where
    --{*A version of @{term list_case} that's always defined.*}
    "list_case'(a,b,xs) ==
       if quasilist(xs) then list_case(a,b,xs) else 0"

definition
  is_list_case :: "[i=>o, i, [i,i,i]=>o, i, i] => o" where
    --{*Returns 0 for non-lists*}
    "is_list_case(M, a, is_b, xs, z) ==
       (is_Nil(M,xs) \<longrightarrow> z=a) &
       (\<forall>x[M]. \<forall>l[M]. is_Cons(M,x,l,xs) \<longrightarrow> is_b(x,l,z)) &
       (is_quasilist(M,xs) | empty(M,z))"

definition
  hd' :: "i => i" where
    --{*A version of @{term hd} that's always defined.*}
    "hd'(xs) == if quasilist(xs) then hd(xs) else 0"

definition
  tl' :: "i => i" where
    --{*A version of @{term tl} that's always defined.*}
    "tl'(xs) == if quasilist(xs) then tl(xs) else 0"

definition
  is_hd :: "[i=>o,i,i] => o" where
     --{* @{term "hd([]) = 0"} no constraints if not a list.
          Avoiding implication prevents the simplifier's looping.*}
    "is_hd(M,xs,H) ==
       (is_Nil(M,xs) \<longrightarrow> empty(M,H)) &
       (\<forall>x[M]. \<forall>l[M]. ~ is_Cons(M,x,l,xs) | H=x) &
       (is_quasilist(M,xs) | empty(M,H))"

definition
  is_tl :: "[i=>o,i,i] => o" where
     --{* @{term "tl([]) = []"}; see comments about @{term is_hd}*}
    "is_tl(M,xs,T) ==
       (is_Nil(M,xs) \<longrightarrow> T=xs) &
       (\<forall>x[M]. \<forall>l[M]. ~ is_Cons(M,x,l,xs) | T=l) &
       (is_quasilist(M,xs) | empty(M,T))"

subsubsection{*@{term quasilist}: For Case-Splitting with @{term list_case'}*}

lemma [iff]: "quasilist(Cons(x,l))"
by (simp add: quasilist_def)

lemma list_imp_quasilist: "l \<in> list(A) ==> quasilist(l)"
by (erule list.cases, simp_all)

subsubsection{*@{term list_case'}, the Modified Version of @{term list_case}*}

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: "~ quasilist(x) ==> 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) ==>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]:
  "[|M(k); M(a); \<forall>x[M]. \<forall>y[M]. M(b(x,y))|] ==> 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) ==> is_quasilist(M,z) \<longleftrightarrow> quasilist(z)"
by (auto simp add: is_quasilist_def quasilist_def)

lemma (in M_trivial) list_case_abs [simp]:
     "[| relation2(M,is_b,b); M(k); M(z) |]
      ==> 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{*The Modified Operators @{term hd'} and @{term tl'}*}

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:
     "[|M(a); M(l)|] ==> is_hd(M,Cons(a,l),Z) \<longleftrightarrow> Z = a"
by (force simp add: is_hd_def)

lemma (in M_trivial) hd_abs [simp]:
     "[|M(x); M(y)|] ==> 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:
     "[|M(a); M(l)|] ==> is_tl(M,Cons(a,l),Z) \<longleftrightarrow> Z = l"
by (force simp add: is_tl_def)

lemma (in M_trivial) tl_abs [simp]:
     "[|M(x); M(y)|] ==> 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 ==> tl'^n ([]) = []"
apply (induct_tac n)
apply (simp_all add: tl'_Nil)
done

lemma (in M_basic) tl'_closed: "M(x) ==> M(tl'(x))"
apply (simp add: tl'_def)
apply (force simp add: quasilist_def)
done

end


theory prop_44
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun elem :: "Nat => Nat list => bool" where
  "elem x (Nil2) = False"
  | "elem x (Cons2 z xs) = (if equal2 x z then True else elem x xs)"
  fun intersect :: "Nat list => Nat list => Nat list" where
  "intersect (Nil2) y = Nil2"
  | "intersect (Cons2 z xs) y =
       (if elem z y then Cons2 z (intersect xs y) else intersect xs y)"

(*hipster equal2 elem intersect*)

lemma lemma_a [thy_expl]: "equal2 x2 y2 = equal2 y2 x2"
by (hipster_induct_schemes equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes equal2.simps)

(*hipster_cond equal2*)

lemma lemma_ac [thy_expl]: "equal2 y2 x2 \<Longrightarrow> x2 = y2"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ad []: "intersect (intersect x5 y5) y5 = intersect x5 y5"
by (hipster_induct_schemes elem.simps intersect.simps equal2.simps)

lemma lemma_ae [thy_expl]: "elem x1 z1 \<Longrightarrow> elem x1 (intersect y1 z1) = elem x1 y1"
by (hipster_induct_schemes elem.simps intersect.simps equal2.simps)

  theorem x0 :
    "(elem x y) ==> ((elem x z) ==> (elem x (intersect y z)))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory LFIs_border
  imports "logical_consequence" "../conditions/conditions_relativized_infinitary"
begin

section \<open>Logics of Formal Inconsistency (LFIs)\<close>

(**The LFIs are a family of paraconsistent logics featuring a 'consistency' operator @{text "\<^bold>\<circ>"}
that can be used to recover some classical properties of negation (in particular ECQ).
We show a shallow semantical embedding of logics at least as strong as the LFI RmbC-ciw*)

(*Let us assume a concrete type w (for 'worlds' or 'points')*)
typedecl w
(*Let us assume the following primitive unary operation \<B> (intended as a border operator)*)
consts \<B>::"w \<sigma> \<Rightarrow> w \<sigma>"

(*From the topological cube of opposition:*)
abbreviation "\<C> \<equiv> (\<B>\<^sup>f\<^sup>p)\<^sup>-"
abbreviation "\<I> \<equiv> \<B>\<^sup>f\<^sup>p\<^sup>c"
lemma "\<C>\<^sup>- = \<B>\<^sup>f\<^sup>p" by (simp add: dualcompl_invol)

(*let us recall that: *)
lemma expn_cntr: "EXPN \<C> = CNTR \<B>" by (metis EXPN_CNTR_dual2 EXPN_fp ofp_comm_dc1)

(**For LFIs we use the negation previously defined as \<C>\<^sup>- = \<B>\<^sup>f\<^sup>p *)
abbreviation cneg ("\<^bold>\<not>_"[70]71) where "cneg \<equiv> \<B>\<^sup>f\<^sup>p"

(**In terms of the border operator the negation looks as follows:*)
lemma cneg_char: "CNTR \<B> \<longrightarrow> \<^bold>\<not>A \<approx> \<^bold>\<midarrow>A \<^bold>\<or> (\<B> A)" by (smt (verit, ccfv_threshold) CNTR_def compl_def dimpl_def join_def op_fixpoint_def setequ_def subset_def)

(**This negation is of course boldly paraconsistent (for both local and global consequence).*)
lemma "[a, \<^bold>\<not>a \<turnstile> b]" nitpick oops (*countermodel*)
lemma "[a, \<^bold>\<not>a \<turnstile> \<^bold>\<not>b]" nitpick oops (*countermodel*)
lemma "[a, \<^bold>\<not>a \<turnstile>\<^sub>g b]" nitpick oops (*countermodel*)
lemma "[a, \<^bold>\<not>a \<turnstile>\<^sub>g \<^bold>\<not>b]" nitpick oops (*countermodel*)

(**We define two pairs of in/consistency operators and show how they relate to each other.
Using LFIs terminology, the minimal logic so encoded corresponds to 'RmbC-ciw' (cf. @{cite RLFI}).*)
abbreviation op_inc_a::"w \<sigma> \<Rightarrow> w \<sigma>" ("\<bullet>\<^sup>A_" [57]58) (* \<bullet> as truth-glut *)
  where "\<bullet>\<^sup>AA \<equiv> A \<^bold>\<and> \<^bold>\<not>A"
abbreviation op_con_a::"w \<sigma> \<Rightarrow> w \<sigma>" ("\<^bold>\<circ>\<^sup>A_" [57]58)
  where "\<^bold>\<circ>\<^sup>AA \<equiv> \<^bold>\<midarrow>\<bullet>\<^sup>AA"
abbreviation op_inc_b::"w \<sigma> \<Rightarrow> w \<sigma>" ("\<bullet>\<^sup>B_" [57]58) (* \<bullet> as border *)
  where "\<bullet>\<^sup>BA \<equiv> \<B> A"
abbreviation op_con_b::"w \<sigma> \<Rightarrow> w \<sigma>" ("\<^bold>\<circ>\<^sup>B_" [57]58)
  where "\<^bold>\<circ>\<^sup>BA \<equiv> \<B>\<^sup>c A"

(**Observe that assumming CNTR \<B> are we allowed to exchange A and B variants.*)
lemma pincAB: "CNTR \<B> \<longrightarrow> \<bullet>\<^sup>AA \<approx> \<bullet>\<^sup>BA" by (smt (verit, ccfv_SIG) cneg_char dimpl_def join_def meet_def op_fixpoint_def setequ_def)
lemma pconAB: "CNTR \<B> \<longrightarrow> \<^bold>\<circ>\<^sup>AA \<approx> \<^bold>\<circ>\<^sup>BA" by (metis pincAB setequ_ext svfun_compl_def)

(**Variants A and B give us slightly different properties (there are countermodels for those not shown).*)
lemma Prop1: "\<^bold>\<circ>\<^sup>BA \<approx> \<I>\<^sup>f\<^sup>p A" by (simp add: ofp_comm_compl ofp_invol setequ_ext)
lemma Prop2: "\<^bold>\<circ>\<^sup>AA \<approx> A \<^bold>\<rightarrow> \<I> A" by (simp add: BA_deMorgan2 impl_char svfun_compl_def)
lemma Prop3: "fp \<C> A \<longleftrightarrow> \<^bold>\<circ>\<^sup>B\<^bold>\<midarrow>A \<approx> \<^bold>\<top>" by (metis Prop1 dual_compl_char2 fp_d_rel setequ_ext)
lemma Prop4a: "fp \<I> A \<longleftrightarrow> \<^bold>\<circ>\<^sup>BA \<approx> \<^bold>\<top>" by (simp add: fp_rel ofp_comm_compl ofp_invol)
lemma Prop4b: "fp \<I> A  \<longrightarrow> \<^bold>\<circ>\<^sup>AA \<approx> \<^bold>\<top>" by (metis BA_impl Prop2 fixpoints_def setequ_char setequ_ext)

(**The 'principle of gentle explosion' works for both variants (both locally and globally)*)
lemma "[\<^bold>\<circ>\<^sup>Aa, a, \<^bold>\<not>a \<turnstile> b]" by (metis (mono_tags, lifting) compl_def meet_def subset_def)
lemma "[\<^bold>\<circ>\<^sup>Aa, a, \<^bold>\<not>a \<turnstile>\<^sub>g b]" by (metis compl_def meet_def)
lemma "[\<^bold>\<circ>\<^sup>Ba, a, \<^bold>\<not>a \<turnstile> b]" by (smt (z3) meet_def ofp_fixpoint_compl_def ofp_invol sdiff_def subset_def)
lemma "[\<^bold>\<circ>\<^sup>Ba, a, \<^bold>\<not>a \<turnstile>\<^sub>g b]" by (metis compl_def fixpoints_def fp_rel gtrue_def setequ_ext svfun_compl_def)

abbreviation "BORDER \<phi> \<equiv> nMULTr \<phi> \<and> CNTR \<phi> \<and> nDNRM \<phi> \<and> nIDEMr\<^sup>b \<phi>"

(**We show how all (local) contraposition variants (among others) can be recovered using the
 consistency operators.*)

lemma "[\<^bold>\<circ>\<^sup>Ab, a \<^bold>\<rightarrow> b \<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" nitpick oops
lemma cons_lcop1: "CNTR \<B> \<longrightarrow> [\<^bold>\<circ>\<^sup>Ab, a \<^bold>\<rightarrow> b \<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" by (smt (verit, del_insts) cneg_char compl_def impl_char join_def meet_def setequ_ext subset_def)
lemma "[\<^bold>\<circ>\<^sup>Bb, a \<^bold>\<rightarrow> b \<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" nitpick oops
lemma cons_lcop2: "CNTR \<B> \<longrightarrow> [\<^bold>\<circ>\<^sup>Bb, a \<^bold>\<rightarrow> b \<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" by (metis cons_lcop1 pconAB setequ_ext)
(*.....*)

(**The following axioms are commonly employed in the literature on LFIs to obtain stronger logics.
We explore under which conditions they can be assumed while keeping the logic boldly paraconsistent.*)
abbreviation cf where "cf \<equiv> \<forall>P. [\<^bold>\<not>\<^bold>\<not>P \<turnstile> P]"
abbreviation ce where "ce \<equiv> \<forall>P. [P \<turnstile> \<^bold>\<not>\<^bold>\<not>P]"
abbreviation ciw_a where "ciw_a \<equiv> \<forall>P. [\<turnstile> \<^bold>\<circ>\<^sup>AP \<^bold>\<or> \<bullet>\<^sup>AP]"
abbreviation ciw_b where "ciw_b \<equiv> \<forall>P. [\<turnstile> \<^bold>\<circ>\<^sup>BP \<^bold>\<or> \<bullet>\<^sup>BP]"
abbreviation ci_a  where  "ci_a \<equiv> \<forall>P. [\<^bold>\<not>(\<^bold>\<circ>\<^sup>AP) \<turnstile> \<bullet>\<^sup>AP]"
abbreviation ci_b  where  "ci_b \<equiv> \<forall>P. [\<^bold>\<not>(\<^bold>\<circ>\<^sup>BP) \<turnstile> \<bullet>\<^sup>BP]"
abbreviation cl_a  where  "cl_a \<equiv> \<forall>P.  [\<^bold>\<not>(\<bullet>\<^sup>AP) \<turnstile> \<^bold>\<circ>\<^sup>AP]"
abbreviation cl_b  where  "cl_b \<equiv> \<forall>P.  [\<^bold>\<not>(\<bullet>\<^sup>BP) \<turnstile> \<^bold>\<circ>\<^sup>BP]"
abbreviation ca_conj_a where "ca_conj_a \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>AP,\<^bold>\<circ>\<^sup>AQ \<turnstile> \<^bold>\<circ>\<^sup>A(P \<^bold>\<and> Q)]"
abbreviation ca_conj_b where "ca_conj_b \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>BP,\<^bold>\<circ>\<^sup>BQ \<turnstile> \<^bold>\<circ>\<^sup>B(P \<^bold>\<and> Q)]"
abbreviation ca_disj_a where "ca_disj_a \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>AP,\<^bold>\<circ>\<^sup>AQ \<turnstile> \<^bold>\<circ>\<^sup>A(P \<^bold>\<or> Q)]"
abbreviation ca_disj_b where "ca_disj_b \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>BP,\<^bold>\<circ>\<^sup>BQ \<turnstile> \<^bold>\<circ>\<^sup>B(P \<^bold>\<or> Q)]"
abbreviation ca_impl_a where "ca_impl_a \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>AP,\<^bold>\<circ>\<^sup>AQ \<turnstile> \<^bold>\<circ>\<^sup>A(P \<^bold>\<rightarrow> Q)]"
abbreviation ca_impl_b where "ca_impl_b \<equiv> \<forall>P Q. [\<^bold>\<circ>\<^sup>BP,\<^bold>\<circ>\<^sup>BQ \<turnstile> \<^bold>\<circ>\<^sup>B(P \<^bold>\<rightarrow> Q)]"
abbreviation ca_a where "ca_a \<equiv> ca_conj_a \<and> ca_disj_a \<and> ca_impl_a"
abbreviation ca_b where "ca_b \<equiv> ca_conj_b \<and> ca_disj_b \<and> ca_impl_b"

(**cf*)
lemma "BORDER \<B> \<Longrightarrow> cf" nitpick oops (*countermodel*)

(**ce*)
lemma "BORDER \<B> \<Longrightarrow> ce" nitpick oops (*countermodel*)

(**ciw*)
lemma prop_ciw_a: "ciw_a" by (simp add: conn)
lemma prop_ciw_b: "ciw_b" by (simp add: conn svfun_compl_def)

(**ci*)
lemma "BORDER \<B> \<Longrightarrow> ci_a" nitpick oops (*countermodel*)
lemma "BORDER \<B> \<Longrightarrow> ci_b" nitpick oops (*countermodel*)

(**cl*)
lemma "BORDER \<B> \<Longrightarrow> cl_a" nitpick oops (*countermodel*)
lemma "BORDER \<B> \<Longrightarrow> cl_b" nitpick oops (*countermodel*)

(**ca_conj*)
lemma prop_ca_conj_b: "nMULT\<^sup>b \<B> = ca_conj_b" by (metis MULT_b_def nMULTb_compl sfun_compl_invol)
lemma prop_ca_conj_a: "nMULTr\<^sup>b \<B> = ca_conj_a" unfolding cond op_fixpoint_def by (smt (z3) compl_def dimpl_def join_def meet_def op_fixpoint_def subset_def subset_in_def)

(**ca_disj*)
lemma prop_ca_disj_b: "ADDI\<^sup>a \<B> = ca_disj_b" by (simp add: nADDI_a_def nADDIa_compl)
lemma prop_ca_disj_a: "nMULTr\<^sup>a \<B> = ca_disj_a" (*nitpick*) oops (*TODO: verify*)

(**ca_impl*)
lemma "BORDER \<B> \<Longrightarrow> ca_impl_a" nitpick oops (*countermodel*)
lemma "BORDER \<B> \<Longrightarrow> ca_impl_b" nitpick oops (*countermodel*)

end


(*  Author:     Tobias Nipkow, 2007  *)

theory QElin_opt
imports QElin
begin

subsubsection\<open>An optimization\<close>

text\<open>Atoms are simplified asap.\<close>

definition
"asimp a = (case a of
 Less r cs \<Rightarrow> (if \<forall>c\<in> set cs. c = 0
               then if r<0 then TrueF else FalseF
               else Atom a) |
 Eq r cs \<Rightarrow> (if \<forall>c\<in> set cs. c = 0
             then if r=0 then TrueF else FalseF else Atom a))"

lemma asimp_pretty:
"asimp (Less r cs) =
 (if \<forall>c\<in> set cs. c = 0
  then if r<0 then TrueF else FalseF
  else Atom(Less r cs))"
"asimp (Eq r cs) =
 (if \<forall>c\<in> set cs. c = 0
  then if r=0 then TrueF else FalseF
  else Atom(Eq r cs))"
by(auto simp:asimp_def)

definition qe_FMo\<^sub>1 :: "atom list \<Rightarrow> atom fm" where
"qe_FMo\<^sub>1 as = list_conj [asimp(combine p q). p\<leftarrow>lbounds as, q\<leftarrow>ubounds as]"

lemma I_asimp: "R.I (asimp a) xs = I\<^sub>R a xs"
by(simp add:asimp_def iprod0_if_coeffs0 split:atom.split)

lemma I_qe_FMo\<^sub>1: "R.I (qe_FMo\<^sub>1 as) xs = R.I (qe_FM\<^sub>1 as) xs"
by(simp add:qe_FM\<^sub>1_def qe_FMo\<^sub>1_def I_asimp)

definition "qe_FMo = R\<^sub>e.lift_dnfeq_qe qe_FMo\<^sub>1"

lemma qfree_qe_FMo\<^sub>1: "qfree (qe_FMo\<^sub>1 as)"
by(auto simp:qe_FM\<^sub>1_def qe_FMo\<^sub>1_def asimp_def intro!:qfree_list_conj
        split:atom.split)

corollary I_qe_FMo: "R.I (qe_FMo \<phi>) xs = R.I \<phi> xs"
unfolding qe_FMo_def
apply(rule R\<^sub>e.I_lift_dnfeq_qe)
 apply(rule qfree_qe_FMo\<^sub>1)
apply(rule allI)
apply(subst I_qe_FMo\<^sub>1)
apply(rule I_qe_FM\<^sub>1)
 prefer 2 apply blast
apply(clarify)
apply(drule_tac x=a in bspec) apply simp
apply(simp add: depends\<^sub>R_def split:atom.splits list.splits)
done

theorem qfree_qe_FMo: "qfree (qe_FMo f)"
by(simp add:qe_FMo_def R\<^sub>e.qfree_lift_dnfeq_qe qfree_qe_FMo\<^sub>1)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Transport for Dependent Function Relator with Non-Dependent Functions\<close>
theory Transport_Rel_If
  imports
    Transport.Transport
begin

paragraph \<open>Summary\<close>
text \<open>We introduce a special case of @{locale transport_Dep_Fun_Rel}.
The derived theorem is easier to apply and supported by our current prototype.\<close>

context
  fixes P :: "'a \<Rightarrow> bool" and R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

lemma reflexive_on_rel_if_if_reflexive_onI [intro]:
  assumes "B \<Longrightarrow> reflexive_on P R"
  shows "reflexive_on P (rel_if B R)"
  using assms by (intro reflexive_onI) blast

lemma transitive_on_rel_if_if_transitive_onI [intro]:
  assumes "B \<Longrightarrow> transitive_on P R"
  shows "transitive_on P (rel_if B R)"
  using assms by (intro transitive_onI) (blast dest: transitive_onD)

lemma preorder_on_rel_if_if_preorder_onI [intro]:
  assumes "B \<Longrightarrow> preorder_on P R"
  shows "preorder_on P (rel_if B R)"
  using assms by (intro preorder_onI) auto

lemma symmetric_on_rel_if_if_symmetric_onI [intro]:
  assumes "B \<Longrightarrow> symmetric_on P R"
  shows "symmetric_on P (rel_if B R)"
  using assms by (intro symmetric_onI) (blast dest: symmetric_onD)

lemma partial_equivalence_rel_on_rel_if_if_partial_equivalence_rel_onI [intro]:
  assumes "B \<Longrightarrow> partial_equivalence_rel_on P R"
  shows "partial_equivalence_rel_on P (rel_if B R)"
  using assms by (intro partial_equivalence_rel_onI)
  auto

lemma rel_if_dep_mono_wrt_rel_if_iff_if_dep_mono_wrt_relI:
  assumes "B \<Longrightarrow> B' \<Longrightarrow> ([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  and "B \<longleftrightarrow> B'"
  shows "([x y \<Colon> (rel_if B R)] \<Rrightarrow>\<^sub>m (rel_if B' (S x y))) f"
  using assms by (intro dep_mono_wrt_relI) auto

end

corollary reflexive_rel_if_if_reflexiveI [intro]:
  assumes "B \<Longrightarrow> reflexive R"
  shows "reflexive (rel_if B R)"
  using assms unfolding reflexive_eq_reflexive_on by blast

corollary transitive_rel_if_if_transitiveI [intro]:
  assumes "B \<Longrightarrow> transitive R"
  shows "transitive (rel_if B R)"
  using assms unfolding transitive_eq_transitive_on by blast

corollary preorder_rel_if_if_preorderI [intro]:
  assumes "B \<Longrightarrow> preorder R"
  shows "preorder (rel_if B R)"
  using assms unfolding preorder_eq_preorder_on by blast

corollary symmetric_rel_if_if_symmetricI [intro]:
  assumes "B \<Longrightarrow> symmetric R"
  shows "symmetric (rel_if B R)"
  using assms unfolding symmetric_eq_symmetric_on by blast

corollary partial_equivalence_rel_rel_if_if_partial_equivalence_relI [intro]:
  assumes "B \<Longrightarrow> partial_equivalence_rel R"
  shows "partial_equivalence_rel (rel_if B R)"
  using assms unfolding partial_equivalence_rel_eq_partial_equivalence_rel_on
  by blast

context galois_prop
begin

interpretation rel_if : galois_prop "rel_if B (\<le>\<^bsub>L\<^esub>)" "rel_if B' (\<le>\<^bsub>R\<^esub>)" l r .

lemma rel_if_half_galois_prop_left_if_iff_if_half_galois_prop_leftI:
  assumes "B \<Longrightarrow> B' \<Longrightarrow> ((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  and "B \<longleftrightarrow> B'"
  shows "((rel_if B (\<le>\<^bsub>L\<^esub>)) \<^sub>h\<unlhd> (rel_if B' (\<le>\<^bsub>R\<^esub>))) l r"
  using assms by (intro rel_if.half_galois_prop_leftI) fastforce

lemma rel_if_half_galois_prop_right_if_iff_if_half_galois_prop_rightI:
  assumes "B \<Longrightarrow> B' \<Longrightarrow> ((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  and "B \<longleftrightarrow> B'"
  shows "((rel_if B (\<le>\<^bsub>L\<^esub>)) \<unlhd>\<^sub>h (rel_if B' (\<le>\<^bsub>R\<^esub>))) l r"
  using assms by (intro rel_if.half_galois_prop_rightI) fastforce

lemma rel_if_galois_prop_if_iff_if_galois_propI:
  assumes "B \<Longrightarrow> B' \<Longrightarrow> ((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  and "B \<longleftrightarrow> B'"
  shows "((rel_if B (\<le>\<^bsub>L\<^esub>)) \<unlhd> (rel_if B' (\<le>\<^bsub>R\<^esub>))) l r"
  using assms by (intro rel_if.galois_propI
    rel_if_half_galois_prop_left_if_iff_if_half_galois_prop_leftI
    rel_if_half_galois_prop_right_if_iff_if_half_galois_prop_rightI)
  auto

end

context galois
begin

interpretation rel_if : galois "rel_if B (\<le>\<^bsub>L\<^esub>)" "rel_if B' (\<le>\<^bsub>R\<^esub>)" l r .

lemma rel_if_galois_connection_if_iff_if_galois_connectionI:
  assumes "B \<Longrightarrow> B' \<Longrightarrow> ((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  and "B \<longleftrightarrow> B'"
  shows "((rel_if B (\<le>\<^bsub>L\<^esub>)) \<stileturn> (rel_if B' (\<le>\<^bsub>R\<^esub>))) l r"
  using assms by (intro rel_if.galois_connectionI
    rel_if_dep_mono_wrt_rel_if_iff_if_dep_mono_wrt_relI
    rel_if_galois_prop_if_iff_if_galois_propI)
  auto

lemma rel_if_galois_equivalence_if_iff_if_galois_equivalenceI:
  assumes "B \<Longrightarrow> B' \<Longrightarrow> ((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  and "B \<longleftrightarrow> B'"
  shows "((rel_if B (\<le>\<^bsub>L\<^esub>)) \<equiv>\<^sub>G (rel_if B' (\<le>\<^bsub>R\<^esub>))) l r"
  using assms by (intro rel_if.galois_equivalenceI
    rel_if_galois_connection_if_iff_if_galois_connectionI
    galois_prop.rel_if_galois_prop_if_iff_if_galois_propI)
  (auto elim: galois.galois_connectionE)

end

context transport
begin

interpretation rel_if : transport "rel_if B (\<le>\<^bsub>L\<^esub>)" "rel_if B' (\<le>\<^bsub>R\<^esub>)" l r .

lemma rel_if_preorder_equivalence_if_iff_if_preorder_equivalenceI:
  assumes "B \<Longrightarrow> B' \<Longrightarrow> ((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  and "B \<longleftrightarrow> B'"
  shows "((rel_if B (\<le>\<^bsub>L\<^esub>)) \<equiv>\<^bsub>pre\<^esub> (rel_if B' (\<le>\<^bsub>R\<^esub>))) l r"
  using assms by (intro rel_if.preorder_equivalence_if_galois_equivalenceI
    rel_if_galois_equivalence_if_iff_if_galois_equivalenceI
    preorder_on_rel_if_if_preorder_onI)
  blast+

lemma rel_if_partial_equivalence_rel_equivalence_if_iff_if_partial_equivalence_rel_equivalenceI:
  assumes "B \<Longrightarrow> B' \<Longrightarrow> ((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  and "B \<longleftrightarrow> B'"
  shows "((rel_if B (\<le>\<^bsub>L\<^esub>)) \<equiv>\<^bsub>PER\<^esub> (rel_if B' (\<le>\<^bsub>R\<^esub>))) l r"
  using assms by (intro
    rel_if.partial_equivalence_rel_equivalence_if_galois_equivalenceI
    rel_if_galois_equivalence_if_iff_if_galois_equivalenceI)
  blast+

end

locale transport_Dep_Fun_Rel_no_dep_fun =
  transport_Dep_Fun_Rel_syntax L1 R1 l1 r1 L2 R2 "\<lambda>_ _. l2" "\<lambda>_ _. r2" +
  tdfr : transport_Dep_Fun_Rel L1 R1 l1 r1 L2 R2 "\<lambda>_ _. l2" "\<lambda>_ _. r2"
  for L1 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> bool"
  and R1 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and l1 :: "'a1 \<Rightarrow> 'a2"
  and r1 :: "'a2 \<Rightarrow> 'a1"
  and L2 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> 'b1 \<Rightarrow> 'b1 \<Rightarrow> bool"
  and R2 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> 'b2 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and l2 :: "'b1 \<Rightarrow> 'b2"
  and r2 :: "'b2 \<Rightarrow> 'b1"
begin

notation t2.unit ("\<eta>\<^sub>2")
notation t2.counit ("\<epsilon>\<^sub>2")

abbreviation "L \<equiv> tdfr.L"
abbreviation "R \<equiv> tdfr.R"

abbreviation "l \<equiv> tdfr.l"
abbreviation "r \<equiv> tdfr.r"

notation tdfr.L (infix "\<le>\<^bsub>L\<^esub>" 50)
notation tdfr.R (infix "\<le>\<^bsub>R\<^esub>" 50)

notation tdfr.ge_left (infix "\<ge>\<^bsub>L\<^esub>" 50)
notation tdfr.ge_right (infix "\<ge>\<^bsub>R\<^esub>" 50)

notation tdfr.unit ("\<eta>")
notation tdfr.counit ("\<epsilon>")

theorem partial_equivalence_rel_equivalenceI:
  assumes per_equiv1: "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and per_equiv2: "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) l2 r2"
  and "([x1 x2 \<Colon> (\<ge>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 x4 \<Colon> (\<le>\<^bsub>L1\<^esub>) | x1 \<le>\<^bsub>L1\<^esub> x3] \<Rrightarrow> (\<le>)) L2"
  and "([x1' x2' \<Colon> (\<ge>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x3' x4' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x1' \<le>\<^bsub>R1\<^esub> x3'] \<Rrightarrow> (\<le>)) R2"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
proof -
  have per2I: "((\<le>\<^bsub>L2 x1 (r1 x2')\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2 (l1 x1) x2'\<^esub>)) l2 r2"
    if hyps: "x1 \<le>\<^bsub>L1\<^esub> x2" "x2 \<^bsub>L1\<^esub>\<lessapprox> x1'" "x1' \<le>\<^bsub>R1\<^esub> x2'" for x1 x2 x1' x2'
  proof -
    from hyps have "x1 \<^bsub>L1\<^esub>\<lessapprox> x2'"
      using per_equiv1 t1.Galois_if_Galois_if_left_relI t1.Galois_if_right_rel_if_GaloisI
      by fast
    with per_equiv2 show ?thesis by blast
  qed
  have "([x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>) | x2 \<^bsub>L1\<^esub>\<lessapprox> x1'] \<Rrightarrow>
    [in_field (\<le>\<^bsub>L2 x1 (r1 x2')\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 (l1 x1) x2'\<^esub>)) (\<lambda>_ _. l2)"
    by (intro dep_mono_wrt_relI Dep_Fun_Rel_relI Dep_Fun_Rel_predI rel_if_if_impI)
    (fast dest!: per2I)
  moreover have
    "([x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x2 \<^bsub>L1\<^esub>\<lessapprox> x1'] \<Rrightarrow>
    [in_field (\<le>\<^bsub>R2 (l1 x1) x2'\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 x1 (r1 x2')\<^esub>)) (\<lambda>_ _. r2)"
    by (intro dep_mono_wrt_relI Dep_Fun_Rel_relI Dep_Fun_Rel_predI rel_if_if_impI)
    (fast dest!: per2I)
  ultimately show ?thesis
    using assms by (intro tdfr.partial_equivalence_rel_equivalenceI) auto
qed

end

end


theory Word_Lsb_Msb
  imports "HOL-Library.Word"
begin

class word = ring_bit_operations +
  fixes word_length :: \<open>'a itself \<Rightarrow> nat\<close>
  assumes word_length_positive [simp]: \<open>0 < word_length TYPE('a)\<close>
    and possible_bit_msb: \<open>possible_bit TYPE('a) (word_length TYPE('a) - Suc 0)\<close>
    and not_possible_bit_length: \<open>\<not> possible_bit TYPE('a) (word_length TYPE('a))\<close>
begin

lemma word_length_not_0 [simp]:
  \<open>word_length TYPE('a) \<noteq> 0\<close>
  using word_length_positive
  by simp

lemma possible_bit_iff_less_word_length:
  \<open>possible_bit TYPE('a) n \<longleftrightarrow> n < word_length TYPE('a)\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof
  assume \<open>?P\<close>
  show ?Q
  proof (rule ccontr)
    assume \<open>\<not> n < word_length TYPE('a)\<close>
    then have \<open>word_length TYPE('a) \<le> n\<close>
      by simp
    with \<open>?P\<close> have \<open>possible_bit TYPE('a) (word_length TYPE('a))\<close>
      by (rule possible_bit_less_imp)
    with not_possible_bit_length show False ..
  qed
next
  assume \<open>?Q\<close>
  then have \<open>n \<le> word_length TYPE('a) - Suc 0\<close>
    by simp
  with possible_bit_msb show ?P
    by (rule possible_bit_less_imp)
qed

end

instantiation word :: (len) word
begin

definition word_length_word :: \<open>'a word itself \<Rightarrow> nat\<close>
  where [simp, code_unfold]: \<open>word_length_word _ = LENGTH('a)\<close>

instance
  by standard simp_all

end

context word
begin

context
  includes bit_operations_syntax
begin

abbreviation lsb :: \<open>'a \<Rightarrow> bool\<close>
  where \<open>lsb \<equiv> odd\<close>

definition msb :: \<open>'a \<Rightarrow> bool\<close>
  where \<open>msb w = bit w (word_length TYPE('a) - Suc 0)\<close>

lemma not_msb_0 [simp]:
  \<open>\<not> msb 0\<close>
  by (simp add: msb_def)

lemma msb_minus_1 [simp]:
  \<open>msb (- 1)\<close>
  by (simp add: msb_def possible_bit_iff_less_word_length)

lemma msb_1_iff [simp]:
  \<open>msb 1 \<longleftrightarrow> word_length TYPE('a) = 1\<close>
  by (auto simp add: msb_def bit_simps le_less)

lemma msb_minus_iff [simp]:
  \<open>msb (- w) \<longleftrightarrow> \<not> msb (w - 1)\<close>
  by (simp add: msb_def bit_simps possible_bit_iff_less_word_length)

lemma msb_not_iff [simp]:
  \<open>msb (NOT w) \<longleftrightarrow> \<not> msb w\<close>
  by (simp add: msb_def bit_simps possible_bit_iff_less_word_length)

lemma msb_and_iff [simp]:
  \<open>msb (v AND w) \<longleftrightarrow> msb v \<and> msb w\<close>
  by (simp add: msb_def bit_simps)

lemma msb_or_iff [simp]:
  \<open>msb (v OR w) \<longleftrightarrow> msb v \<or> msb w\<close>
  by (simp add: msb_def bit_simps)

lemma msb_xor_iff [simp]:
  \<open>msb (v XOR w) \<longleftrightarrow> \<not> (msb v \<longleftrightarrow> msb w)\<close>
  by (simp add: msb_def bit_simps)

lemma msb_exp_iff [simp]:
  \<open>msb (2 ^ n) \<longleftrightarrow> n = word_length TYPE('a) - Suc 0\<close>
  by (simp add: msb_def bit_simps possible_bit_iff_less_word_length)

lemma msb_mask_iff [simp]:
  \<open>msb (mask n) \<longleftrightarrow> word_length TYPE('a) \<le> n\<close>
  by (simp add: msb_def bit_simps less_diff_conv2 Suc_le_eq less_Suc_eq_le possible_bit_iff_less_word_length)

lemma msb_set_bit_iff [simp]:
  \<open>msb (set_bit n w) \<longleftrightarrow> n = word_length TYPE('a) - Suc 0 \<or> msb w\<close>
  by (simp add: set_bit_eq_or ac_simps)

lemma msb_unset_bit_iff [simp]:
  \<open>msb (unset_bit n w) \<longleftrightarrow> n \<noteq> word_length TYPE('a) - Suc 0 \<and> msb w\<close>
  by (simp add: unset_bit_eq_and_not ac_simps)

lemma msb_flip_bit_iff [simp]:
  \<open>msb (flip_bit n w) \<longleftrightarrow> (n \<noteq> word_length TYPE('a) - Suc 0 \<longleftrightarrow> msb w)\<close>
  by (auto simp add: flip_bit_eq_xor)

lemma msb_push_bit_iff:
  \<open>msb (push_bit n w) \<longleftrightarrow> n < word_length TYPE('a) \<and> bit w (word_length TYPE('a) - Suc n)\<close>
  by (simp add: msb_def bit_simps le_diff_conv2 Suc_le_eq possible_bit_iff_less_word_length)

lemma msb_drop_bit_iff [simp]:
  \<open>msb (drop_bit n w) \<longleftrightarrow> n = 0 \<and> msb w\<close>
  by (cases n)
    (auto simp add: msb_def bit_simps possible_bit_iff_less_word_length intro!: impossible_bit)

lemma msb_take_bit_iff [simp]:
  \<open>msb (take_bit n w) \<longleftrightarrow> word_length TYPE('a) \<le> n \<and> msb w\<close>
  by (simp add: take_bit_eq_mask ac_simps)

lemma msb_signed_take_bit_iff:
  \<open>msb (signed_take_bit n w) \<longleftrightarrow> bit w (min n (word_length TYPE('a) - Suc 0))\<close>
  by (simp add: msb_def bit_simps possible_bit_iff_less_word_length)

definition signed_drop_bit :: \<open>nat \<Rightarrow> 'a \<Rightarrow> 'a\<close>
  where \<open>signed_drop_bit n w = drop_bit n w
    OR (of_bool (bit w (word_length TYPE('a) - Suc 0)) * NOT (mask (word_length TYPE('a) - Suc n)))\<close>

lemma msb_signed_drop_bit_iff [simp]:
  \<open>msb (signed_drop_bit n w) \<longleftrightarrow> msb w\<close>
  by (simp add: signed_drop_bit_def bit_simps not_le not_less)
    (simp add: msb_def)

end

end

end


(* Author: Julian Brunner *)
(* This is originally a part of the CAVA model checker *)
theory Basic
imports
  Main
begin

  abbreviation (input) "const x \<equiv> \<lambda> _. x"

  lemma infinite_subset[trans]: "infinite A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> infinite B" using infinite_super by this
  lemma finite_subset[trans]: "A \<subseteq> B \<Longrightarrow> finite B \<Longrightarrow> finite A" using finite_subset by this

  declare infinite_coinduct[case_names infinite, coinduct pred: infinite]
  lemma infinite_psubset_coinduct[case_names infinite, consumes 1]:
    assumes "R A"
    assumes "\<And> A. R A \<Longrightarrow> \<exists> B \<subset> A. R B"
    shows "infinite A"
  proof
    assume "finite A"
    then show "False" using assms by (induct rule: finite_psubset_induct) (auto)
  qed

  lemma GreatestI:
    fixes k :: nat
    assumes "P k" "\<And> k. P k \<Longrightarrow> k \<le> l"
    shows "P (GREATEST k. P k)"
  proof (rule GreatestI_nat)
    show "P k" using assms(1) by this
    show "k \<le> l" if "P k" for k using assms(2) that by force
  qed
  lemma Greatest_le:
    fixes k :: nat
    assumes "P k" "\<And> k. P k \<Longrightarrow> k \<le> l"
    shows "k \<le> (GREATEST k. P k)"
  proof (rule Greatest_le_nat)
    show "P k" using assms(1) by this
    show "k \<le> l" if "P k" for k using assms(2) that by force
  qed
  lemma Greatest_not_less:
    fixes k :: nat
    assumes "k > (GREATEST k. P k)" "\<And> k. P k \<Longrightarrow> k \<le> l"
    shows "\<not> P k"
  proof
    assume 1: "P k"
    have 2: "k \<le> (GREATEST k. P k)" using Greatest_le 1 assms(2) by this
    show "False" using assms(1) 2 by auto
  qed

  lemma finite_set_of_finite_maps':
    assumes "finite A" "finite B"
    shows "finite {m. dom m \<subseteq> A \<and> ran m \<subseteq> B}"
  proof -
    have "{m. dom m \<subseteq> A \<and> ran m \<subseteq> B} = (\<Union> \<A> \<in> Pow A. {m. dom m = \<A> \<and> ran m \<subseteq> B})" by auto
    also have "finite \<dots>" using finite_subset assms by (auto intro: finite_set_of_finite_maps)
    finally show ?thesis by this
  qed

  primrec alternate :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a)" where
    "alternate f g 0 = id" | "alternate f g (Suc k) = alternate g f k \<circ> f"

  lemma alternate_Suc[simp]: "alternate f g (Suc k) = (if even k then f else g) \<circ> alternate f g k"
  proof (induct k arbitrary: f g)
    case (0)
    show ?case by simp
  next
    case (Suc k)
    have "alternate f g (Suc (Suc k)) = alternate g f (Suc k) \<circ> f" by auto
    also have "\<dots> = (if even k then g else f) \<circ> (alternate g f k \<circ> f)" unfolding Suc by auto
    also have "\<dots> = (if even (Suc k) then f else g) \<circ> alternate f g (Suc k)" by auto
    finally show ?case by this
  qed

  declare alternate.simps(2)[simp del]

  lemma alternate_antimono:
    assumes "\<And> x. f x \<le> x" "\<And> x. g x \<le> x"
    shows "antimono (alternate f g)"
  proof
    fix k l :: nat
    assume 1: "k \<le> l"
    obtain n where 2: "l = k + n" using le_Suc_ex 1 by auto
    have 3: "alternate f g (k + n) \<le> alternate f g k"
    proof (induct n)
      case (0)
      show ?case by simp
    next
      case (Suc n)
      have "alternate f g (k + Suc n) \<le> alternate f g (k + n)" using assms by (auto intro: le_funI)
      also have "\<dots> \<le> alternate f g k" using Suc by this
      finally show ?case by this
    qed
    show "alternate f g l \<le> alternate f g k" using 3 unfolding 2 by this
  qed

end


(* Author: Tobias Nipkow and Gerwin Klein *)

section "Compiler for IMP"

theory Compiler imports Big_Step Star
begin

subsection "List setup"

text \<open>
  In the following, we use the length of lists as integers
  instead of natural numbers. Instead of converting \<^typ>\<open>nat\<close>
  to \<^typ>\<open>int\<close> explicitly, we tell Isabelle to coerce \<^typ>\<open>nat\<close>
  automatically when necessary.
\<close>
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

text \<open>
  Similarly, we will want to access the ith element of a list,
  where \<^term>\<open>i\<close> is an \<^typ>\<open>int\<close>.
\<close>
fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"

text \<open>
  The only additional lemma we need about this function
  is indexing over append:
\<close>
lemma inth_append [simp]:
  "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induction xs arbitrary: i) (auto simp: algebra_simps)

text\<open>We hide coercion \<^const>\<open>int\<close> applied to \<^const>\<open>length\<close>:\<close>

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

text_raw\<open>\snip{instrdef}{0}{1}{%\<close>
datatype instr =
  LOADI int | LOAD vname | ADD | STORE vname |
  JMP int | JMPLESS int | JMPGE int
text_raw\<open>}%endsnip\<close>

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
"iexec instr (i,s,stk) = (case instr of
  LOADI n \<Rightarrow> (i+1,s, n#stk) |
  LOAD x \<Rightarrow> (i+1,s, s x # stk) |
  ADD \<Rightarrow> (i+1,s, (hd2 stk + hd stk) # tl2 stk) |
  STORE x \<Rightarrow> (i+1,s(x := hd stk),tl stk) |
  JMP n \<Rightarrow>  (i+1+n,s,stk) |
  JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i+1+n else i+1,s,tl2 stk) |
  JMPGE n \<Rightarrow> (if hd2 stk >= hd stk then i+1+n else i+1,s,tl2 stk))"

definition
  exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
     ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)
where
  "P \<turnstile> c \<rightarrow> c' =
  (\<exists>i s stk. c = (i,s,stk) \<and> c' = iexec(P!!i) (i,s,stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P!!i) (i,s,stk) \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size P
  \<Longrightarrow> P \<turnstile> (i,s,stk) \<rightarrow> c'"
by (simp add: exec1_def)

abbreviation
  exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50)
where
  "exec P \<equiv> star (exec1 P)"

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

code_pred exec1 by (metis exec1_def)

values
  "{(i,map t [''x'',''y''],stk) | i t stk.
    [LOAD ''y'', STORE ''x''] \<turnstile>
    (0, <''x'' := 3, ''y'' := 4>, []) \<rightarrow>* (i,t,stk)}"

subsection\<open>Verification infrastructure\<close>

text\<open>Below we need to argue about the execution of code that is embedded in
larger programs. For this purpose we show that execution is preserved by
appending code to the left or right of a program.\<close>

lemma iexec_shift [simp]:
  "((n+i',s',stk') = iexec x (n+i,s,stk)) = ((i',s',stk') = iexec x (i,s,stk))"
by(auto split:instr.split)

lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
by (auto simp: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: star.step exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows
  "P \<turnstile> (i,s,stk) \<rightarrow> (i',s',stk') \<Longrightarrow>
   P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow> (size(P')+i',s',stk')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

lemma exec_appendL:
  fixes i i' :: int
  shows
 "P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')  \<Longrightarrow>
  P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow>* (size(P')+i',s',stk')"
  by (induction rule: exec_induct) (blast intro: star.step exec1_appendL)+

text\<open>Now we specialise the above lemmas to enable automatic proofs of
\<^prop>\<open>P \<turnstile> c \<rightarrow>* c'\<close> where \<open>P\<close> is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by \<open>@\<close> and \<open>#\<close>. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it:\<close>

lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0,s,stk) \<rightarrow>* (j,t,stk') \<Longrightarrow>
  instr#P \<turnstile> (1,s,stk) \<rightarrow>* (1+j,t,stk')"
by (drule exec_appendL[where P'="[instr]"]) simp

lemma exec_appendL_if[intro]:
  fixes i i' j :: int
  shows
  "size P' <= i
   \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
   \<Longrightarrow> i' = size P' + j
   \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
by (drule exec_appendL[where P'=P']) simp

text\<open>Split the execution of a compound program up into the execution of its
parts:\<close>

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows
"P \<turnstile> (0,s,stk) \<rightarrow>* (i',s',stk') \<Longrightarrow>
 size P \<le> i' \<Longrightarrow>
 P' \<turnstile>  (i' - size P,s',stk') \<rightarrow>* (i'',s'',stk'') \<Longrightarrow>
 j'' = size P + i''
 \<Longrightarrow>
 P @ P' \<turnstile> (0,s,stk) \<rightarrow>* (j'',s'',stk'')"
by(metis star_trans[OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
"acomp (N n) = [LOADI n]" |
"acomp (V x) = [LOAD x]" |
"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
by (induction a arbitrary: stk) fastforce+

fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
"bcomp (Bc v) f n = (if v=f then [JMP n] else [])" |
"bcomp (Not b) f n = bcomp b (\<not>f) n" |
"bcomp (And b1 b2) f n =
 (let cb2 = bcomp b2 f n;
        m = if f then size cb2 else (size cb2)+n;
      cb1 = bcomp b1 False m
  in cb1 @ cb2)" |
"bcomp (Less a1 a2) f n =
 acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
     False 3"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n"
                 "False"]
       And(2)[of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
"ccomp SKIP = []" |
"ccomp (x ::= a) = acomp a @ [STORE x]" |
"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  (let cc\<^sub>1 = ccomp c\<^sub>1; cc\<^sub>2 = ccomp c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
   in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
"ccomp (WHILE b DO c) =
 (let cc = ccomp c; cb = bcomp b False (size cc + 1)
  in cb @ cc @ [JMP (-(size cb + size cc + 1))])"

value "ccomp
 (IF Less (V ''u'') (N 1) THEN ''u'' ::= Plus (V ''u'') (N 1)
  ELSE ''v'' ::= V ''u'')"

value "ccomp (WHILE Less (V ''u'') (N 1) DO (''u'' ::= Plus (V ''u'') (N 1)))"

subsection "Preservation of semantics"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  let ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
    using \<open>bval b s1\<close> by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
    using WhileTrue.IH(1) by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
qed fastforce+

end