(*  Title:      ZF/Constructible/Relative.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
                With modifications by E. Gunther, M. Pagano,
                and P. Sánchez Terraf
*)

section \<open>Relativization and Absoluteness\<close>

theory Relative imports ZF begin

subsection\<open>Relativized versions of standard set-theoretic concepts\<close>

definition
  empty :: "[i=>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
    \<comment> \<open>the cleaner
      \<^term>\<open>\<exists>r'[M]. is_converse(M,r,r') & is_domain(M,r',z)\<close>
      unfortunately needs an instance of separation in order to prove
        \<^term>\<open>M(converse(r))\<close>.\<close>
    "is_range(M,r,z) ==
        \<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
     \<comment> \<open>an ordinal is a transitive set of transitive sets\<close>
    "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
    \<comment> \<open>a limit ordinal is a non-empty, successor-closed ordinal\<close>
    "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
    \<comment> \<open>a successor ordinal is any ordinal that is neither empty nor limit\<close>
    "successor_ordinal(M,a) ==
        ordinal(M,a) & ~ empty(M,a) & ~ limit_ordinal(M,a)"

definition
  finite_ordinal :: "[i=>o,i] => o" where
    \<comment> \<open>an ordinal is finite if neither it nor any of its elements are limit\<close>
    "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
    \<comment> \<open>omega is a limit ordinal none of whose elements are limit\<close>
    "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
    \<comment> \<open>as above, but typed\<close>
    "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\<open>Useful when absoluteness reasoning has replaced the predicates by terms\<close>
lemma triv_Relation1:
     "Relation1(M, A, \<lambda>x y. y = f(x), f)"
by (simp add: Relation1_def)

lemma triv_Relation2:
     "Relation2(M, A, B, \<lambda>x y a. a = f(x,y), f)"
by (simp add: Relation2_def)

subsection \<open>The relativized ZF axioms\<close>

definition
  extensionality :: "(i=>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
    \<comment> \<open>The formula \<open>P\<close> should only involve parameters
        belonging to \<open>M\<close> and all its quantifiers must be relativized
        to \<open>M\<close>.  We do not have separation as a scheme; every instance
        that we need must be assumed (and later proved) separately.\<close>
    "separation(M,P) ==
        \<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\<open>A trivial consistency proof for $V_\omega$\<close>

text\<open>We prove that $V_\omega$
      (or \<open>univ\<close> in Isabelle) satisfies some ZF axioms.
     Kunen, Theorem IV 3.13, page 123.\<close>

lemma univ0_downwards_mem: "[| 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\<open>Congruence rule for separation: can assume the variable is in \<open>M\<close>\<close>
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\<open>Congruence rule for replacement\<close>
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\<open>The extensionality axiom\<close>
lemma "extensionality(\<lambda>x. x \<in> univ(0))"
apply (simp add: extensionality_def)
apply (blast intro: univ0_downwards_mem)
done

text\<open>The separation axiom requires some lemmas\<close>
lemma Collect_in_Vfrom:
     "[| 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)

lemma "separation(\<lambda>x. x \<in> univ(0), P)"
apply (simp add: separation_def, clarify)
apply (rule_tac x = "Collect(z,P)" in bexI)
apply (blast intro: Collect_in_univ Transset_0)+
done

text\<open>Unordered pairing axiom\<close>
lemma "upair_ax(\<lambda>x. x \<in> univ(0))"
apply (simp add: upair_ax_def upair_def)
apply (blast intro: doubleton_in_univ)
done

text\<open>Union axiom\<close>
lemma "Union_ax(\<lambda>x. x \<in> univ(0))"
apply (simp add: Union_ax_def big_union_def, clarify)
apply (rule_tac x="\<Union>x" in bexI)
 apply (blast intro: univ0_downwards_mem)
apply (blast intro: Union_in_univ Transset_0)
done

text\<open>Powerset axiom\<close>

lemma Pow_in_univ:
     "[| X \<in> univ(A);  Transset(A) |] ==> Pow(X) \<in> univ(A)"
apply (simp add: univ_def Pow_in_VLimit)
done

lemma "power_ax(\<lambda>x. x \<in> univ(0))"
apply (simp add: power_ax_def powerset_def subset_def, clarify)
apply (rule_tac x="Pow(x)" in bexI)
 apply (blast intro: univ0_downwards_mem)
apply (blast intro: Pow_in_univ Transset_0)
done

text\<open>Foundation axiom\<close>
lemma "foundation_ax(\<lambda>x. x \<in> univ(0))"
apply (simp add: foundation_ax_def, clarify)
apply (cut_tac A=x in foundation)
apply (blast intro: univ0_downwards_mem)
done

lemma "replacement(\<lambda>x. x \<in> univ(0), P)"
apply (simp add: replacement_def, clarify)
oops
text\<open>no idea: maybe prove by induction on the rank of A?\<close>

text\<open>Still missing: Replacement, Choice\<close>

subsection\<open>Lemmas Needed to Reduce Some Set Constructions to Instances
      of Separation\<close>

lemma image_iff_Collect: "r `` A = {y \<in> \<Union>(\<Union>(r)). \<exists>p\<in>r. \<exists>x\<in>A. p=<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\<open>These two lemmas lets us prove \<open>domain_closed\<close> and
      \<open>range_closed\<close> without new instances of separation\<close>

lemma domain_eq_vimage: "domain(r) = r -`` Union(Union(r))"
apply (rule equalityI, auto)
apply (rule vimageI, assumption)
apply (simp add: Pair_def, blast)
done

lemma range_eq_image: "range(r) = r `` Union(Union(r))"
apply (rule equalityI, auto)
apply (rule imageI, assumption)
apply (simp add: Pair_def, blast)
done

lemma replacementD:
    "[| 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\<open>More constants, for order types\<close>

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 \<comment> \<open>membership relation\<close>
    "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\<open>Introducing a Transitive Class Model\<close>

text\<open>The class M is assumed to be transitive and inhabited\<close>
locale M_trans =
  fixes M
  assumes transM:   "[| y\<in>x; M(x) |] ==> M(y)"
    and M_inhabited: "\<exists>x . M(x)"

lemma (in M_trans) nonempty [simp]:  "M(0)"
proof -
  have "M(x) \<longrightarrow> M(0)" for x
  proof (rule_tac P="\<lambda>w. M(w) \<longrightarrow> M(0)" in eps_induct)
    {
    fix x
    assume "\<forall>y\<in>x. M(y) \<longrightarrow> M(0)" "M(x)"
    consider (a) "\<exists>y. y\<in>x" | (b) "x=0" by auto
    then
    have "M(x) \<longrightarrow> M(0)"
    proof cases
      case a
      then show ?thesis using \<open>\<forall>y\<in>x._\<close> \<open>M(x)\<close> transM by auto
    next
      case b
      then show ?thesis by simp
    qed
  }
  then show "M(x) \<longrightarrow> M(0)" if "\<forall>y\<in>x. M(y) \<longrightarrow> M(0)" for x
    using that by auto
  qed
  with M_inhabited
  show "M(0)" using M_inhabited by blast
qed

text\<open>The class M is assumed to be transitive and to satisfy some
      relativized ZF axioms\<close>
locale M_trivial = M_trans +
  assumes upair_ax:         "upair_ax(M)"
      and Union_ax:         "Union_ax(M)"

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

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

lemma (in M_trans) 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\<open>Simplifies proofs of equalities when there's an iff-equality
      available for rewriting, universally quantified over M.
      But it's not the only way to prove such equalities: its
      premises \<^term>\<open>M(A)\<close> and  \<^term>\<open>M(B)\<close> can be too strong.\<close>
lemma (in M_trans) M_equalityI:
     "[| !!x. M(x) ==> x\<in>A \<longleftrightarrow> x\<in>B; M(A); M(B) |] ==> A=B"
by (blast dest: transM)

subsubsection\<open>Trivial Absoluteness Proofs: Empty Set, Pairs, etc.\<close>

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

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

lemma (in M_trans) upair_abs [simp]:
     "M(z) ==> upair(M,a,b,z) \<longleftrightarrow> z={a,b}"
apply (simp add: upair_def)
apply (blast intro: transM)
done

lemma (in M_trivial) upair_in_MI [intro!]:
     " M(a) & M(b) \<Longrightarrow> M({a,b})"
by (insert upair_ax, simp add: upair_ax_def)

lemma (in M_trans) upair_in_MD [dest!]:
     "M({a,b}) \<Longrightarrow> M(a) & M(b)"
  by (blast intro: transM)

lemma (in M_trivial) upair_in_M_iff [simp]:
  "M({a,b}) \<longleftrightarrow> M(a) & M(b)"
  by blast

lemma (in M_trivial) singleton_in_MI [intro!]:
     "M(a) \<Longrightarrow> M({a})"
  by (insert upair_in_M_iff [of a a], simp)

lemma (in M_trans) singleton_in_MD [dest!]:
     "M({a}) \<Longrightarrow> M(a)"
  by (insert upair_in_MD [of a a], simp)

lemma (in M_trivial) singleton_in_M_iff [simp]:
     "M({a}) \<longleftrightarrow> M(a)"
  by blast

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

lemma (in M_trans) pair_in_MD [dest!]:
     "M(<a,b>) \<Longrightarrow> M(a) & M(b)"
  by (simp add: Pair_def, blast intro: transM)

lemma (in M_trivial) pair_in_MI [intro!]:
     "M(a) & M(b) \<Longrightarrow> M(<a,b>)"
  by (simp add: Pair_def)

lemma (in M_trivial) pair_in_M_iff [simp]:
     "M(<a,b>) \<longleftrightarrow> M(a) & M(b)"
  by blast

lemma (in M_trans) pair_components_in_M:
     "[| <x,y> \<in> A; M(A) |] ==> M(x) & M(y)"
  by (blast dest: transM)

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\<open>Absoluteness for Unions and Intersections\<close>

lemma (in M_trans) union_abs [simp]:
     "[| M(a); M(b); M(z) |] ==> union(M,a,b,z) \<longleftrightarrow> z = a \<union> b"
  unfolding union_def
  by (blast intro: transM )

lemma (in M_trans) inter_abs [simp]:
     "[| M(a); M(b); M(z) |] ==> inter(M,a,b,z) \<longleftrightarrow> z = a \<inter> b"
  unfolding inter_def
  by (blast intro: transM)

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

lemma (in M_trans) Union_abs [simp]:
     "[| M(A); M(z) |] ==> big_union(M,A,z) \<longleftrightarrow> z = \<Union>(A)"
  unfolding big_union_def
  by (blast  dest: transM)

lemma (in M_trivial) Union_closed [intro,simp]:
     "M(A) ==> 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_trans) succ_in_MD [dest!]:
     "M(succ(a)) \<Longrightarrow> M(a)"
  unfolding succ_def
  by (blast intro: transM)

lemma (in M_trivial) succ_in_MI [intro!]:
     "M(a) \<Longrightarrow> M(succ(a))"
  unfolding succ_def
  by (blast intro: transM)

lemma (in M_trivial) succ_in_M_iff [simp]:
     "M(succ(a)) \<longleftrightarrow> M(a)"
  by blast

subsubsection\<open>Absoluteness for Separation and Replacement\<close>

lemma (in M_trans) separation_closed [intro,simp]:
     "[| 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_trans) Collect_abs [simp]:
     "[| M(A); M(z) |] ==> is_Collect(M,A,P,z) \<longleftrightarrow> z = Collect(A,P)"
  unfolding is_Collect_def
  by (blast dest: transM)

subsubsection\<open>The Operator \<^term>\<open>is_Replace\<close>\<close>

lemma is_Replace_cong [cong]:
     "[| 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_trans) 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))"
  unfolding Replace_iff univalent_def
  by (blast dest: transM)

(*The last premise expresses that P takes M to M*)
lemma (in M_trans) strong_replacement_closed [intro,simp]:
     "[| 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_trans) 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_trans) 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\<open>Better than \<open>RepFun_closed\<close> when having the formula \<^term>\<open>x\<in>A\<close>
      makes relativization easier.\<close>
lemma (in M_trans) RepFun_closed2:
     "[| 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 \<open>Absoluteness for \<^term>\<open>Lambda\<close>\<close>

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\<open>Better than \<open>lam_closed\<close>: has the formula \<^term>\<open>x\<in>A\<close>\<close>
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_trans) 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

subsubsection\<open>Relativization of Powerset\<close>

text\<open>What about \<open>Pow_abs\<close>?  Powerset is NOT absolute!
      This result is one direction of absoluteness.\<close>

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

text\<open>But we can't prove that the powerset in \<open>M\<close> includes the
      real powerset.\<close>

lemma (in M_trans) powerset_imp_subset_Pow:
     "[| powerset(M,x,y); M(y) |] ==> y \<subseteq> Pow(x)"
apply (simp add: powerset_def)
apply (blast dest: transM)
done

lemma (in M_trans) powerset_abs:
  assumes
     "M(y)"
  shows
    "powerset(M,x,y) \<longleftrightarrow> y = {a\<in>Pow(x) . M(a)}"
proof (intro iffI equalityI)
  (* First show the converse implication by double inclusion *)
  assume "powerset(M,x,y)"
  with \<open>M(y)\<close>
  show "y \<subseteq> {a\<in>Pow(x) . M(a)}"
    using powerset_imp_subset_Pow transM by blast
  from \<open>powerset(M,x,y)\<close>
  show "{a\<in>Pow(x) . M(a)} \<subseteq> y"
    using transM unfolding powerset_def by auto
next (* we show the direct implication *)
  assume
    "y = {a \<in> Pow(x) . M(a)}"
  then
  show "powerset(M, x, y)"
    unfolding powerset_def subset_def using transM by blast
qed

subsubsection\<open>Absoluteness for the Natural Numbers\<close>

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

lemma (in M_trans) 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\<open>Absoluteness for Ordinals\<close>
text\<open>These results constitute Theorem IV 5.1 of Kunen (page 126).\<close>

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

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

lemma (in M_trans) 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\<open>Kunen continued to 20...\<close>

(*Could not get this to work.  The \<lambda>x\<in>nat is essential because everything
  but the recursion variable must stay unchanged.  But then the recursion
  equations only hold for x\<in>nat (or in some other set) and not for the
  whole of the class M.
  consts
    natnumber_aux :: "[i=>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\<open>Some instances of separation and strong replacement\<close>

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:
     \<comment> \<open>for well-founded recursion: used to prove \<open>is_recfun_equal\<close>\<close>
     "[| 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))"
     and power_ax:         "power_ax(M)"

lemma (in M_trivial) 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\<open>Final, difficult case: the left-to-right direction of the theorem.\<close>
apply (insert power_ax, simp add: power_ax_def)
apply (frule_tac x="A \<union> B" and P="\<lambda>x. rex(M,Q(x))" for Q in rspec)
apply (blast, clarify)
apply (drule_tac x=z and P="\<lambda>x. rex(M,Q(x))" for Q in rspec)
apply assumption
apply (blast intro: cartprod_iff_lemma)
done

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

text\<open>All the lemmas above are necessary because Powerset is not absolute.
      I should have used Replacement instead!\<close>
lemma (in M_basic) cartprod_closed [intro,simp]:
     "[| 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 \<open>converse of a relation\<close>

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 \<open>image, preimage, domain, range\<close>

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\<open>Domain, range and field\<close>

lemma (in M_trans) 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_trans) 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: is_field_def field_def)

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

subsubsection\<open>Relations, functions and application\<close>

lemma (in M_trans) 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_trivial) 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_trivial) 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 (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\<open>Composition of relations\<close>

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\<open>Proving \<^term>\<open>composition(M, r, s, r O s)\<close>\<close>
 prefer 2
 apply (simp add: composition_def comp_def)
 apply (blast dest: transM)
txt\<open>Opposite implication\<close>
apply (rule M_equalityI)
  apply (simp add: composition_def comp_def)
  apply (blast del: allE dest: transM)+
done

text\<open>no longer needed\<close>
lemma (in M_basic) restriction_is_function:
     "[| 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_trans) 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_trans) 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_trans) 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\<open>Some Facts About Separation Axioms\<close>

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_trans) 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)}))"
  by (simp,blast dest: transM)

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\<open>This result is a hint of how little can be done without the Reflection
  Theorem.  The quantifier has to be bounded by a set.  We also need another
  instance of Separation!\<close>
lemma (in M_basic) separation_rall:
     "[|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!:  RepFun_closed dest: transM)
done

subsubsection\<open>Functions and function space\<close>

text\<open>The assumption \<^term>\<open>M(A->B)\<close> is unusual, but essential: in
all but trivial cases, A->B cannot be expected to belong to \<^term>\<open>M\<close>.\<close>
lemma (in M_trivial) is_funspace_abs [simp]:
     "[|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\<open>\<^term>\<open>M\<close> contains all finite function spaces.  Needed to prove the
absoluteness of transitive closure.  See the definition of
\<open>rtrancl_alt\<close> in in \<open>WF_absolute.thy\<close>.\<close>
lemma (in M_basic) finite_funspace_closed [intro,simp]:
     "[|n\<in>nat; M(B)|] ==> M(n->B)"
apply (induct_tac n, simp)
apply (simp add: funspace_succ nat_into_M)
done

subsection\<open>Relativization and Absoluteness for Boolean Operators\<close>

definition
  is_bool_of_o :: "[i=>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\<open>Relativization and Absoluteness for List Operators\<close>

definition
  is_Nil :: "[i=>o, i] => o" where
     \<comment> \<open>because \<^prop>\<open>[] \<equiv> Inl(0)\<close>\<close>
    "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
     \<comment> \<open>because \<^prop>\<open>Cons(a, l) \<equiv> Inr(\<langle>a,l\<rangle>)\<close>\<close>
    "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
    \<comment> \<open>A version of \<^term>\<open>list_case\<close> that's always defined.\<close>
    "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
    \<comment> \<open>Returns 0 for non-lists\<close>
    "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
    \<comment> \<open>A version of \<^term>\<open>hd\<close> that's always defined.\<close>
    "hd'(xs) == if quasilist(xs) then hd(xs) else 0"

definition
  tl' :: "i => i" where
    \<comment> \<open>A version of \<^term>\<open>tl\<close> that's always defined.\<close>
    "tl'(xs) == if quasilist(xs) then tl(xs) else 0"

definition
  is_hd :: "[i=>o,i,i] => o" where
     \<comment> \<open>\<^term>\<open>hd([]) = 0\<close> no constraints if not a list.
          Avoiding implication prevents the simplifier's looping.\<close>
    "is_hd(M,xs,H) ==
       (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
     \<comment> \<open>\<^term>\<open>tl([]) = []\<close>; see comments about \<^term>\<open>is_hd\<close>\<close>
    "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\<open>\<^term>\<open>quasilist\<close>: For Case-Splitting with \<^term>\<open>list_case'\<close>\<close>

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\<open>\<^term>\<open>list_case'\<close>, the Modified Version of \<^term>\<open>list_case\<close>\<close>

lemma list_case'_Nil [simp]: "list_case'(a,b,Nil) = a"
by (simp add: list_case'_def quasilist_def)

lemma list_case'_Cons [simp]: "list_case'(a,b,Cons(x,l)) = b(x,l)"
by (simp add: list_case'_def quasilist_def)

lemma non_list_case: "~ 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\<open>The Modified Operators \<^term>\<open>hd'\<close> and \<^term>\<open>tl'\<close>\<close>

lemma (in M_trivial) is_hd_Nil: "is_hd(M,[],Z) \<longleftrightarrow> empty(M,Z)"
by (simp add: is_hd_def)

lemma (in M_trivial) is_hd_Cons:
     "[|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 MDLEmbedding imports Main
begin
(*>*)

section \<open>MDL Reasoning -- A Semantical Approach\<close>

text \<open>Direct automation of proof calculi such as natural deduction (ND)
      or Hilbert-style systems is usually unfeasible in practice.
      The calculi do not provide reasonable proof guidance for
      theorem proving systems and, thus, perform poorly.
      Popular calculi well-suited for automation are resolution,
      superposition, tableaux-based systems, connection calculi
      and many more. However, implementing such calculi is hard
      work and proving them correct can also be a large task.\<close>

text \<open>Another approach is to utilize the expressivity of Isabelle's
     underlying higher-order logic (HOL) to encode MDL's semantics
     into HOL and then use already existing automation methods
     for HOL for reasoning within MDL.\<close>

text \<open>The embedding explicitly encodes the Kripke-style semantics
      of MDL (Modal logic D) as follows:\<close>

typedecl i                   \<comment> \<open>type for possible worlds\<close>
type_synonym \<sigma> = "(i\<Rightarrow>bool)" \<comment> \<open>propositions are lifted to predicates on worlds\<close>

locale MDL =
  fixes
    r :: "i\<Rightarrow>i\<Rightarrow>bool" (infixr "r" 70) \<comment> \<open>the accessibility relation\<close>
  assumes
    seriality: "\<forall>w. \<exists>v. w r v" \<comment> \<open>the usual assumption for MDL\<close>
begin
text \<open>In the following, the definitions of all logical connectives
      are given with respect to their semantics.\<close>

 abbreviation mnot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)
  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
 abbreviation mand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51)
  where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
 abbreviation mor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50)
  where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
 abbreviation mimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49)
  where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
 abbreviation mequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<equiv>"48)
  where "\<phi>\<^bold>\<equiv>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"
 abbreviation mobligatory :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circle>")
  where "\<^bold>\<circle> \<phi> \<equiv> \<lambda>w. \<forall>v.  w r v \<longrightarrow> \<phi>(v)"
 abbreviation mforbidden :: "\<sigma>\<Rightarrow>\<sigma>" ("F")
  where "F \<phi> \<equiv> \<^bold>\<circle> (\<^bold>\<not> \<phi>)"
 abbreviation mpermitted :: "\<sigma>\<Rightarrow>\<sigma>" ("P")
  where "P \<phi> \<equiv> \<^bold>\<not> (\<^bold>\<circle> (\<^bold>\<not> \<phi>))"

 text \<open>The meta-logical notion valid is used to ground formulas
      of MDL to truth-values within HOL (i.e. Isabelle). It's
      definition is straight-forward: A MDL formula is (globally)
      valid iff it holds in every possible world.\<close>
 abbreviation valid :: "\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>"[7]8)
   where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"

 text \<open>We can also define local validity as validity in a
      certain given world w:\<close>
 abbreviation validInCW :: "\<sigma> \<Rightarrow> i \<Rightarrow> bool" ("\<lfloor>_\<rfloor>\<^sub>_"[7]8)
  where "\<lfloor>p\<rfloor>\<^sub>w \<equiv> p w"
end

text \<open>Now we already have everything we need for reasoning within
      MDL. Using the definitions/abbreviations above, formulas
      that are inputted are being internally unfolded to HOL formulas
      and we can use every proof strategy of Isabelle to tackle them.\<close>

subsection \<open>Some properties of MDL\<close>

text \<open>We can easily verify the basic properties of MDL:\<close>

lemma (in MDL) D:
  "\<lfloor>\<^bold>\<not> ((\<^bold>\<circle>\<phi>) \<^bold>\<and> (\<^bold>\<circle>(\<^bold>\<not>\<phi>)))\<rfloor>" sledgehammer oops
lemma (in MDL) K: "\<lfloor>((\<^bold>\<circle>\<phi>) \<^bold>\<and> (\<^bold>\<circle>(\<phi> \<^bold>\<rightarrow> \<psi>)) \<^bold>\<rightarrow> (\<^bold>\<circle>\<psi>))\<rfloor>" sledgehammer
lemma (in MDL) NEC: "\<lfloor>\<phi>\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<circle>\<phi>\<rfloor>" by simp \<comment> \<open>@{text "\<Longrightarrow>"} is meta-level implication\<close>
lemma (in MDL) RM: "\<lfloor>\<phi> \<^bold>\<rightarrow> \<psi>\<rfloor> \<Longrightarrow> \<lfloor>(\<^bold>\<circle>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<circle>\<psi>)\<rfloor>" by simp

text \<open>We can also reason about MDL in this setting, e.g.
      for verifying that the axiom D corresponds to
      serial frames:\<close>
lemma (in MDL) D_equivalent_to_seriality:
  "\<lfloor>\<^bold>\<not> ((\<^bold>\<circle>\<phi>) \<^bold>\<and> (\<^bold>\<circle>(\<^bold>\<not>\<phi>)))\<rfloor> \<equiv> (\<forall>w. \<exists>v. w r v)" sledgehammer

text \<open>We can check for consistency of our theory at any time:\<close>
lemma (in MDL) True nitpick [satisfy,user_axioms,expect=genuine] oops
  \<comment> \<open>Consistency is confirmed by Nitpick\<close>

text \<open>And we can get explicit (counter-) models generated for
      formulas that do not hold in general.\<close>
lemma (in MDL) MC: "\<lfloor>\<phi> \<^bold>\<rightarrow> (\<^bold>\<circle>\<phi>)\<rfloor>"  \<comment> \<open>Modal Collapse\<close>
  nitpick [user_axioms,expect=genuine] oops
  \<comment> \<open>Counter model by Nitpick, that is, Modal Collapse for O does not hold\<close>

paragraph \<open>Examples from the exercises\<close>

text \<open>We define short hands for the both relation properties:\<close>
abbreviation transitive
  where "transitive R \<equiv> \<forall>w v u. ((R w v) \<and> (R v u)) \<longrightarrow> R w u"
abbreviation euclidean
  where "euclidean R \<equiv> \<forall> s t u. ((R s t) \<and> (R s u)) \<longrightarrow> R t u"

subparagraph \<open>Exercise 1\<close>

text \<open>Does it hold that the formula @{text \<open>\<^bold>\<circle> \<phi> \<^bold>\<rightarrow> \<^bold>\<circle>(\<^bold>\<circle> \<phi>)\<close>}
     is valid if @{term "r"} is not transitive?\<close>

lemma (in MDL)
  assumes "\<not> (transitive (r))"
  shows "\<lfloor>\<^bold>\<circle> \<phi> \<^bold>\<rightarrow> \<^bold>\<circle>(\<^bold>\<circle> \<phi>)\<rfloor>"
  nitpick[expect=genuine, atoms = s t, card i = 2]
  oops

text \<open>No, there is a counter-model provided by nitpick. It
      The counter model can directly be reconstructed from
      nitpick's answer. \<close>

subparagraph \<open>Exercise 2\<close>

text \<open>Prove that @{text "\<^bold>\<circle> \<phi> \<^bold>\<rightarrow> \<^bold>\<circle> \<psi>"} whenever @{text "\<phi> \<^bold>\<rightarrow> \<psi>"}.\<close>

lemma (in MDL) ROM: "\<lfloor>\<phi> \<^bold>\<rightarrow> \<psi>\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<circle> \<phi> \<^bold>\<rightarrow> \<^bold>\<circle> \<psi>\<rfloor>" by simp

subparagraph \<open>Exercise 3\<close>

text \<open>Does it hold that the formula @{text \<open>\<^bold>\<not>\<^bold>\<circle> \<phi> \<^bold>\<rightarrow> \<^bold>\<circle>(\<^bold>\<not>\<^bold>\<circle> \<phi>)\<close>}
     is valid if @{term "r"} is euclidean?\<close>

lemma (in MDL) "3a":
  assumes "euclidean (r)"
  shows "\<lfloor>\<^bold>\<not>\<^bold>\<circle> \<phi> \<^bold>\<rightarrow> \<^bold>\<circle>(\<^bold>\<not>\<^bold>\<circle> \<phi>)\<rfloor>"
  nitpick[expect=none]
  sledgehammer
  using assms by blast

text \<open>Yes, nitpick does not find a counter-model and
      sledgehammer suggests a proof in under 5ms.\<close>

lemma (in MDL) "3b":
  assumes "\<not> euclidean (r)"
  shows "\<lfloor>\<^bold>\<not>\<^bold>\<circle> \<phi> \<^bold>\<rightarrow> \<^bold>\<circle>(\<^bold>\<not>\<^bold>\<circle> \<phi>)\<rfloor>"
  nitpick[expect=genuine,atoms = s t]
  oops

text \<open>On the contrary, if @{text "r"} is not euclidean,
      then the conjecture does not hold any more. Nitpick
     gives a minimal counter-model with two worlds s and t.\<close>

subsection \<open>Chisholm's Paradox in MDL\<close>

text \<open>Let's use the automation of MDL to assess Chisholm's paradox
      with automated reasoning mechanisms:\<close>

paragraph \<open>The set-up.\<close>
text \<open>We define a locale that gives raise to the vocabulary
      (and possibly additional assumptions) of an experiment
      scenario.\<close>

locale Chisholm = MDL +
  fixes \<comment> \<open>We fix local assumptions to our experiment.\<close>
    go :: \<sigma> and \<comment> \<open>both from Chisholm's paradox\<close>
    tell :: \<sigma> and
    kill :: \<sigma> and
    w :: i \<comment> \<open>current world\<close>
begin

text \<open>Define the axioms of the paradox as shorthands D1, D2, D3 and D4,
and, for D2 and D3, both the wide and narrow interpretation.\<close>

text \<open>It is obligatory to go and help.\<close>
abbreviation D1 where "D1 \<equiv> \<lfloor>\<^bold>\<circle> go\<rfloor>\<^sub>w" \<comment> \<open>everything local\<close>

text \<open>If you go, you must tell your neighbor.\<close>
abbreviation D2_wide ("D2\<^sup>w") where "D2\<^sup>w \<equiv> \<lfloor>\<^bold>\<circle> (go \<^bold>\<rightarrow> tell)\<rfloor>\<^sub>w"
abbreviation D2_narrow ("D2\<^sup>n") where "D2\<^sup>n \<equiv> \<lfloor>go \<^bold>\<rightarrow> \<^bold>\<circle>tell\<rfloor>\<^sub>w"

text \<open>If you do not go, do not tell your neighbor.\<close>
abbreviation D3_wide ("D3\<^sup>w") where "D3\<^sup>w \<equiv> \<lfloor>\<^bold>\<circle>( \<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<not>tell )\<rfloor>\<^sub>w"
abbreviation D3_narrow ("D3\<^sup>n") where "D3\<^sup>n \<equiv> \<lfloor>(\<^bold>\<not>go) \<^bold>\<rightarrow> (\<^bold>\<circle> (\<^bold>\<not>tell))\<rfloor>\<^sub>w"

text \<open>You do not go.\<close>
abbreviation D4 where "D4 \<equiv> \<lfloor>\<^bold>\<not> go\<rfloor>\<^sub>w"

text \<open>As can be seen above, we have defined two variants
      of D2 and D3, referred to as narrow- and wide-scope interpretations.
      We select the concrete D2/D3 by ...\<close>

abbreviation D2 where "D2 \<equiv> D2\<^sup>w" (* we can change it here to wide/narrow *)
abbreviation D3 where "D3 \<equiv> D3\<^sup>n" (* this way, we dont need to change the lemmas below *)

text \<open>We can access the definitions directly or just change to above two
lines if we want to change the interpretations for our experiments.\<close>

text \<open>You should kill the boss. Just as an example statement
      that we really do not want to be true.\<close>
abbreviation D5 where "D5 \<equiv> \<lfloor>\<^bold>\<circle> kill\<rfloor>\<^sub>w"
end

paragraph \<open>The experiments.\<close>
text \<open>Now we can start assessing the concrete examples:\<close>

subparagraph \<open>Inconsistency.\<close>
text \<open>We can prove falsity from the assumptions D1, D2, D3 and D4.\<close>
theorem (in Chisholm)
  assumes D1 and D2 and D3 and D4
  shows False
using seriality assms by fastforce

text \<open>This implies that the assumptions are inconsistent and we can prove
anything, e.g. that we should kill our Boss:\<close>

theorem (in Chisholm)
  assumes D1 and D2 and D3 and D4
  shows D5
  sledgehammer
  using assms seriality by blast

text \<open>Sledgehammer finds a proof for this in less than 5ms.\<close>

subparagraph \<open>Logical independence\<close>
text \<open>We can also assess logical independence. Depending
on the choice of narrow/wide scope interpretations, either
the theory will be inconsistent or logically dependent.\<close>

lemma (in Chisholm)
  assumes D2 and D3 and D4
  shows D1 nitpick[user_axioms, expect=genuine, show_all] oops

lemma (in Chisholm)
  assumes D1 and D3 and D4
  shows D2 nitpick[user_axioms, expect=genuine, show_all] oops

lemma (in Chisholm)
  assumes D1 and D2 and D4
  shows D3 nitpick[user_axioms, expect=genuine, show_all] oops

lemma (in Chisholm)
  assumes D1 and D2 and D3
  shows D4 nitpick[user_axioms, expect=genuine, show_all] oops

text \<open>Currently, the theory is logically independent (but inconsistent),
      as certified by nitpick (giving counter-models to the
      conjecture of logical dependence). These results of
      course change if D2 and D3 are chosen with other scope.\<close>

section \<open>Forrester's Paradox\<close>

text \<open>Just as above, we define a local scope for the experiments
      with Forrester's paradox:\<close>

locale Forrester = MDL +
  fixes
    red :: \<sigma> and
    scarlet :: \<sigma> and \<comment> \<open>both from Forrester's paradox\<close>
    w :: i \<comment> \<open>current world\<close>
  assumes
    scarlet_implies_red: "\<lfloor>scarlet \<^bold>\<rightarrow> red\<rfloor>"
begin

text \<open>You ought not dress red.\<close>
abbreviation F1
  where "F1 \<equiv> \<lfloor>\<^bold>\<circle>(\<^bold>\<not>red)\<rfloor>\<^sub>w"

text \<open>If you dress red, you ought dress scarlet\<close>
abbreviation F2_narrow ("F2\<^sup>n")
  where "F2\<^sup>n \<equiv> \<lfloor>(red \<^bold>\<rightarrow> \<^bold>\<circle>scarlet)\<rfloor>\<^sub>w"
abbreviation F2_wide ("F2\<^sup>w")
  where "F2\<^sup>w \<equiv> \<lfloor>\<^bold>\<circle>(red \<^bold>\<rightarrow> scarlet)\<rfloor>\<^sub>w"

text \<open>You dress red.\<close>
abbreviation F3
  where "F3 \<equiv> \<lfloor>red\<rfloor>\<^sub>w"

(* select the interpretation *)
abbreviation F2
  where "F2 \<equiv> F2\<^sup>n"
end

lemma (in Forrester)
  assumes F1 and F2 and F3
  shows "False"
  nitpick
  using assms scarlet_implies_red seriality by blast
text \<open>Again, the theory is inconsistent.\<close>

text \<open>Logical independence can again be assessed for different
      scope interpretations:\<close>

lemma  (in Forrester)
  assumes F1 and F2
  shows F3
  nitpick oops

lemma (in Forrester)
  assumes F1 and F3
  shows F2
  nitpick oops

lemma (in Forrester)
  assumes F2 and F3
  shows F1
  nitpick oops

  text_raw \<open>\pagebreak\<close>

section \<open>About using Cups.\<close>

locale Cup = MDL +
  fixes \<comment> \<open>We fix local assumptions to our experiment.\<close>
    useCup :: \<sigma> and \<comment> \<open>Using the cup\<close>
    putInDishwasher :: \<sigma> and \<comment> \<open>Putting the cup in the dishwasher\<close>
    w :: i \<comment> \<open>current world\<close>

  assumes "\<lfloor> putInDishwasher \<^bold>\<rightarrow> useCup \<rfloor>" \<comment> \<open>Implicit: If I put a cup in the dishwasher;
                                             I'm practically using it.\<close>
begin

  text \<open>You ought not use non-stock cups.\<close>
  abbreviation F1 where "F1 \<equiv> \<lfloor>\<^bold>\<circle>(\<^bold>\<not>useCup)\<rfloor>"

  text \<open>If you use non-stock cups, you ought to put them into the dishwasher\<close>
  abbreviation F2 ("F2")  where "F2 \<equiv> \<lfloor>(useCup \<^bold>\<rightarrow> \<^bold>\<circle>putInDishwasher)\<rfloor>"

  text \<open>I use a non-stock cup.\<close>
  abbreviation F3 where "F3 \<equiv> \<lfloor>useCup\<rfloor>\<^sub>w"

  lemma
    assumes F1 and F2 and F3
    shows "False"
    using Cup.axioms(2) Cup_axioms Cup_axioms_def D assms(1) assms(2) assms(3) by fastforce

  text \<open>As a consequence, we see that we get in a crazy situation (Falsity is true!)
if using non-stock cups.\<close>
end

  text_raw \<open>\pagebreak\<close>

(*<*)
end
(*>*)


theory Add_Cancel_Distinct

imports
  "HOL-Library.Multiset"

begin

text \<open>
Cancelling of terms in an equality of additions, which can be applied
to multisets to prove lists are permutations of each other, and in
particular can be used to prove distinctness of lists by sorting them.
\<close>

locale add_cancel_many_helpers begin

lemma cancel_some_shape:
  fixes x :: "'a :: cancel_semigroup_add"
  shows "(x \<equiv> x_same + x_rest) \<Longrightarrow> (y \<equiv> y_same + y_rest) \<Longrightarrow>
    x_same = y_same \<Longrightarrow> (x = y) = (x_rest = y_rest)"
  by simp

lemma eq_split_rules:
  fixes x :: "'a :: {cancel_semigroup_add, ab_semigroup_add}"
  shows
  "((x + a) = ((x + b) + c)) = (a = b + c)"
  "((x + a) = (b + (x + c))) = (a = b + c)"
  by (simp_all add: add.assoc add.left_commute[where a=x and b=b])

end

ML \<open>

structure Add_Cancel_Many = struct

fun dest_sum ct = let
    val t = Thm.term_of ct
    val _ = HOLogic.dest_bin \<^const_name>\<open>Groups.plus\<close> dummyT t
    val (x, y) = Thm.dest_binop ct
  in x :: dest_sum y end handle TERM _ => [ct]

fun dest_sum_tree [] = []
  | dest_sum_tree (ct :: cts) = case dest_sum ct of
    [x] => x :: dest_sum_tree cts
  | xs => dest_sum_tree (xs @ cts)

fun dest_sum_tree_reassoc ct = let
    val xs = dest_sum_tree [ct]
    val ys = dest_sum ct
  in (length xs <> length ys, xs) end

fun mk_sum _ [ct] = ct
  | mk_sum _ [] = raise TERM ("mk_sum", [])
  | mk_sum plus (x :: y :: zs) = Thm.mk_binop plus x (mk_sum plus (y :: zs))

fun simp_only ctxt thms = simp_tac ((put_simpset HOL_basic_ss ctxt) addsimps thms)

fun mk_meta_eq ctxt x y = let
    val eq = Logic.mk_equals (Thm.term_of x, Thm.term_of y)
    val ct = head_of eq |> Thm.cterm_of ctxt
  in Thm.mk_binop ct x y end

(* tag which elements of a summation will be selected, using a fresh
    free variable, to avoid confusion involving identical elements. *)
fun tag_sum_conv ctxt select_elems x ct = let
    val ys = dest_sum_tree [ct]
    val plus = Thm.dest_fun2 ct
    val t_of = Thm.term_of
    val sel_tab = Termtab.make_list
        (map (fn ct => (t_of ct, ())) select_elems)
    val ty = fastype_of (t_of ct)
    val tag1 = HOLogic.pair_const (fastype_of x) ty $ x |> Thm.cterm_of ctxt
    val tag2 = HOLogic.mk_snd (HOLogic.mk_prod (x, t_of ct))
        |> head_of |> Thm.cterm_of ctxt
    val tag = Thm.apply tag1 #> Thm.apply tag2
    fun f _ [] = []
      | f tab (y :: ys) = (case Termtab.lookup tab (t_of y) of
            SOME (_ :: zs) => tag y :: f (Termtab.update (t_of y, zs) tab) ys
          | _ => y :: f tab ys)
    val rhs = f sel_tab ys |> mk_sum plus
    val eq = mk_meta_eq ctxt ct rhs
  in Goal.prove_internal ctxt [] eq
    (fn _ => simp_only ctxt @{thms add.assoc snd_conv} 1)
  end

fun prove_eq_split_tac ctxt =
    simp_only ctxt @{thms add_cancel_many_helpers.eq_split_rules}
        THEN_ALL_NEW simp_only ctxt @{thms refl add.commute}

fun prove_eq_split ctxt ct = Goal.prove_internal ctxt [] ct
    (fn _ => prove_eq_split_tac ctxt 1)

fun has_var v (f $ x) = has_var v f orelse has_var v x
  | has_var v (Abs (_, _, t)) = has_var v t
  | has_var v t = (t = v)

fun split_by_var_conv ctxt v ct = let
    val xs = dest_sum ct
    val choose_xs = filter (has_var v o Thm.term_of) xs
    val other_xs = filter_out (has_var v o Thm.term_of) xs
    val plus = Thm.dest_fun2 ct
    val rhs = Thm.mk_binop plus (mk_sum plus choose_xs) (mk_sum plus other_xs)
    val prop = mk_meta_eq ctxt ct rhs
  in Goal.prove_internal ctxt [] prop
    (fn _ => resolve_tac ctxt @{thms eq_reflection} 1
        THEN prove_eq_split_tac ctxt 1)
  end

fun cancel_step ctxt ct = let
    val t = Thm.term_of ct
    val _ = HOLogic.dest_eq t
    val (lhs, rhs) = Thm.dest_binop ct
    val lhs_bits = dest_sum_tree [lhs]
    val rhs_bits = dest_sum_tree [rhs]
    val lhs_sort = sort Thm.fast_term_ord lhs_bits
    val rhs_sort = sort Thm.fast_term_ord rhs_bits
    val choose = if list_ord Thm.fast_term_ord (lhs_sort, rhs_sort) = EQUAL
      then take (length lhs_sort div 2) lhs_sort
      else Ord_List.inter Thm.fast_term_ord lhs_sort rhs_sort
    val choose2 = if length choose < Int.min (length lhs_sort, length rhs_sort)
      then choose else List.tl choose
    val _ = List.hd choose2 (* raise Empty if no progress can be made *)
    val x = Variable.variant_frees ctxt [t] [("x", @{typ unit})]
        |> the_single |> Free
    val conv = tag_sum_conv ctxt choose2 x then_conv split_by_var_conv ctxt x
    val lhs_split = conv lhs
    val rhs_split = conv rhs
  in
    ([lhs_split, rhs_split]
        MRS @{thm add_cancel_many_helpers.cancel_some_shape})
    RS @{thm eq_reflection}
  end

fun cancel ctxt ct = let
    val thm1 = cancel_step ctxt ct
    fun prove_asm ct = Goal.prove_internal ctxt [] ct
      (fn _ => (simp_only ctxt @{thms refl add_left_cancel}
        THEN_ALL_NEW CONVERSION (Conv.arg_conv (cancel ctxt))
        THEN_ALL_NEW (simp_only ctxt @{thms refl})) 1)
    val prems = Thm.cprems_of thm1 |> map prove_asm
    val step1 = prems MRS thm1
  in ((fn _ => step1) then_conv cancel ctxt) ct
    handle Empty => step1
  end

end
\<close>

lemma distinct_mset:
  "distinct xs = (\<forall>x. count (mset xs) x \<le> 1)"
  apply (induct xs, simp_all add: all_conj_distrib)
  apply (metis count_mset_0_iff le_SucI order_refl)
  done

lemma distinct_mset_eq:
  "distinct xs \<Longrightarrow> mset xs = mset ys \<Longrightarrow> distinct ys"
  by (simp add: distinct_mset)

lemma mset_to_plus:
  "mset (x # y # zs) = mset [x] + mset (y # zs)"
  by simp

lemma distinct_sorted_wrt:
  "distinct xs = sorted_wrt (\<noteq>) xs"
  by (induct xs, auto)

lemma distinct_via_sorted:
  "irreflp R \<Longrightarrow> sorted_wrt R xs \<Longrightarrow> distinct xs"
  by (clarsimp simp: distinct_sorted_wrt irreflp_def
    elim!: sorted_wrt_mono_rel[rotated])

ML \<open>
structure Distinct_Tac = struct

val thm = @{thm distinct_via_sorted[THEN distinct_mset_eq]}

val simp_only = Add_Cancel_Many.simp_only

fun mset_eq_tac ctxt = simp_only ctxt @{thms mset_to_plus}
    THEN_ALL_NEW CONVERSION (Conv.arg_conv (Add_Cancel_Many.cancel ctxt))
    THEN_ALL_NEW simp_only ctxt @{thms refl}

fun solve nm tac = (tac THEN_ALL_NEW SUBGOAL
        (fn (t, _) => raise TERM (nm ^ ": unsolved subgoal", [t])))
    ORELSE' SUBGOAL (fn (t, _) => raise TERM (nm ^ ": tactic failed", [t]))

fun main_tac ctxt dest ord rel = SUBGOAL (fn (t, i) => let
    val xs_t = case HOLogic.dest_Trueprop t of
        Const (@{const_name distinct}, _) $ xs => xs
      | t => raise TERM ("distinct_tac: not distinct", [t])
    val xs = HOLogic.dest_list xs_t
    val ys = map (fn x => (dest x, x)) xs |> sort (ord o apply2 fst)
    val ys_t = HOLogic.mk_list (fastype_of (hd xs)) (map snd ys)
    val thm1 = Drule.infer_instantiate' ctxt
        (map (SOME o Thm.cterm_of ctxt) [fst rel, ys_t, xs_t])
        thm
  in (resolve_tac ctxt [thm1]
    THEN' solve "irreflp" (simp_only ctxt (snd rel))
    THEN' (solve "mset_eq_tac" (mset_eq_tac ctxt) o (fn j => j + 1))
    THEN' simp_only ctxt (@{thms sorted_wrt2_simps} @ snd rel))
    i
  end)

fun tac ctxt dest ord rel = simp_only ctxt @{thms distinct.simps(1) distinct_singleton}
    THEN_ALL_NEW main_tac ctxt dest ord rel

end

\<close>

definition
  fast_list_ord :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> (bool \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where
  "fast_list_ord R f xs ys = (length xs < length ys \<or>
    (length xs = length ys \<and> f (List.lexordp R xs ys)))"

lemma fast_list_ord_eq_lex:
  "fast_list_ord R (\<lambda>x. x) xs ys = ((xs, ys) \<in> (length <*mlex*> List.lexord {(x, y). R x y}))"
  by (simp add: fast_list_ord_def mlex_prod_def lexordp_def)

lemma fast_list_ord_simps[simp]:
  "fast_list_ord R f [] [] = f False"
  "fast_list_ord R b [] (y # ys) = True"
  "fast_list_ord R b (x # xs) [] = False"
  "fast_list_ord R f (x # xs) (y # ys) = fast_list_ord R (\<lambda>b. f (R x y \<or> (x = y \<and> b))) xs ys"
  by (simp_all add: fast_list_ord_def lexordp_def)

lemma fast_list_ord_irreflp:
  "irreflp R \<Longrightarrow> irreflp (fast_list_ord R (\<lambda>x. x))"
  by (simp add: fast_list_ord_def irreflp_def lexordp_def lexord_irreflexive)

lemma fast_list_ord_transp:
  "transp R \<Longrightarrow> transp (fast_list_ord R (\<lambda>x. x))"
  apply (simp add: transp_trans fast_list_ord_eq_lex mlex_prod_def del: in_inv_image)
  apply (simp add: trans_inv_image lexord_transI)
  done

lemma string_ord_transp:
  "transp (fast_list_ord (\<lambda>x y. (of_char x < (of_char y :: nat))) (\<lambda>x. x))"
  using trans_inv_image[of "measure id" of_char]
  apply (simp add: inv_image_def)
  apply (rule fast_list_ord_transp)
  apply (simp add: transp_trans trans_def[where r="measure _"])
  done

lemma string_ord_irreflp:
  "irreflp (fast_list_ord (\<lambda>x y. (of_char x < (of_char y :: nat))) (\<lambda>x. x))"
  by (simp add: irreflp_def fast_list_ord_def lexordp_def lexord_irreflexive)

method_setup distinct_string = \<open>
  Scan.succeed (fn ctxt => Method.SIMPLE_METHOD
    (Distinct_Tac.tac ctxt (HOLogic.dest_string) fast_string_ord
        (@{term "fast_list_ord (\<lambda>x y. of_char x < (of_char y :: nat)) (\<lambda>x. x)"},
            @{thms string_ord_irreflp string_ord_transp})
        1))
\<close>

ML \<open>
fun dest_nat (Const (@{const_name Suc}, _) $ n) = dest_nat n + 1
  | dest_nat n = snd (HOLogic.dest_number n)
\<close>

lemma irreflp_less:
  "irreflp ((<) :: ('a :: order) \<Rightarrow> _)"
  by (simp add: irreflpI)

method_setup distinct_nat = \<open>
  Scan.succeed (fn ctxt => Method.SIMPLE_METHOD
    (Distinct_Tac.tac ctxt dest_nat Int.compare
        (@{term "(<) :: nat \<Rightarrow> _"}, @{thms irreflp_less transp_less})
        1))
\<close>

method_setup distinct_int = \<open>
  Scan.succeed (fn ctxt => Method.SIMPLE_METHOD
    (Distinct_Tac.tac ctxt (snd o HOLogic.dest_number) Int.compare
        (@{term "(<) :: int \<Rightarrow> _"}, @{thms irreflp_less transp_less})
        1))
\<close>

notepad begin

have "distinct [''x'', ''y'', ''zyx'', ''a'', ''t'', ''hello there'', ''hello again'']"
  by (distinct_string; simp)

have "distinct [Suc 0, 4, 5, 9, 8, 7]"
  by (distinct_nat; simp)

have "distinct [(2 :: int), 4, 5, 9, 8, 7]"
  by (distinct_int; simp)

have "distinct (rev [12 ..< 80])"
  by (simp del: distinct.simps; distinct_nat; simp)

end

end


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

subsection \<open>Miscellaneous lemmas\<close>

method_setup clarsimp_all =
  \<open>Method.sections clasimp_modifiers >>
    K (SIMPLE_METHOD o CHANGED_PROP o PARALLEL_ALLGOALS o clarsimp_tac)\<close>
  "clarify simplified, all goals"

definition flip where
  flip_def: "flip f \<equiv> \<lambda>x y. f y x"

lemma option_expand':
  "\<lbrakk>(option = None) = (option' = None); \<And>x y. \<lbrakk>option = Some x; option' = Some y\<rbrakk> \<Longrightarrow> x = y\<rbrakk> \<Longrightarrow>
    option = option'"
  by(rule option.expand, auto)

(*********************************)
subsection \<open>Argmax\<close>
definition Max_by :: "('a \<Rightarrow> 'b :: linorder) \<Rightarrow> 'a set \<Rightarrow> 'a" where
  "Max_by f S = (SOME x. x \<in> S \<and> f x = Max (f ` S))"

lemma Max_by_dest:
  assumes "finite A" and "A \<noteq> {}"
  shows "Max_by f A \<in> A \<and> f (Max_by f A) = Max (f ` A)" (is "?P (Max_by f A)")
proof(simp only: Max_by_def some_eq_ex[where P="?P"])
  from assms have "finite (f ` A)" "f ` A \<noteq> {}" by auto
  from Max_in[OF this] show "\<exists>x. x \<in> A \<and> f x = Max (f ` A)"
    by (metis image_iff)
qed

lemma Max_by_in:
  assumes "finite A" and "A \<noteq> {}"
  shows "Max_by f A \<in> A" using assms
  by(rule Max_by_dest[THEN conjunct1])

lemma Max_by_ge:
  assumes "finite A" "x \<in> A"
  shows "f x \<le> f (Max_by f A)"
proof-
  from assms(1) have fin_image: "finite (f ` A)" by simp
  from assms(2) have non_empty: "A \<noteq> {}" by auto
  have "f x \<in> f ` A" using assms(2) by simp
  from Max_ge[OF fin_image this] and Max_by_dest[OF assms(1) non_empty, of f] show ?thesis
    by(simp)
qed

lemma finite_UN_D:
  "finite (\<Union>S) \<Longrightarrow> \<forall>A \<in> S. finite A"
  by (metis Union_upper finite_subset)

lemma Max_by_eqI:
  assumes
    fin: "finite A"
    and "\<And>y. y \<in> A \<Longrightarrow> cmp_f y \<le> cmp_f x"
    and in_X: "x \<in> A"
    and inj: "inj_on cmp_f A"
  shows "Max_by cmp_f A = x"
proof-
  have in_M: "Max_by cmp_f A \<in> A" using assms
    by(auto intro!: Max_by_in)
  hence "cmp_f (Max_by cmp_f A) \<le> cmp_f x" using assms
    by auto
  also have "cmp_f x \<le> cmp_f (Max_by cmp_f A)"
    by (intro Max_by_ge assms)
  finally show ?thesis  using inj in_M in_X
    by(auto simp add: inj_on_def)
qed

lemma Max_by_Union_distrib:
  "\<lbrakk> finite A; A = \<Union>S; S \<noteq> {}; {} \<notin> S; inj_on cmp_f A \<rbrakk> \<Longrightarrow>
    Max_by cmp_f A = Max_by cmp_f (Max_by cmp_f ` S)"
proof(rule Max_by_eqI, assumption)
  fix y
  assume assms: "finite A" "A = \<Union>S" "{} \<notin> S" "y \<in> A"
  then obtain B where B_def: "B \<in> S" "y \<in> B" by auto
  hence "cmp_f y \<le> cmp_f (Max_by cmp_f B)" using assms
    by (metis Max_by_ge finite_UN_D)
  also have "... \<le> cmp_f (Max_by cmp_f (Max_by cmp_f ` S))" using B_def(1) assms
    by (metis Max_by_ge finite_UnionD finite_imageI imageI)
  finally show "cmp_f y \<le> cmp_f (Max_by cmp_f (Max_by cmp_f ` S))" .
next
  assume assms: "finite A" "A = \<Union>S" "{} \<notin> S" "S \<noteq> {}"
  hence "Max_by cmp_f ` S \<noteq> {}" "finite (Max_by cmp_f ` S)"
    apply (metis image_is_empty)
    by (metis assms(1) assms(2) finite_UnionD finite_imageI)
  hence "Max_by cmp_f (Max_by cmp_f ` S) \<in> (Max_by cmp_f ` S)"
    by(blast intro!: Max_by_in)
  also have "(Max_by cmp_f ` S) \<subseteq> A"
  proof -
    have f1: "\<forall>v0 v1. (\<not> finite v0 \<or> v0 = {}) \<or> Max_by (v1::'a \<Rightarrow> 'b) v0 \<in> v0" using Max_by_in by blast
    have "\<forall>v1. v1 \<notin> S \<or> finite v1" using assms(1) assms(2) finite_UN_D by blast
    then obtain v2_13 :: "'a set set \<Rightarrow> 'a \<Rightarrow> 'a set" where "Max_by cmp_f ` S \<subseteq> \<Union>S" using f1 assms(3) by blast
    thus "Max_by cmp_f ` S \<subseteq> A" using assms(2) by presburger
  qed
  finally show "Max_by cmp_f (Max_by cmp_f ` S) \<in> A" .
qed

lemma Max_by_UNION_distrib:
  "\<lbrakk>finite A; A = (\<Union>x\<in>S. f x); S \<noteq> {}; {} \<notin> f ` S; inj_on cmp_f A\<rbrakk> \<Longrightarrow>
    Max_by cmp_f A = Max_by cmp_f (Max_by cmp_f ` (f ` S))"
  by(force intro!: Max_by_Union_distrib)

lemma Max_by_eta:
  "Max_by f = (\<lambda>S. (SOME x. x \<in> S \<and> f x = Max (f ` S)))"
  by(auto simp add: Max_by_def)

lemma Max_is_Max_by_id:
  "\<lbrakk> finite S; S \<noteq> {} \<rbrakk> \<Longrightarrow> Max S = Max_by id S "
  apply(clarsimp simp add: Max_by_def)
  by (metis (mono_tags, lifting) Max_in someI_ex)

definition option_Max_by :: "('a \<Rightarrow> 'b :: linorder) \<Rightarrow> 'a set \<Rightarrow> 'a option" where
  "option_Max_by cmp_f A \<equiv> if A = {} then None else Some (Max_by cmp_f A)"

(*********************************)

subsection \<open>Function and map graphs\<close>

definition fun_graph where
  "fun_graph f = {(x, f x)|x. True}"

definition map_graph :: "('a, 'b)map \<Rightarrow> ('a \<times> 'b) set" where
  "map_graph f = {(x, y)|x y. (x, Some y) \<in> fun_graph f}"

lemma map_graph_mem[simp]:
  "((x, y) \<in> map_graph f) = (f x = Some y)"
  by(auto simp add: dom_def map_graph_def fun_graph_def)

lemma finite_fun_graph:
  "finite A \<Longrightarrow> finite (fun_graph f \<inter> (A \<times> UNIV))"
  apply(rule bij_betw_finite[where A=A and f="\<lambda>x. (x, f x)", THEN iffD1])
  by(auto simp add: fun_graph_def bij_betw_def inj_on_def)

lemma finite_map_graph:
  "finite A \<Longrightarrow> finite (map_graph f \<inter> (A \<times> UNIV))"
  by(force simp add: map_graph_def
    dest!: finite_fun_graph[where f=f]
    intro!: finite_surj[where A="fun_graph f \<inter> (A \<times> UNIV)" and f="apsnd the"]
  )

lemma finite_dom_finite_map_graph:
  "finite (dom f) \<Longrightarrow> finite (map_graph f)"
  apply(simp add: dom_def map_graph_def fun_graph_def)
  apply(erule finite_surj[where f="\<lambda>x. (x, the (f x))"])
  apply(clarsimp simp add: image_def)
  by (metis option.sel)

(*******************************************************************)
lemma ran_map_addD:
  "x \<in> ran (m ++ f) \<Longrightarrow> x \<in> ran m \<or> x \<in> ran f"
  by(auto simp add: ran_def)

subsection \<open>Constant maps\<close>

definition const_map :: "'v \<Rightarrow> 'k set \<Rightarrow> ('k, 'v)map" where
  "const_map v S \<equiv> (\<lambda>_. Some v) |` S"

lemma const_map_empty[simp]:
  "const_map v {} = Map.empty"
  by(auto simp add: const_map_def)

lemma const_map_ran[simp]: "x \<in> ran (const_map v S) = (S \<noteq> {} \<and> x = v)"
  by(auto simp add: const_map_def ran_def restrict_map_def)

lemma const_map_is_None:
  "(const_map y A  x = None) = (x \<notin> A)"
  by(auto simp add: const_map_def restrict_map_def)

lemma const_map_is_Some:
  "(const_map y A x = Some z) = (z = y \<and> x \<in> A)"
  by(auto simp add: const_map_def restrict_map_def)

lemma const_map_in_set:
  "x \<in> A \<Longrightarrow> const_map v A x = Some v"
  by(auto simp add: const_map_def)

lemma const_map_notin_set:
  "x \<notin> A \<Longrightarrow> const_map v A x = None"
  by(auto simp add: const_map_def)

lemma dom_const_map:
  "dom (const_map v S) = S"
  by(auto simp add: const_map_def)

(*******************************************************************)
subsection \<open>Votes with maximum timestamps.\<close>
(*******************************************************************)

definition vote_set :: "('round \<Rightarrow> ('process, 'val)map) \<Rightarrow> 'process set \<Rightarrow> ('round \<times> 'val)set" where
  "vote_set vs Q \<equiv> {(r, v)|a r v. ((r, a), v) \<in> map_graph (case_prod vs) \<and> a \<in> Q}"

lemma inj_on_fst_vote_set:
  "inj_on fst (vote_set v_hist {p})"
  by(clarsimp simp add: inj_on_def vote_set_def)

lemma finite_vote_set:
  assumes "\<forall>r'\<ge>(r :: nat). v_hist r' = Map.empty"
    "finite S"
  shows "finite (vote_set v_hist S)"
proof-
  define vs where "vs = {((r, a), v)|r a v. ((r, a), v) \<in> map_graph (case_prod v_hist) \<and> a \<in> S}"
  have "vs
      = (\<Union>p\<in>S. ((\<lambda>(r, v). ((r, p), v)) ` (map_graph (\<lambda>r. v_hist r p))))"
      by(auto simp add: map_graph_def fun_graph_def vs_def)
  also have "... \<le> (\<Union>p\<in>S. (\<lambda>r. ((r, p), the (v_hist r p))) ` {0..<r})"
    using assms(1)
    apply auto
    apply (auto simp add: map_graph_def fun_graph_def image_def)
    apply (metis le_less_linear option.distinct(1))
    done
  also note I=finite_subset[OF calculation]
  have "finite vs"
    by(auto intro: I assms(2) nat_seg_image_imp_finite[where n=r])

  thus ?thesis
    apply(clarsimp simp add: map_graph_def fun_graph_def vote_set_def vs_def)
    apply(erule finite_surj[where f="\<lambda>((r, a), v). (r, v)"])
    by(force simp add: image_def)
qed

definition mru_of_set
  :: "('round :: linorder \<Rightarrow> ('process, 'val)map) \<Rightarrow> ('process set, 'round \<times> 'val)map" where
  "mru_of_set vs \<equiv> \<lambda>Q. option_Max_by fst (vote_set vs Q)"

definition process_mru
  :: "('round :: linorder \<Rightarrow> ('process, 'val)map) \<Rightarrow> ('process, 'round \<times> 'val)map" where
  "process_mru vs \<equiv> \<lambda>a. mru_of_set vs {a}"

lemma process_mru_is_None:
  "(process_mru v_f a = None) = (vote_set v_f {a} = {})"
  by(auto simp add: process_mru_def mru_of_set_def option_Max_by_def)

lemma process_mru_is_Some:
  "(process_mru v_f a = Some rv) = (vote_set v_f {a} \<noteq> {} \<and> rv = Max_by fst (vote_set v_f {a}))"
  by(auto simp add: process_mru_def mru_of_set_def option_Max_by_def)

lemma vote_set_upd:
  "vote_set (v_hist(r := v_f)) {p} =
      (if p \<in> dom v_f
        then insert (r, the (v_f p))
        else id
      )
      (if v_hist r p = None
        then vote_set v_hist {p}
        else vote_set v_hist {p} - {(r, the (v_hist r p))}
      )
  "
  by(auto simp add: vote_set_def const_map_is_Some split: if_split_asm)

lemma finite_vote_set_upd:
  " finite (vote_set v_hist {a}) \<Longrightarrow>
    finite (vote_set (v_hist(r := v_f)) {a})"
  by(simp add: vote_set_upd)

lemma vote_setD:
  "rv \<in> vote_set v_f {a} \<Longrightarrow> v_f (fst rv) a = Some (snd rv)"
  by(auto simp add: vote_set_def)

lemma process_mru_new_votes:
  assumes
    "\<forall>r' \<ge> (r :: nat). v_hist r' = Map.empty"
  shows
    "process_mru (v_hist(r := v_f)) =
    (process_mru v_hist ++ (\<lambda>p. map_option (Pair r) (v_f p)))"
proof(rule ext, rule option_expand')
  fix p
  show
    "(process_mru (v_hist(r := v_f)) p = None) =
    ((process_mru v_hist ++ (\<lambda>p. map_option (Pair r) (v_f p))) p = None)" using assms
    by(force simp add: vote_set_def restrict_map_def  const_map_is_None process_mru_is_None)
next
  fix p rv rv'
  assume eqs:
    "process_mru (v_hist(r := v_f)) p = Some rv"
    "(process_mru v_hist ++ (\<lambda>p. map_option (Pair r) (v_f p))) p = Some rv'"
  moreover have "v_hist (r) p = None" using assms(1)
    by(auto)

  ultimately show "rv = rv'"  using eqs assms
    by(auto simp add: map_add_Some_iff const_map_is_Some const_map_is_None
      process_mru_is_Some vote_set_upd dest!: vote_setD intro!: Max_by_eqI
      finite_vote_set[OF assms]
      intro: ccontr inj_on_fst_vote_set)
qed

end