theory GZF_locale
  imports Main begin

no_notation Set.member ("'(\<in>')") and
            Set.member ("(_/ \<in> _)" [51, 51] 50) and
            Set.not_member  ("'(\<notin>')") and
            Set.not_member  (infixl \<open>\<notin>\<close> 50) and
            Set.not_member  ("(_/ \<notin> _)" [51, 51] 50) and
            subset_eq  ("'(\<subseteq>')") and
            subset_eq  ("(_/ \<subseteq> _)" [51, 51] 50) and
            Union ("\<Union>") and Inter ("\<Inter>") and
            union (infixl "\<union>" 65) and inter (infixl "\<inter>" 70) and
            image (infixr "`" 90)

no_notation Product_Type.Times (infixr "\<times>" 80)

no_notation less_eq  ("'(\<le>')") and
  less_eq  ("(_/ \<le> _)"  [51, 51] 50) and
  less  ("'(<')") and
  less  ("(_/ < _)"  [51, 51] 50)

no_notation
  Groups.minus (infixl "-" 65) and
  Groups.zero ("0") and
  Groups.one_class.one ("1")

no_notation (ASCII)
  Set.member  ("'(:')") and
  Set.member  ("(_/ : _)" [51, 51] 50) and
  Set.not_member  ("'(~:')") and
  Set.not_member  ("(_/ ~: _)" [51, 51] 50) and
  less_eq  ("'(<=')") and
  less_eq  ("(_/ <= _)" [51, 51] 50) and
  union (infixl "Un" 65) and
  inter (infixl "Int" 70)

notation (ASCII)
  not_equal  (infixl \<open>~=\<close> 50) and
  Not  (\<open>~ _\<close> [40] 40) and
  conj  (infixr \<open>&\<close> 35) and
  disj  (infixr \<open>|\<close> 30) and
  All  (binder \<open>ALL \<close> 10) and
  Ex  (binder \<open>EX \<close> 10) and
  Ex1  (binder \<open>EX! \<close> 10) and
  implies  (infixr \<open>-->\<close> 25) and
  iff  (infixr \<open><->\<close> 25)

(*Removing list syntax so that we can have f[x] := image(f,x) *)
no_translations
  "[x, xs]" == "x#[xs]"
  "[x]" == "x#[]"
no_syntax
  "_list" :: "args => 'a list" ("[(_)]")

locale GZF =  (*Fixes and axiomatises constants on type 'd*)
  fixes Mem :: "'d \<Rightarrow> 'd \<Rightarrow> bool"  (infixl \<open>\<in>\<close> 50)
    and Emp :: "'d"  (\<open>\<emptyset>\<close>)
    and Set :: "'d \<Rightarrow> bool"
    and Union :: "'d \<Rightarrow> 'd" (\<open>\<Union> _\<close> [90] 90)
    and Subset :: "['d,'d] \<Rightarrow> bool" (infixl \<open>\<subseteq>\<close> 50)
    and Pow ::  "'d \<Rightarrow> 'd" (\<open>\<P> _\<close> [90] 90)
    and Succ :: "'d \<Rightarrow> 'd"
    and Inf :: "'d"
    and Repl :: "[['d,'d] \<Rightarrow> bool] \<Rightarrow> 'd \<Rightarrow>'d" (\<open>\<R>\<close> 90)
 assumes emp : "\<forall>x. ~ (x \<in> \<emptyset>)"
    and set : "\<forall>x. Set x \<longleftrightarrow> (x = \<emptyset> \<or> (\<exists>y. y \<in> x))"
    and ext : "\<forall>x y. Set x \<longrightarrow> Set y \<longrightarrow>
      ((\<forall>a. a \<in> x \<longleftrightarrow> a \<in> y) \<longrightarrow> x = y)"
    and subset_def : "\<forall>x y. x \<subseteq> y \<longleftrightarrow> Set x \<and> Set y \<and> (\<forall>a. a \<in> x \<longrightarrow> a \<in> y)"
    and uni : "\<forall>x. Set x \<longrightarrow> (Set (\<Union> x) \<and> (\<forall>a. a \<in> \<Union> x \<longleftrightarrow> (\<exists>z. z \<in> x \<and> a \<in> z)))"
    and pow : "\<forall>x. Set x \<longrightarrow> (\<forall>z. z \<in> \<P> x \<longleftrightarrow> z \<subseteq> x)"
    and suc : "\<forall>x. Set x \<longrightarrow> (\<forall>a. a \<in> Succ x \<longleftrightarrow> (a \<in> x \<or> a = x))"
    and inf : "\<emptyset> \<in> Inf \<and> (\<forall>x. x \<in> Inf \<longrightarrow> Succ x \<in> Inf)"
    and repl: "\<forall>P x. Set x \<longrightarrow> Set (Repl P x) \<and>
             ((\<forall>a. a \<in> x \<longrightarrow> (\<exists>\<^sub>\<le>\<^sub>1 b. P a b))
         \<longrightarrow> (\<forall>b. b \<in> (Repl P x) \<longleftrightarrow> (\<exists>a. a \<in> x \<and> P a b)))"

context GZF begin

definition the_default :: "'d \<Rightarrow> ('d \<Rightarrow> bool) \<Rightarrow> 'd" (\<open>\<iota>'' _ _\<close> [90,90] ) where
 "\<iota>' d F \<equiv> if Ex1 F then (THE x. F x) else d"

lemma the_def_if : "if (Ex1 F) then (F a \<longleftrightarrow> \<iota>' d F = a)
                               else \<iota>' d F = d"
proof (cases \<open>Ex1 F\<close>)
  assume "Ex1 F" hence eq:"\<iota>' d F = (THE x. F x)"
    unfolding the_default_def by auto
  have "F a \<longleftrightarrow> \<iota>' d F = a"
  proof
    assume "F a"
    thus "\<iota>' d F = a" by (subst eq, insert \<open>Ex1 F\<close>, auto)
  next
    assume "\<iota>' d F = a"
    thus "F a" using eq \<open>Ex1 F\<close> by (auto intro: theI)
  qed
  thus "if (Ex1 F) then (F a \<longleftrightarrow> \<iota>' d F = a) else \<iota>' d F = d" using \<open>Ex1 F\<close> by simp
next
  assume "\<not> Ex1 F"
  thus "if (Ex1 F) then (F a \<longleftrightarrow> \<iota>' d F = a) else \<iota>' d F = d"
    unfolding the_default_def by auto
qed

lemma the_def_eq : assumes "P a" "\<And>x. P x \<Longrightarrow> x = a"
  shows "\<iota>' d P = a"
proof -
  from assms have "Ex1 P" by auto
  hence "P a \<longleftrightarrow> (\<iota>' d P) = a" using the_def_if by auto
  thus "(\<iota>' d P) = a" using \<open>P a\<close> by auto
qed

lemma the_defI : assumes "P a" "\<And>x. P x \<Longrightarrow> x = a"
  shows "P (\<iota>' d P)"
proof -
  from the_def_eq assms have "\<iota>' d P = a" by blast
  thus "P (\<iota>' d P)" using \<open>P a\<close> by simp
qed

lemma the_defI' : assumes "Ex1 P" shows "P (\<iota>' d P)"
  using assms by (blast intro: the_defI)

lemma the_defI2 : assumes "P a" "\<And>x. P x \<Longrightarrow> x = a" "\<And>x. P x \<Longrightarrow> Q x"
  shows "Q (\<iota>' d P)" by (blast intro: assms the_defI)

lemma the_defI2' : assumes "Ex1 P" "\<And>x. P x \<Longrightarrow> Q x" shows "Q (\<iota>' d P)"
  by (blast intro: assms(2) the_defI2[where P=P and Q=Q] ex1E[OF assms(1)])

lemma the_def_eq' : "\<lbrakk> Ex1 P ; P a \<rbrakk> \<Longrightarrow> (\<iota>' d P) = a"
  by (blast intro: the_def_eq)

subsection \<open>Restricted quantification using a predicate\<close>

definition rall :: "('d \<Rightarrow> bool) \<Rightarrow> ('d \<Rightarrow> bool) \<Rightarrow> bool" where
  rall_def : "rall P Q \<equiv> \<forall>x. P x \<longrightarrow> Q x"
definition rex :: "('d \<Rightarrow> bool) \<Rightarrow> ('d \<Rightarrow> bool) \<Rightarrow> bool" where
  rex_def : "rex P Q \<equiv> \<exists>x. P x \<and> Q x"

(*Taken from ZF/OrdQuant, unfolded syntax*)
lemma rallI [intro]: "[| !!x. M(x) ==> P(x) |] ==> rall M P"
by (simp add: rall_def)

lemma rspec: "[| rall M P; M(x) |] ==> P(x)"
by (simp add: rall_def)

lemma rev_rallE [elim]:
    "[| rall M P;  ~ M(x) ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: rall_def, blast)

lemma rallE: "[| rall M P; P(x) ==> Q;  ~ M(x) ==> Q |] ==> Q"
by blast

lemma rall_triv [simp]: "(rall M (\<lambda>x. P)) \<longleftrightarrow> ((\<exists>x. M x) \<longrightarrow> P)"
by (simp add: rall_def)

lemma rall_cong [cong]:
    "(!!x. M(x) ==> P(x) <-> P'(x)) ==> (rall M P) <-> (rall M P')"
by (simp add: rall_def)

lemma rexI [intro]: "[| P(x); M(x) |] ==> rex M P"
by (simp add: rex_def, blast)

lemma rev_rexI: "[| M(x);  P(x) |] ==> rex M P"
by blast

lemma rexCI: "[| rall M (\<lambda>x. ~P x) ==> P(a); M(a) |] ==> rex M P"
by blast

lemma rexE [elim]: "[| rex M P;  !!x. [| M(x); P(x) |] ==> Q |] ==> Q"
by (simp add: rex_def, blast)

lemma rex_triv [simp]: "(rex M (\<lambda>x. P)) \<longleftrightarrow> ((\<exists>x. M(x)) \<and> P)"
by (simp add: rex_def)

lemma rex_cong [cong]:
    "(!!x. M(x) ==> P(x) <-> P'(x)) ==> (rex M P) <-> (rex M P')"
by (simp add: rex_def cong: conj_cong)

lemma atomize_rall: "(!!x. M(x) ==> P(x)) == Trueprop (rall M P)"
by (simp add: rall_def atomize_all atomize_imp)

subsection \<open>Bounding quantification over a set\<close>

definition ball :: "'d \<Rightarrow> ('d \<Rightarrow> bool) \<Rightarrow> bool" where
  ball_def : "ball x P \<equiv> rall (\<lambda>a. a \<in> x) P"
definition bex :: "'d \<Rightarrow> ('d \<Rightarrow> bool) \<Rightarrow> bool" where
  bex_def : "bex x P \<equiv> rex (\<lambda>a. a \<in> x) P"

abbreviation not_mem :: "['d, 'd] \<Rightarrow> bool"  (infixl \<open>\<notin>\<close> 50)  \<comment> \<open>negated membership relation\<close>
  where "x \<notin> y \<equiv> \<not> (x \<in> y)"

(*Lemmas taken from ZF/ZF_Base*)
lemma ballI [intro!]: "(\<And>x. x \<in> A \<Longrightarrow> P x) \<Longrightarrow> ball A P"
  by (simp add: ball_def)

lemma bspec [dest?]: "[| ball A P;  x\<in>A |] ==> P x"
  unfolding ball_def by auto

lemma rev_ballE [elim]:
    "[| ball A P;  x\<notin>A ==> Q;  P x ==> Q |] ==> Q"
  by (simp add: ball_def, blast)

lemma ballE: "[| ball A P;  P x ==> Q;  x\<notin>A \<Longrightarrow>  Q |] ==> Q"
  by auto

lemma ball_triv [simp]: "ball A (\<lambda>x. P) \<longleftrightarrow> ((\<exists>x. x\<in>A) \<longrightarrow> P)"
 by (simp add: ball_def)

lemma ball_cong [cong]:
 "[| A=A';  !!x. x\<in>A' ==> P x \<longleftrightarrow> P' x |] ==> (ball A P \<longleftrightarrow> ball A' P')"
  by (simp add: ball_def)

lemma bexI [intro]: "[| P x;  x\<in> A |] ==> bex A P "
  by (simp add: bex_def, blast)

lemma rev_bexI: "[| x\<in>A;  P x |] ==>  bex A P " by blast

lemma bexCI: "[| ball A  (\<lambda>x. ~P x) \<Longrightarrow> P a;  a\<in> A |] ==>  bex A P "
  by blast

lemma bexE [elim!]:
  "[|  bex A P ;  !!x. [| x\<in>A; P x |] ==> Q |] ==> Q"
by (simp add: bex_def, blast)

lemma bex_triv [simp]: "bex A (\<lambda>x. P) \<longleftrightarrow> ((\<exists>x. x\<in>A) & P)"
by (simp add: bex_def)

lemma bex_cong [cong]:
    "[| A=A';  !!x. x\<in>A' ==> P x \<longleftrightarrow> P'(x) |]
     ==>  bex A P \<longleftrightarrow> bex A' P'"
  by (simp add: bex_def cong: conj_cong)

subsection \<open>Rules for the Set ownership relation\<close>

lemma set_iff : "Set x \<longleftrightarrow> x = \<emptyset> \<or> (\<exists>y. y \<in> x)"
  using set by auto

lemma setI  : "a \<in> x \<Longrightarrow> Set x" using set_iff by auto
lemma setE  : "Set x \<Longrightarrow> x = \<emptyset> \<or> (\<exists>y. y \<in> x)" using set_iff by auto

subsection \<open>Rules for the subset relation\<close>

lemma subset_iff : "x \<subseteq> y \<longleftrightarrow> Set x \<and> Set y \<and> (ball x (\<lambda>a. a \<in> y))"
  using subset_def by auto

lemma subset_set : "x \<subseteq> y \<Longrightarrow> Set x \<and> Set y" using subset_iff by auto
lemma subset_set1 : "x \<subseteq> y \<Longrightarrow> Set x" using subset_set by auto
lemma subset_set2 : "x \<subseteq> y \<Longrightarrow> Set y" using subset_set by auto

(*Lemmas taken from ZF/ZF_Base:*)

(*Added assumptions \<open>Set A\<close>, \<open>Set B\<close>*)
lemma subsetI [intro]: assumes "Set A" "Set B" shows
    "(!!x. x\<in>A ==> x\<in>B) ==> A \<subseteq> B"
  using assms subset_iff by auto
(*WAS: by (simp add: subset_def) *)

lemma subsetD [elim]: "[| A \<subseteq> B;  c\<in>A |] ==> c\<in>B"
  using subset_iff by auto
(*WAS: apply (unfold subset_def)
       apply (erule bspec, assumption)
       done
*)
lemma subsetCE [elim]:
    "[| A \<subseteq> B;  c\<notin>A ==> P;  c\<in>B ==> P |] ==> P"
  using subsetD by auto
(*WAS: by (simp add: subset_def, blast)*)

lemma rev_subsetD: "[| c\<in>A; A \<subseteq> B |] ==> c\<in>B"
by blast

lemma contra_subsetD: "[| A \<subseteq> B; c \<notin> B |] ==> c \<notin> A"
by blast

lemma rev_contra_subsetD: "[| c \<notin> B;  A \<subseteq> B |] ==> c \<notin> A"
by blast

(*Added assumption: \<open>Set A\<close>*)
lemma subset_refl : assumes "Set A" shows "A \<subseteq> A"
 using assms by blast
(*WAS: by blast*)

lemma subset_trans: "[| A \<subseteq> B;  B \<subseteq> C |] ==> A \<subseteq> C"
  by (simp add: subset_iff, auto)

(*WAS: by blast*)

declare subsetD [trans] rev_subsetD [trans] subset_trans [trans]

subsection \<open>Equality of sets\<close>

lemma subset_equal : assumes "Set x" "Set y"
  shows "x = y \<longleftrightarrow> x \<subseteq> y \<and> y \<subseteq> x "
  using assms ext by auto

lemma equality_iff : assumes "Set x" "Set y"
  shows "x = y \<longleftrightarrow> (\<forall>a. a \<in> x \<longleftrightarrow> a \<in> y)"
  using assms ext by auto

(*Lemmas taken from ZF/ZF_Base:*)
lemma equalityI : "[| A \<subseteq> B;  B \<subseteq> A |] ==> A = B"
  using subset_set subset_equal by auto
(*WAS: by (rule extension [THEN iffD2], rule conjI) *)

(*Added assumptions: \<open>Set A\<close> \<open>Set B\<close>*)
lemma equality_iffI: assumes "Set A" "Set B"
  shows "(!!x. x \<in> A \<longleftrightarrow> x \<in> B) \<Longrightarrow> A = B"
  using assms equalityI subsetI by blast

(*WAS: by (rule equalityI, blast+)*)

(*Replaced \<open>extension\<close> with \<open>subset_equal\<close>*)
lemmas equalityD1 = subset_equal [THEN iffD1, THEN conjunct1]
lemmas equalityD2 = subset_equal [THEN iffD1, THEN conjunct2]

(*Added assumptions: \<open>Set A\<close> \<open>Set B\<close>*)
lemma equalityE: assumes "Set A" "Set B" shows "[| A = B;  [| A \<subseteq> B; B \<subseteq> A |] ==> P |]  ==>  P"
  by (use equalityD1[OF assms] equalityD2[OF assms] in auto)
(*WAS: by (blast dest: equalityD1 equalityD2) *)

(*Added assumptions: \<open>Set A\<close> \<open>Set B\<close>*)
lemma equalityCE: assumes "Set A" "Set B" shows
    "[| A = B;  [| c\<in>A; c\<in>B |] ==> P;  [| c\<notin>A; c\<notin>B |] ==> P |]  ==>  P"
by (erule equalityE[OF assms], blast)
(*WAS: by (erule equalityE, blast)*)

subsection\<open>Rules for the empty set\<close>

lemma emp_set [simp] : "Set \<emptyset>" using set_iff by auto

(*Taken from ZF/ZF_Base*)
lemma not_mem_empty : "a \<notin> \<emptyset>"
  by (simp add: emp)
(*WAS: apply (cut_tac foundation)
       apply (best dest: equalityD2)
       done *)

lemmas emptyE [elim] = not_mem_empty [THEN notE]

(*Added assumption: \<open>Set A\<close>*)
lemma empty_subsetI [simp]: assumes "Set A" shows "\<emptyset> \<subseteq> A"
  using assms by auto
(*WAS: by blast*)

(*Added assumption: \<open>Set A\<close>*)
lemma equals0I: assumes "Set A" shows "[|!!y. y\<in>A ==> False |] ==> A=\<emptyset>"
  by (rule equality_iffI[OF assms emp_set], use not_mem_empty in auto)
(*WAS: by blast*)

lemma equals0D [dest]: "x = \<emptyset> \<Longrightarrow> a \<notin> x"
  by blast

declare sym [THEN equals0D, dest]

lemma not_emptyI: "a \<in> x ==> x \<noteq> \<emptyset>"
  by blast

(*Added assumption: \<open>Set A\<close>*)
lemma not_emptyE: assumes "Set A"
  shows "[| A \<noteq> \<emptyset>;  !!x. x\<in>A ==> R |] ==> R"
  using setE[OF assms] by blast
(*WAS: by blast*)

subsection \<open>Corollaries of the Axiom of Union\<close>

lemma union_set : "Set x \<Longrightarrow> Set (\<Union> x)"
  using uni by auto

(*Added assumption: \<open>Set x\<close>*)
lemma union_iff : assumes "Set x"
  shows "a \<in> \<Union> x \<longleftrightarrow> (bex x (\<lambda>y. a \<in> y))"
  using assms uni by auto
(*WAS: axiomatised then, declare union_iff [simp]*)

(*Added assumption: \<open>Set x\<close>*)
lemma unionI [intro]: assumes "Set x"
  shows "\<lbrakk> y \<in> x;  a \<in> y \<rbrakk> \<Longrightarrow> a \<in> \<Union> x"
  by (simp add: union_iff[OF assms], blast)
(*WAS: by (simp, blast)*)

(*Added assumption: \<open>Set x\<close>*)
lemma unionE [elim]: assumes "Set x"
  shows "\<lbrakk> a \<in> \<Union> x;  \<And>y. \<lbrakk> a \<in> y;  y \<in> x \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (simp add: union_iff[OF assms], blast)
(*WAS: by (simp, blast)*)

lemma union_emp : assumes "Set x" shows "a \<in> \<Union> x \<Longrightarrow> x \<noteq> \<emptyset>"
  using assms unionE not_emptyI by auto

subsection \<open>Rules for power sets\<close>

(*Added assumption: \<open>Set x\<close>*)
lemma pow_iff : assumes "Set x" shows "y \<in> \<P> x \<longleftrightarrow> y \<subseteq> x"
  using pow assms by auto
(*WAS: an axiom*)

(*Added assumption: \<open>Set x\<close>*)
lemma powI: "A \<subseteq> B \<Longrightarrow> A \<in> \<P> B"
  using subset_set2 pow_iff by auto
(*WAS: by (erule Pow_iff [THEN iffD2])*)

lemma powD: assumes "Set B" shows "A \<in> \<P> B \<Longrightarrow> A \<subseteq> B"
  using pow_iff[OF assms] by simp
(*WAS: by (erule Pow_iff [THEN iffD1]) *)

declare pow_iff

lemmas pow_bottom = empty_subsetI [THEN powI]    \<comment> \<open>\<^term>\<open>\<emptyset> \<in> \<P> B\<close>\<close>
lemmas pow_top = subset_refl [THEN powI]         \<comment> \<open>\<^term>\<open>A \<in> \<P> A\<close>\<close>

lemma pow_set : "Set x \<Longrightarrow> Set (\<P> x)"
  using setI[OF pow_top] by simp

subsection \<open>Rules for von Neumann successor operation\<close>

thm suc
lemma vsucc_iff : assumes "Set x"
  shows "y \<in> Succ x \<longleftrightarrow> (y \<in> x | y = x)"
  using assms suc by simp

lemma vsuccI1 : assumes "Set x"
  shows "y \<in> x \<Longrightarrow> y \<in> Succ x"
  using vsucc_iff[OF assms] by simp

lemma vsuccI2 : assumes "Set x"
  shows "x \<in> Succ x"
  using vsucc_iff[OF assms] by simp

lemma vsucc_set : assumes "Set x"
  shows "Set (Succ x)"
  by (rule setI[OF vsuccI2[OF assms]])

lemma vsuccE : assumes "Set x"
  shows "y \<in> Succ x \<Longrightarrow> (y \<in> x | y = x)"
  using vsucc_iff[OF assms] by simp

subsection \<open>Rules for the witness of Axiom of Infinity\<close>

thm inf
lemma inf0 : "\<emptyset> \<in> Inf" by (simp add: inf)
lemma inf_closed: "x \<in> Inf \<Longrightarrow> Succ x \<in> Inf" by (simp add: inf)
lemma inf_set : "Set Inf" by (rule setI[OF inf0])

subsection \<open>Rules for Replacement and derived operators\<close>

thm repl
lemma repl_set : "Set x \<Longrightarrow> Set (Repl P x)" using repl by auto

lemma repl_iff : assumes "Set x" "ball x (\<lambda>a. \<exists>\<^sub>\<le>\<^sub>1 b. P a b)"
  shows "b \<in> Repl P x \<longleftrightarrow> (bex x (\<lambda>a. P a b))"
  using repl assms unfolding ball_def rall_def bex_def rex_def by auto

definition Replace :: "[['d,'d] \<Rightarrow> bool, 'd] \<Rightarrow> 'd" where
  "Replace P x \<equiv> Repl (\<lambda>x y. (\<exists>!z. P x z) \<and> P x y) x"

lemma replace_set : "Set x \<Longrightarrow> Set (Replace P x)"
  by (unfold Replace_def, rule repl_set)

lemma replace_iff : assumes "Set x"
  shows "b \<in> Replace P x \<longleftrightarrow> (bex x (\<lambda>a. P a b \<and> (\<forall>c. P a c \<longrightarrow> c = b)))"
proof -
  let ?Q = "(\<lambda>x y. (\<exists>!z. P x z) \<and> P x y)"
  have "ball x (\<lambda>a. \<exists>\<^sub>\<le>\<^sub>1 b. ?Q a b)" unfolding Uniq_def by auto
  hence "b \<in> Repl ?Q x \<longleftrightarrow> (bex x (\<lambda>a. ?Q a b))" by (rule repl_iff[OF assms])
  thus ?thesis unfolding Replace_def Ex1_def by auto
qed

lemma replaceI : "\<lbrakk> P a b ; a \<in> x ; \<And>c. P a c \<Longrightarrow> c = b \<rbrakk> \<Longrightarrow> b \<in> Replace P x"
  using replace_iff setI by blast

lemma replaceE: assumes "Set x"
  shows "\<lbrakk> b \<in> Replace P x ;
          \<And>a. \<lbrakk>a \<in> x ; P a b ; \<forall>c. P a c \<longrightarrow> c = b \<rbrakk> \<Longrightarrow> R \<rbrakk>
          \<Longrightarrow> R"
  by (rule replace_iff [OF assms, THEN iffD1, THEN bexE], simp+)

lemma replaceE2 : assumes "Set x"
  shows "\<lbrakk> b \<in> Replace P x ; \<And>a. \<lbrakk>a \<in> x ; P a b \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (erule replaceE[OF assms], blast)

lemma replace_cong : assumes "Set x" "Set y" shows [cong]:
  "\<lbrakk>x = y ; \<And>a b. a \<in> y \<Longrightarrow> P a b \<longleftrightarrow> Q a b\<rbrakk> \<Longrightarrow> Replace P x = Replace Q y"
  by (rule equality_iffI[OF replace_set[OF assms(1)]
                            replace_set[OF assms(2)]],
      simp add: assms replace_iff)

definition RepFun :: "['d \<Rightarrow> 'd, 'd] \<Rightarrow> 'd" where
  "RepFun F x \<equiv> Replace (\<lambda>a b. b = F a) x"

lemma repfun_set : "Set x \<Longrightarrow> Set (RepFun F x)"
  unfolding RepFun_def by (rule replace_set)

lemma repfunI : "a \<in> x \<Longrightarrow>  F a \<in> RepFun F x"
  unfolding RepFun_def using replace_iff setI by auto

lemma repfun_eqI : "\<lbrakk>b = F a ; a \<in> x\<rbrakk> \<Longrightarrow> b \<in> RepFun F x"
  using repfunI by auto

lemma repfunE : assumes "Set x"
  shows "\<lbrakk> b \<in> RepFun F x ;
        \<And>a. \<lbrakk> a \<in> x ; b = F a \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (simp add: RepFun_def replace_iff[OF assms], blast)

lemma repfun_cong : assumes "Set x" "Set y"
  shows "\<lbrakk> x = y ; \<And>a. a \<in> y \<Longrightarrow> F a = G a \<rbrakk> \<Longrightarrow> RepFun F x = RepFun G y"
  unfolding RepFun_def using assms by simp

lemma repfun_iff  : assumes "Set x"
  shows "b \<in> RepFun F x \<longleftrightarrow> (bex x (\<lambda>c. b = F c))"
  using repfun_eqI repfunE[OF assms] by blast

lemma repfun_union : assumes "Set x"
  shows "b \<in> \<Union> RepFun F x \<longleftrightarrow> (bex x (\<lambda>a. b \<in> F a))"
  by (simp add: union_iff[OF repfun_set[OF \<open>Set x\<close>]] bex_def rex_def
                repfun_iff[OF \<open>Set x\<close>], auto)

lemma repfun_union_subset : "a \<in> x \<Longrightarrow> y \<subseteq> F a \<Longrightarrow> y \<subseteq> \<Union> RepFun F x"
  using subset_iff repfun_union[OF setI] union_set[OF repfun_set[OF setI]] by auto

subsection \<open>Subset comprehension\<close>

definition Collect :: "['d \<Rightarrow> bool, 'd] \<Rightarrow> 'd" where
  "Collect P x \<equiv> Replace (\<lambda>a b. a = b \<and> P a) x"

lemma collect_set : "Set x \<Longrightarrow> Set (Collect P x)"
  unfolding Collect_def by (rule replace_set)

lemma collect_iff : assumes "Set x"
  shows "a \<in> Collect P x \<longleftrightarrow> a \<in> x \<and> P a"
  unfolding Collect_def by (simp add: replace_iff[OF assms], auto)

lemma collectI : "\<lbrakk> a \<in> x ; P a \<rbrakk> \<Longrightarrow> a \<in> Collect P x"
  using setI collect_iff by auto

lemma collectE : assumes "Set x"
  shows "\<lbrakk> a \<in> Collect P x ; \<lbrakk> a \<in> x ; P a \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  using collect_iff[OF assms] by auto

lemma collectD1 : assumes "Set x" shows "a \<in> Collect P x \<Longrightarrow> a \<in> x"
  using collectE[OF assms] by auto
lemma collectD2 : assumes "Set x" shows "a \<in> Collect P x \<Longrightarrow> P a"
  using collectE[OF assms] by auto

lemma Collect_cong [cong]: assumes "Set x" "Set y" shows [cong]:
    "\<lbrakk> x = y;  \<And>a. a \<in> y \<Longrightarrow> P a \<longleftrightarrow> Q a \<rbrakk>
     \<Longrightarrow> Collect P x = Collect Q y"
  unfolding Collect_def using assms by simp

subsection \<open>Intersection of a set\<close>

definition Int :: "'d \<Rightarrow> 'd" (\<open>\<Inter> _\<close> [90] 90) where
  "\<Inter> x \<equiv> Collect (\<lambda>a. ball x (\<lambda>y. a \<in> y)) (Union x)"

lemma Int_set : "Set x \<Longrightarrow> Set (\<Inter> x)"
  unfolding Int_def by (rule collect_set[OF union_set])

lemma Int_iff: assumes "Set x"
  shows "a \<in> \<Inter> x \<longleftrightarrow> (ball x (\<lambda>y. a \<in> y)) \<and> x \<noteq> \<emptyset> "
proof
  assume "a \<in> \<Inter> x" hence "a \<in> \<Union> x" "ball x (\<lambda>y. a \<in> y)" unfolding Int_def
    using collectE[OF union_set[OF assms]] by auto
  thus "ball x (\<lambda>y. a \<in> y) \<and> x \<noteq> \<emptyset>" using union_emp[OF assms] by auto
next
  assume "ball x (\<lambda>y. a \<in> y) \<and> x \<noteq> \<emptyset>" hence ball:"ball x (\<lambda>y. a \<in> y)" and "x \<noteq> \<emptyset>" by simp_all
  from \<open>x \<noteq> \<emptyset>\<close> have "a \<in> \<Union> x"
  proof (rule not_emptyE[OF assms])
    fix y assume "y \<in> x" thus "a \<in> \<Union> x"
      using ball unionI[OF assms] unfolding ball_def rall_def by auto
  qed
  thus "a \<in> \<Inter> x" unfolding Int_def using ball collectI by auto
qed

lemma IntI : assumes "Set x" shows "\<lbrakk> \<And>y. y \<in> x \<Longrightarrow> a \<in> y ; x \<noteq> \<emptyset> \<rbrakk> \<Longrightarrow> a \<in> \<Inter> x"
  using Int_iff[OF assms] by auto

lemma IntD : "\<lbrakk> a \<in> \<Inter> x ; y \<in> x \<rbrakk> \<Longrightarrow> a \<in> y"
  using setI Int_iff by auto

lemma IntE : assumes "Set x" shows "\<lbrakk> a \<in> \<Inter> x ; y \<notin> x \<Longrightarrow> R; a \<in> y \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  using Int_iff[OF assms] by auto

subsection \<open>Set difference\<close>

definition diff :: "['d, 'd] \<Rightarrow> 'd" (infixl \<open>-\<close> 65) where
  "x - y \<equiv> Collect (\<lambda>a. a \<notin> y) x"

lemma diff_set : assumes "Set x" shows "Set (x - y)"
  unfolding diff_def by (rule collect_set[OF assms])

lemma diff_iff : assumes "Set x" shows "a \<in> x - y \<longleftrightarrow> a \<in> x \<and> a \<notin> y"
  unfolding diff_def using collect_iff[OF assms] by simp

lemma diffI : "\<lbrakk> a \<in> x ; a \<notin> y \<rbrakk> \<Longrightarrow> a \<in> x - y"
  using setI diff_iff by simp

lemma diffD1 : assumes "Set x" shows "a \<in> x - y \<Longrightarrow> a \<in> x" using diff_iff[OF assms] by simp
lemma diffD2 : assumes "Set x" shows "a \<in> x - y \<Longrightarrow> a \<notin> y" using diff_iff[OF assms] by simp

lemma diffE : assumes "Set x" shows "\<lbrakk> a \<in> x - y ; \<lbrakk>a \<in> x ; a \<notin> y\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using diff_iff[OF assms] by simp

lemma diff_sub : "x \<subseteq> y \<Longrightarrow> x - z \<subseteq> y - z"
  using subset_iff diff_iff diff_set by auto

lemma diff_subset1 : shows "x \<subseteq> y \<Longrightarrow> a \<subseteq> (x - z) \<Longrightarrow> a \<subseteq> (y - z)"
  using subset_iff diff_iff diff_set by auto

lemma diff_subset2 : assumes "Set y" shows "x \<subseteq> (y - z) \<Longrightarrow> x \<subseteq> y"
  using subset_iff diff_iff[OF assms] assms by auto

lemma diff_emp : "\<emptyset> - x = \<emptyset>"
  using diff_iff[OF emp_set] equals0I[OF diff_set[OF emp_set]] by auto

subsection \<open>Unordered pairs; defined by replacement over \<P> (\<P> \<emptyset>)\<close>

abbreviation "\<phi> x y a b \<equiv> (a = \<emptyset> \<and> b = x) \<or> (a = \<P> \<emptyset> \<and> b = y)"

definition upair :: "'d \<Rightarrow> 'd \<Rightarrow> 'd" where
  "upair x y \<equiv> Replace (\<phi> x y) (\<P> (\<P> Emp))"

lemma upair_set : "Set (upair a b)"
  unfolding upair_def
  by (rule replace_set[OF pow_set[OF pow_set[OF emp_set]]])

lemma pow_emp_iff : "x \<in> \<P> \<emptyset> \<longleftrightarrow> x = \<emptyset>" unfolding pow_iff[OF emp_set]
proof
  assume "x \<subseteq> \<emptyset>" hence "Set x" "\<forall>a. a \<notin> x" using subset_iff by auto
  thus "x = \<emptyset>" using equals0I by blast
next
  assume "x = \<emptyset>" thus "x \<subseteq> \<emptyset>" using empty_subsetI[OF emp_set] by simp
qed

lemma pow_pow_emp_iff : "x \<in> \<P> (\<P> \<emptyset>) \<longleftrightarrow> (x = \<emptyset> | x = \<P> \<emptyset>)" unfolding pow_iff[OF pow_set[OF emp_set]]
proof
  assume "x \<subseteq> \<P> \<emptyset>" hence "Set x" using subset_set by auto (*and "\<forall>a. a \<in> x \<longrightarrow> a \<in> \<P> \<emptyset>" by auto*)
  hence "x = \<emptyset> | (\<exists>y. y \<in> x)" by (rule setE)
  thus "x = \<emptyset> | x = \<P> \<emptyset>"
  proof (rule, simp)
    assume "\<exists>y. y \<in> x" hence emp_x : "\<emptyset> \<in> x" using \<open>x \<subseteq> \<P> \<emptyset>\<close> pow_emp_iff by auto
    have "x = \<P> \<emptyset>" proof (rule equality_iffI[OF \<open>Set x\<close> pow_set[OF emp_set]])
      fix a show "a \<in> x \<longleftrightarrow> a \<in> \<P> \<emptyset>" using \<open>x \<subseteq> \<P> \<emptyset>\<close> \<open>\<emptyset> \<in> x\<close> pow_emp_iff by auto
    qed
    thus "x = \<emptyset> | x = \<P> \<emptyset>" by simp
  qed
next
  assume "x = \<emptyset> | x = \<P> \<emptyset>" thus "x \<subseteq> \<P> \<emptyset>"
  proof
    assume "x = \<emptyset>" thus "x \<subseteq> \<P> \<emptyset>"
      using empty_subsetI[OF pow_set[OF emp_set]] by simp
  next
    assume "x = \<P> \<emptyset>" thus "x \<subseteq> \<P> \<emptyset>"
      using subset_refl[OF pow_set[OF emp_set]] by simp
  qed
qed

lemma \<phi>_uniq : "\<phi> x y a b \<Longrightarrow> (\<forall>z. \<phi> x y a z \<longrightarrow> z = b)"
  using pow_emp_iff by blast

thm replace_iff[OF pow_set[OF pow_set[OF emp_set]]]
lemma upair_iff : "b \<in> upair x y \<longleftrightarrow> (b = x | b = y)"
  unfolding upair_def
proof (rule, erule replaceE2[OF pow_set[OF pow_set[OF emp_set]]])
  fix a assume "a \<in> (\<P> \<P> \<emptyset>)" and "\<phi> x y a b"
  thus "(b = x | b = y)" using pow_pow_emp_iff by auto
next
  assume "(b = x | b = y)"
  thus "b \<in> Replace (\<phi> x y) (\<P> \<P> \<emptyset>)"
  proof
    assume "b = x" show "b \<in> Replace (\<phi> x y) (\<P> \<P> \<emptyset>)"
    proof (rule replaceI)
      let ?a = "\<emptyset>" show "\<phi> x y ?a b" using \<open>b = x\<close> by simp
      show "\<emptyset> \<in> \<P> (\<P> \<emptyset>)" using pow_pow_emp_iff by simp
      show "\<And>c. \<phi> x y ?a c \<Longrightarrow> c = b" using \<phi>_uniq[OF `\<phi> x y ?a b`] by auto
    qed
  next
    assume "b = y" show "b \<in> Replace (\<phi> x y) (\<P> \<P> \<emptyset>)"
    proof (rule replaceI)
      let ?a = "\<P> \<emptyset>" show "\<phi> x y ?a b" using \<open>b = y\<close> by simp
      show "\<P> \<emptyset> \<in> \<P> (\<P> \<emptyset>)" using pow_pow_emp_iff by simp
      show "\<And>c. \<phi> x y ?a c \<Longrightarrow> c = b" using \<phi>_uniq[OF `\<phi> x y ?a b`] by auto
    qed
  qed
qed

lemma upairI1 : "a \<in> upair a b" using upair_iff by simp
lemma upairI2 : "b \<in> upair a b" using upair_iff by simp

lemma upairE : "\<lbrakk> a \<in> upair b c ; a=b \<Longrightarrow> P ; a=c \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (simp add: upair_iff, blast)

subsection \<open>Singleton sets\<close>

definition sng :: "'d \<Rightarrow> 'd" where
  "sng x \<equiv> upair x x"

lemma sng_set : "Set (sng a)" unfolding sng_def by (rule upair_set)

lemma sng_iff : "a \<in> sng x \<longleftrightarrow> a = x"
  unfolding sng_def using upair_iff by auto

lemma sngI : "a \<in> sng a" using sng_iff by auto

lemma sngE : "\<lbrakk> a \<in> sng x ; a = x \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using sng_iff by auto

subsection \<open>Properties of very small sets\<close>

lemma upair_subset: "a \<in> x \<Longrightarrow> b \<in> x \<Longrightarrow> upair a b \<subseteq> x" using upair_iff by (auto intro: subsetI[OF upair_set setI])
lemma sng_subset: "a \<in> x \<Longrightarrow> sng a \<subseteq> x" unfolding sng_def using upair_subset by auto

lemma sng_eq_iff : "sng a = sng b \<longleftrightarrow> a=b"
  by (rule equality_iff[OF sng_set, OF sng_set, THEN cnf.iff_trans],
      use sng_iff in auto)

lemma upair_eq_iff : "(upair a b) = (upair c d) \<longleftrightarrow> ((a=c \<and> b=d) | (a=d \<and> b=c))"
proof (rule equality_iff[OF upair_set upair_set, THEN cnf.iff_trans], rule)
  assume eq:"\<forall>x. x \<in> upair a b \<longleftrightarrow> x \<in> upair c d"
  have "a = b | a \<noteq> b" by simp
  thus "a = c \<and> b = d \<or> a = d \<and> b = c"
  proof
    assume "a = b" hence "upair a b = sng a" unfolding sng_def by simp
    hence "c = a \<and> d = a" using eq upair_iff sng_iff by auto
    thus "a = c \<and> b = d \<or> a = d \<and> b = c" using \<open>a = b\<close> by auto
  next
    assume "a \<noteq> b"
    have "a \<in> upair c d" "b \<in> upair c d" using eq upairI1 upairI2 by auto
    thus "a = c \<and> b = d \<or> a = d \<and> b = c" using \<open>a\<noteq>b\<close> upair_iff by auto
  qed
next
  assume "a = c \<and> b = d \<or> a = d \<and> b = c"
  thus "\<forall>x. (x \<in> upair a b) \<longleftrightarrow> (x \<in> upair c d)" using upair_iff by auto
qed

subsection \<open>Kuratowski ordered pairs\<close>

definition kpair :: "['d,'d] \<Rightarrow> 'd" where
  "kpair x y \<equiv> upair (upair x y) (upair x x)"

lemma kpair_iff : "kpair a b = kpair c d \<longleftrightarrow> a = c \<and> b = d"
  using kpair_def upair_eq_iff by auto

lemma pair_inject : "kpair a b = kpair c d \<Longrightarrow> (a=c \<Longrightarrow> b=d \<Longrightarrow> R) \<Longrightarrow> R "
  using kpair_iff by auto

lemma pair_inject1 : "kpair a b = kpair c d \<Longrightarrow> a=c"
  by (auto elim: pair_inject)
lemma pair_inject2 : "kpair a b = kpair c d \<Longrightarrow> b=d"
  by (auto elim: pair_inject)

subsection \<open>Cartesian product\<close>

definition cprod :: "['d, 'd] \<Rightarrow> 'd" (infixr \<open>\<times>\<close> 80) where
  "x \<times> y \<equiv> \<Union> Replace (\<lambda>a z. z = Replace (\<lambda>b p. p = kpair a b) y) x"

lemma cprod_set : assumes "Set x"
  shows "Set (x \<times> y)" unfolding cprod_def
  by (rule union_set[OF replace_set[OF assms]])

lemma cprod_iff : assumes "Set x" "Set y"
  shows "p \<in> x \<times> y \<longleftrightarrow> (\<exists>a b. p = kpair a b \<and> a \<in> x \<and> b \<in> y)"
proof -
  let ?R = "Replace (\<lambda>a z. z = Replace (\<lambda>b p. p = kpair a b) y) x"
  show ?thesis unfolding cprod_def
  proof (rule union_iff[OF replace_set[OF \<open>Set x\<close>], THEN cnf.iff_trans], rule)
    assume "bex ?R (\<lambda>a. p \<in> a)" then obtain r where "r \<in> ?R" "p \<in> r" by auto
    show "\<exists>a b. p = kpair a b \<and> a \<in> x \<and> b \<in> y"
    proof (rule replaceE2[OF \<open>Set x\<close> \<open>r \<in> ?R\<close>], rule)
      fix a assume "a \<in> x" "r = Replace (\<lambda>b p. p = kpair a b) y"
      hence "p \<in> Replace (\<lambda>b p. p = kpair a b) y" using \<open>p \<in> r\<close> by simp
      show "\<exists>b. p = kpair a b \<and> a \<in> x \<and> b \<in> y"
      proof (rule replaceE2[OF \<open>Set y\<close> \<open>p \<in> Replace (\<lambda>b p. p = kpair a b) y\<close>], rule)
        fix b assume "b \<in> y" "p = kpair a b"
        thus "p = kpair a b \<and> a \<in> x \<and> b \<in> y" using \<open>a \<in> x\<close> by auto
      qed
    qed
  next
    assume "\<exists>a b. p = kpair a b \<and> a \<in> x \<and> b \<in> y"
    then obtain a b where "p = kpair a b" "a \<in> x" "b \<in> y" by auto
    hence r: "p \<in> Replace (\<lambda>b p. p = kpair a b) y"
             "Replace (\<lambda>b p. p = kpair a b) y \<in> ?R"
      by (auto intro: replaceI)
    thus "bex ?R (\<lambda>r. p \<in> r)" using r by auto
  qed
qed

lemma cprod_iff_pair : assumes "Set x" "Set y"
  shows "kpair a b \<in> x \<times> y \<longleftrightarrow> a \<in> x \<and> b \<in> y"
  using cprod_iff[OF assms] pair_inject by blast

lemma cprodI : "a \<in> x \<Longrightarrow> b \<in> y \<Longrightarrow> p = kpair a b \<Longrightarrow> p \<in> x \<times> y"
  using setI cprod_iff by auto

lemma cprodI_pair : "a \<in> x \<Longrightarrow> b \<in> y \<Longrightarrow> kpair a b \<in> x \<times> y"
  using setI cprod_iff_pair by auto

lemma cprodD1 : assumes "Set x" "Set y" shows "kpair a b \<in> x \<times> y \<Longrightarrow> a \<in> x"
  using cprod_iff_pair[OF assms] by auto

lemma cprodD2 : assumes "Set x" "Set y" shows "kpair a b \<in> x \<times> y \<Longrightarrow> b \<in> y"
  using cprod_iff_pair[OF assms] by auto

lemma cprodE : assumes "Set x" "Set y"
  shows "\<lbrakk> p \<in> x \<times> y ; \<And>a b. \<lbrakk> a \<in> x ; b \<in> y ; p = kpair a b \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using cprod_iff[OF assms] by auto

lemma cprodE_pair : assumes "Set x" "Set y"
  shows "\<lbrakk> kpair a b \<in> x \<times> y ; \<And>a b. \<lbrakk> a \<in> x ; b \<in> y \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using cprod_iff[OF assms] by auto

lemma cprod_eq : "\<lbrakk> x=x' ; y=y' \<rbrakk> \<Longrightarrow> x\<times>y = x'\<times>y'" by auto

subsection \<open>Projection relations\<close>

definition fst :: "'d \<Rightarrow> 'd" (\<open>\<tau>\<close>) where
  "\<tau> p \<equiv> \<iota>' \<emptyset> (\<lambda>a. \<exists>b. p = kpair a b)"

definition snd :: "'d \<Rightarrow> 'd" (\<open>\<pi>\<close>) where
  "\<pi> p \<equiv> \<iota>' \<emptyset> (\<lambda>b. \<exists>a. p = kpair a b)"

lemma kpair_uniq1 : "p = kpair a b \<Longrightarrow> (\<exists>!a. (\<exists>b. p = kpair a b)) "
  using kpair_iff by auto

lemma kpair_uniq2 : "p = kpair a b \<Longrightarrow> (\<exists>!b. (\<exists>a. p = kpair a b))"
  using kpair_iff by auto

lemma fst_eq [simp]: "\<tau> (kpair a b) = a" unfolding fst_def
  by (rule the_def_eq', use kpair_uniq1 in auto)

lemma snd_eq [simp]: "\<pi> (kpair a b) = b" unfolding snd_def
  by (rule the_def_eq', use kpair_uniq2 in auto)

lemma fst_set : assumes "Set x" "Set y"
  shows "p \<in> x \<times> y \<Longrightarrow> \<tau> p \<in> x"
  by (rule cprodE[OF assms], use fst_eq in auto)

lemma snd_set : assumes "Set x" "Set y"
  shows "p \<in> x \<times> y \<Longrightarrow> \<pi> p \<in> y"
  by (rule cprodE[OF assms], use snd_eq in auto)

lemma fst_snd_eq : assumes "Set x" "Set y"
  shows "p \<in> x \<times> y \<Longrightarrow> kpair (\<tau> p) (\<pi> p) = p"
  by (rule cprodE[OF assms], use fst_eq snd_eq in auto)

subsection \<open>Binary union and intersection\<close>

definition un :: "['d,'d] \<Rightarrow> 'd" (infixl \<open>\<union>\<close> 90) where
  "x \<union> y \<equiv> \<Union> upair x y"

lemma un_set : "Set (x \<union> y)" unfolding un_def by (rule union_set[OF upair_set])

lemma un_iff : "a \<in> x \<union> y \<longleftrightarrow> (a \<in> x | a \<in> y)"
  unfolding un_def
  by (simp add: union_iff[OF upair_set],
      auto intro: upairI1 upairI2 elim: upairE)

lemma unI1 : "a \<in> x \<Longrightarrow> a \<in> x \<union> y" by (simp add: un_iff)
lemma unI2 : "b \<in> y \<Longrightarrow> b \<in> x \<union> y" by (simp add: un_iff)

lemma un_subset1 : assumes "Set x" shows "x \<subseteq> x \<union> y" using subsetI[OF assms un_set] unI1 by simp
lemma un_subset2 : assumes "Set y" shows "y \<subseteq> x \<union> y" using subsetI[OF assms un_set] unI2 by simp

lemma unE : "\<lbrakk> a \<in> x \<union> y ; a \<in> x \<Longrightarrow> P ; a \<in> y \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (simp add: un_iff, blast)

lemma unE' : "\<lbrakk> a \<in> x \<union> y ; a \<in> x \<Longrightarrow> P ; \<lbrakk> a \<in> y ; a \<notin> x \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (simp add: un_iff, blast)

lemma unCI : "(a \<notin> y \<Longrightarrow> a \<in> x) \<Longrightarrow> a \<in> x \<union> y"
  by (simp add: un_iff, blast)

definition int :: "['d,'d] \<Rightarrow> 'd" (infixl \<open>\<inter>\<close> 90) where
  "x \<inter> y \<equiv> \<Inter> upair x y"

lemma int_iff : "a \<in> x \<inter> y \<longleftrightarrow> (a \<in> x \<and> a \<in> y)"
  unfolding int_def
  by (simp add: Int_iff[OF upair_set],
      blast intro: upairI1 upairI2 elim: upairE)

lemma intI : "\<lbrakk> a \<in> x ; a \<in> y \<rbrakk> \<Longrightarrow> a \<in> x \<inter> y"
  by (simp add: int_iff)

lemma intD1 : "a \<in> x \<inter> y \<Longrightarrow> a \<in> x" by (simp add: int_iff)
lemma intD2 : "a \<in> x \<inter> y \<Longrightarrow> a \<in> y" by (simp add: int_iff)

lemma intE : "\<lbrakk> a \<in> x \<inter> y ; \<lbrakk> a \<in> x ; a \<in> y \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (simp add: int_iff)

subsection \<open>Converting a \<lambda>-function to a set-function\<close>

text \<open>Perhaps consider doing this development in a locale,
      so that we can abstract from the representation of the ordered pair.\<close>

definition converse :: "'d \<Rightarrow> 'd"
  where "converse r \<equiv> Replace (\<lambda>p q. \<exists>a b. p = kpair a b \<and> q = kpair b a) r"

definition domain :: "'d \<Rightarrow> 'd"
  where "domain r \<equiv> Replace (\<lambda>p x. (\<exists>y. p = kpair x y)) r"

definition range :: "'d \<Rightarrow> 'd"
  where "range r \<equiv> domain (converse r)"

definition field :: "'d \<Rightarrow> 'd"
  where "field r \<equiv> domain r \<union> range r"

definition relation :: "'d \<Rightarrow> bool"
  where "relation r \<equiv> ball r (\<lambda>p. \<exists>a b. p = kpair a b)"

definition func :: "'d \<Rightarrow> bool"
  where "func f \<equiv> \<forall>a b c. kpair a b \<in> f \<and> kpair a c \<in> f \<longrightarrow> b = c"

definition Lambda :: "['d, 'd \<Rightarrow> 'd] \<Rightarrow> 'd" where
  lam_def : "Lambda A F \<equiv> RepFun (\<lambda>x. kpair x (F x)) A"

definition "apply" :: "['d, 'd] \<Rightarrow> 'd"  (infixl \<open>`\<close> 90)
  where "f`a \<equiv> \<iota>' \<emptyset> (\<lambda>b. kpair a b \<in> f)"

definition image :: "['d,'d] \<Rightarrow> 'd"  (\<open>_[_]\<close> 90)
  where image_def: "f[x] \<equiv> RepFun (\<lambda>a. f`a) x"

lemma image_domain : "(Lambda D F)[D] = RepFun F D"
  sorry
end
end


(*  Title:       variants/e_all_abcd/Fresher.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
    Author:      Peter Höfner, NICTA
*)

section "Quality relations between routes"

theory E_Fresher
imports E_Aodv_Data
begin

subsection "Net sequence numbers"

subsubsection "On individual routes"

definition
  nsqn\<^sub>r :: "r \<Rightarrow> sqn"
where
  "nsqn\<^sub>r r \<equiv> if \<pi>\<^sub>4(r) = val \<or> \<pi>\<^sub>2(r) = 0 then \<pi>\<^sub>2(r) else (\<pi>\<^sub>2(r) - 1)"

lemma nsqnr_def':
  "nsqn\<^sub>r r = (if \<pi>\<^sub>4(r) = inv then \<pi>\<^sub>2(r) - 1 else \<pi>\<^sub>2(r))"
  unfolding nsqn\<^sub>r_def by simp

lemma nsqn\<^sub>r_zero [simp]:
  "\<And>dsn dsk flag hops nhip. nsqn\<^sub>r (0, dsk, flag, hops, nhip) = 0"
  unfolding nsqn\<^sub>r_def by clarsimp

lemma nsqn\<^sub>r_val [simp]:
  "\<And>dsn dsk hops nhip. nsqn\<^sub>r (dsn, dsk, val, hops, nhip) = dsn"
  unfolding nsqn\<^sub>r_def by clarsimp

lemma nsqn\<^sub>r_inv [simp]:
  "\<And>dsn dsk hops nhip. nsqn\<^sub>r (dsn, dsk, inv, hops, nhip) = dsn - 1"
  unfolding nsqn\<^sub>r_def by clarsimp

lemma nsqn\<^sub>r_lte_dsn [simp]:
  "\<And>dsn dsk flag hops nhip. nsqn\<^sub>r (dsn, dsk, flag, hops, nhip) \<le> dsn"
  unfolding nsqn\<^sub>r_def by clarsimp

subsubsection "On routes in routing tables"

definition
  nsqn :: "rt \<Rightarrow> ip \<Rightarrow> sqn"
where
  "nsqn \<equiv> \<lambda>rt dip. case \<sigma>\<^bsub>route\<^esub>(rt, dip) of None \<Rightarrow> 0 | Some r \<Rightarrow> nsqn\<^sub>r(r)"

lemma nsqn_sqn_def:
  "\<And>rt dip. nsqn rt dip = (if flag rt dip = Some val \<or> sqn rt dip = 0
                            then sqn rt dip else sqn rt dip - 1)"
  unfolding nsqn_def sqn_def by (clarsimp split: option.split)

lemma not_in_kD_nsqn [simp]:
  assumes "dip \<notin> kD(rt)"
  shows "nsqn rt dip = 0"
  using assms unfolding nsqn_def by simp

lemma sqn_nsqn:
  "\<And>rt dip. sqn rt dip - 1 \<le> nsqn rt dip"
  unfolding sqn_def nsqn_def by (clarsimp split: option.split)

lemma nsqn_sqn: "nsqn rt dip \<le> sqn rt dip"
  unfolding sqn_def nsqn_def by (cases "rt dip") auto

lemma val_nsqn_sqn [elim, simp]:
  assumes "ip\<in>kD(rt)"
      and "the (flag rt ip) = val"
    shows "nsqn rt ip = sqn rt ip"
  using assms unfolding nsqn_sqn_def by auto

lemma vD_nsqn_sqn [elim, simp]:
  assumes "ip\<in>vD(rt)"
    shows "nsqn rt ip = sqn rt ip"
  proof -
    from \<open>ip\<in>vD(rt)\<close> have "ip\<in>kD(rt)"
                      and "the (flag rt ip) = val" by auto
    thus ?thesis ..
  qed

lemma inv_nsqn_sqn [elim, simp]:
  assumes "ip\<in>kD(rt)"
      and "the (flag rt ip) = inv"
    shows "nsqn rt ip = sqn rt ip - 1"
  using assms unfolding nsqn_sqn_def by auto

lemma iD_nsqn_sqn [elim, simp]:
  assumes "ip\<in>iD(rt)"
    shows "nsqn rt ip = sqn rt ip - 1"
  proof -
    from \<open>ip\<in>iD(rt)\<close> have "ip\<in>kD(rt)"
                      and "the (flag rt ip) = inv" by auto
    thus ?thesis ..
  qed

lemma nsqn_update_changed_kno_val [simp]: "\<And>rt ip dsn dsk hops nhip.
  rt \<noteq> update rt ip (dsn, kno, val, hops, nhip)
   \<Longrightarrow> nsqn (update rt ip (dsn, kno, val, hops, nhip)) ip = dsn"
  unfolding nsqn\<^sub>r_def update_def
  by (clarsimp simp: kD_nsqn split: option.split_asm option.split if_split_asm)
     (metis fun_upd_triv)

lemma nsqn_update_other [simp]:
    fixes dsn dsk flag hops dip nhip pre rt ip
  assumes "dip \<noteq> ip"
    shows "nsqn (update rt ip (dsn, dsk, flag, hops, nhip)) dip = nsqn rt dip"
    using assms unfolding nsqn_def
    by (clarsimp split: option.split)

lemma nsqn_invalidate_eq:
  assumes "dip \<in> kD(rt)"
      and "dests dip = Some rsn"
    shows "nsqn (invalidate rt dests) dip = rsn - 1"
  using assms
  proof -
    from assms obtain dsk hops nhip
      where "invalidate rt dests dip = Some (rsn, dsk, inv, hops, nhip)"
      unfolding invalidate_def
      by auto
    moreover from \<open>dip \<in> kD(rt)\<close> have "dip \<in> kD(invalidate rt dests)" by simp
    ultimately show ?thesis
      using \<open>dests dip = Some rsn\<close> by simp
  qed

lemma nsqn_invalidate_other [simp]:
  assumes "dip\<in>kD(rt)"
      and "dip\<notin>dom dests"
    shows "nsqn (invalidate rt dests) dip = nsqn rt dip"
  using assms by (clarsimp simp add: kD_nsqn)

subsection "Comparing routes "

definition
  fresher :: "r \<Rightarrow> r \<Rightarrow> bool" ("(_/ \<sqsubseteq> _)"  [51, 51] 50)
where
  "fresher r r' \<equiv> ((nsqn\<^sub>r r < nsqn\<^sub>r r') \<or> (nsqn\<^sub>r r  = nsqn\<^sub>r r' \<and> \<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r')))"

lemma fresherI1 [intro]:
  assumes "nsqn\<^sub>r r < nsqn\<^sub>r r'"
    shows "r \<sqsubseteq> r'"
  unfolding fresher_def using assms by simp

lemma fresherI2 [intro]:
  assumes "nsqn\<^sub>r r = nsqn\<^sub>r r'"
      and "\<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r')"
    shows "r \<sqsubseteq> r'"
  unfolding fresher_def using assms by simp

lemma fresherI [intro]:
  assumes "(nsqn\<^sub>r r < nsqn\<^sub>r r') \<or> (nsqn\<^sub>r r  = nsqn\<^sub>r r' \<and> \<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r'))"
    shows "r \<sqsubseteq> r'"
  unfolding fresher_def using assms .

lemma fresherE [elim]:
  assumes "r \<sqsubseteq> r'"
      and "nsqn\<^sub>r r < nsqn\<^sub>r r' \<Longrightarrow> P r r'"
      and "nsqn\<^sub>r r  = nsqn\<^sub>r r' \<and> \<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r') \<Longrightarrow> P r r'"
    shows "P r r'"
  using assms unfolding fresher_def by auto

lemma fresher_refl [simp]: "r \<sqsubseteq> r"
  unfolding fresher_def by simp

lemma fresher_trans [elim, trans]:
  "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
  unfolding fresher_def by auto

lemma not_fresher_trans [elim, trans]:
  "\<lbrakk> \<not>(x \<sqsubseteq> y); \<not>(z \<sqsubseteq> x) \<rbrakk> \<Longrightarrow> \<not>(z \<sqsubseteq> y)"
  unfolding fresher_def by auto

subsection "Comparing routing tables "

definition
  rt_fresher :: "ip \<Rightarrow> rt \<Rightarrow> rt \<Rightarrow> bool"
where
  "rt_fresher \<equiv> \<lambda>dip rt rt'. (the (\<sigma>\<^bsub>route\<^esub>(rt, dip))) \<sqsubseteq> (the (\<sigma>\<^bsub>route\<^esub>(rt', dip)))"

abbreviation
   rt_fresher_syn :: "rt \<Rightarrow> ip \<Rightarrow> rt \<Rightarrow> bool" ("(_/ \<sqsubseteq>\<^bsub>_\<^esub> _)"  [51, 999, 51] 50)
where
  "rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2 \<equiv> rt_fresher i rt1 rt2"

lemma single_rt_fresher [intro]:
  assumes "the (rt1 ip) \<sqsubseteq> the (rt2 ip)"
    shows "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
  using assms unfolding rt_fresher_def .

lemma rt_fresher_single [intro]:
  assumes "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
    shows "the (rt1 ip) \<sqsubseteq> the (rt2 ip)"
  using assms unfolding rt_fresher_def .

lemma rt_fresher_def2:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
    shows "(rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2) = (nsqn rt1 dip < nsqn rt2 dip
                               \<or> (nsqn rt1 dip = nsqn rt2 dip
                                   \<and> the (dhops rt1 dip) \<ge> the (dhops rt2 dip)))"
  using assms unfolding rt_fresher_def fresher_def by (simp add: kD_nsqn proj5_eq_dhops)

lemma rt_fresherI1 [intro]:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "nsqn rt1 dip < nsqn rt2 dip"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
  unfolding rt_fresher_def2 [OF assms(1-2)] using assms(3) by simp

lemma rt_fresherI2 [intro]:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "nsqn rt1 dip = nsqn rt2 dip"
      and "the (dhops rt1 dip) \<ge> the (dhops rt2 dip)"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
  unfolding rt_fresher_def2 [OF assms(1-2)] using assms(3-4) by simp

lemma rt_fresherE [elim]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "\<lbrakk> nsqn rt1 dip < nsqn rt2 dip \<rbrakk> \<Longrightarrow> P rt1 rt2 dip"
      and "\<lbrakk> nsqn rt1 dip = nsqn rt2 dip;
             the (dhops rt1 dip) \<ge> the (dhops rt2 dip) \<rbrakk> \<Longrightarrow> P rt1 rt2 dip"
    shows "P rt1 rt2 dip"
  using assms(1) unfolding rt_fresher_def2 [OF assms(2-3)]
  using assms(4-5) by auto

lemma rt_fresher_refl [simp]: "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt"
  unfolding rt_fresher_def by simp

lemma rt_fresher_trans [elim, trans]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
  using assms unfolding rt_fresher_def by auto

lemma rt_fresher_if_Some [intro!]:
  assumes "the (rt dip) \<sqsubseteq> r"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> (\<lambda>ip. if ip = dip then Some r else rt ip)"
  using assms unfolding rt_fresher_def by simp

definition rt_fresh_as :: "ip \<Rightarrow> rt \<Rightarrow> rt \<Rightarrow> bool"
where
  "rt_fresh_as \<equiv> \<lambda>dip rt1 rt2. (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2) \<and> (rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"

abbreviation
   rt_fresh_as_syn :: "rt \<Rightarrow> ip \<Rightarrow> rt \<Rightarrow> bool" ("(_/ \<approx>\<^bsub>_\<^esub> _)"  [51, 999, 51] 50)
where
  "rt1 \<approx>\<^bsub>i\<^esub> rt2 \<equiv> rt_fresh_as i rt1 rt2"

lemma rt_fresh_as_refl [simp]: "\<And>rt dip. rt \<approx>\<^bsub>dip\<^esub> rt"
  unfolding rt_fresh_as_def by simp

lemma rt_fresh_as_trans [simp, intro, trans]:
  "\<And>rt1 rt2 rt3 dip. \<lbrakk> rt1 \<approx>\<^bsub>dip\<^esub> rt2; rt2 \<approx>\<^bsub>dip\<^esub> rt3 \<rbrakk> \<Longrightarrow> rt1 \<approx>\<^bsub>dip\<^esub> rt3"
  unfolding rt_fresh_as_def rt_fresher_def
  by (metis (mono_tags) fresher_trans)

lemma rt_fresh_asI [intro!]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
    shows "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_as_fresherI [intro]:
  assumes "dip\<in>kD(rt1)"
      and "dip\<in>kD(rt2)"
      and "the (rt1 dip) \<sqsubseteq> the (rt2 dip)"
      and "the (rt2 dip) \<sqsubseteq> the (rt1 dip)"
    shows "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_fresh_as_def
  by (clarsimp dest!: single_rt_fresher)

lemma nsqn_rt_fresh_asI:
  assumes "dip \<in> kD(rt)"
      and "dip \<in> kD(rt')"
      and "nsqn rt dip = nsqn rt' dip"
      and "\<pi>\<^sub>5(the (rt dip)) = \<pi>\<^sub>5(the (rt' dip))"
    shows "rt \<approx>\<^bsub>dip\<^esub> rt'"
  proof
    from assms(1-2,4) have dhops': "the (dhops rt' dip) \<le> the (dhops rt dip)"
      by (simp add: proj5_eq_dhops)
    with assms(1-3) show "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt'"
      by (rule rt_fresherI2)
  next
    from assms(1-2,4) have dhops: "the (dhops rt dip) \<le> the (dhops rt' dip)"
      by (simp add: proj5_eq_dhops)
    with assms(2,1) assms(3) [symmetric] show "rt' \<sqsubseteq>\<^bsub>dip\<^esub> rt"
      by (rule rt_fresherI2)
  qed

lemma rt_fresh_asE [elim]:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
      and "\<lbrakk> rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2; rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1 \<rbrakk> \<Longrightarrow> P rt1 rt2 dip"
    shows "P rt1 rt2 dip"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_asD1 [dest]:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_asD2 [dest]:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_as_sym:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "rt2 \<approx>\<^bsub>dip\<^esub> rt1"
  using assms unfolding rt_fresh_as_def by simp

lemma not_rt_fresh_asI1 [intro]:
  assumes "\<not> (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)"
    shows "\<not> (rt1 \<approx>\<^bsub>dip\<^esub> rt2)"
  proof
    assume "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    hence "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2" ..
    with \<open>\<not> (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)\<close> show False ..
  qed

lemma not_rt_fresh_asI2 [intro]:
  assumes "\<not> (rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
    shows "\<not> (rt1 \<approx>\<^bsub>dip\<^esub> rt2)"
  proof
    assume "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    hence "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1" ..
    with \<open>\<not> (rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)\<close> show False ..
  qed

lemma not_single_rt_fresher [elim]:
  assumes "\<not>(the (rt1 ip) \<sqsubseteq> the (rt2 ip))"
    shows "\<not>(rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2)"
  proof
    assume "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
    hence "the (rt1 ip) \<sqsubseteq> the (rt2 ip)" ..
    with \<open>\<not>(the (rt1 ip) \<sqsubseteq> the (rt2 ip))\<close> show False ..
  qed

lemmas not_single_rt_fresh_asI1 [intro] =  not_rt_fresh_asI1 [OF not_single_rt_fresher]
lemmas not_single_rt_fresh_asI2 [intro] =  not_rt_fresh_asI2 [OF not_single_rt_fresher]

lemma not_rt_fresher_single [elim]:
  assumes "\<not>(rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2)"
    shows "\<not>(the (rt1 ip) \<sqsubseteq> the (rt2 ip))"
  proof
    assume "the (rt1 ip) \<sqsubseteq> the (rt2 ip)"
    hence "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2" ..
    with \<open>\<not>(rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2)\<close> show False ..
  qed

lemma rt_fresh_as_nsqnr:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "nsqn\<^sub>r (the (rt2 dip)) = nsqn\<^sub>r (the (rt1 dip))"
  using assms(3) unfolding rt_fresh_as_def
  by (auto simp: rt_fresher_def2 [OF \<open>dip \<in> kD(rt1)\<close> \<open>dip \<in> kD(rt2)\<close>]
                 rt_fresher_def2 [OF \<open>dip \<in> kD(rt2)\<close> \<open>dip \<in> kD(rt1)\<close>]
                 kD_nsqn [OF \<open>dip \<in> kD(rt1)\<close>]
                 kD_nsqn [OF \<open>dip \<in> kD(rt2)\<close>])

lemma rt_fresher_mapupd [intro!]:
  assumes "dip\<in>kD(rt)"
      and "the (rt dip) \<sqsubseteq> r"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt(dip \<mapsto> r)"
  using assms unfolding rt_fresher_def by simp

lemma rt_fresher_map_update_other [intro!]:
  assumes "dip\<in>kD(rt)"
      and "dip \<noteq> ip"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt(ip \<mapsto> r)"
  using assms unfolding rt_fresher_def by simp

lemma rt_fresher_update_other [simp]:
  assumes inkD: "dip\<in>kD(rt)"
     and "dip \<noteq> ip"
   shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> update rt ip r"
   using assms unfolding update_def
   by (clarsimp split: option.split) (fastforce)

theorem rt_fresher_update [simp]:
  assumes "dip\<in>kD(rt)"
      and "the (dhops rt dip) \<ge> 1"
      and "update_arg_wf r"
   shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> update rt ip r"
  proof (cases "dip = ip")
    assume "dip \<noteq> ip" with \<open>dip\<in>kD(rt)\<close> show ?thesis
      by (rule rt_fresher_update_other)
  next
    assume "dip = ip"

    from \<open>dip\<in>kD(rt)\<close> obtain dsn\<^sub>n dsk\<^sub>n f\<^sub>n hops\<^sub>n nhip\<^sub>n
      where rtn [simp]: "the (rt dip) = (dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)"
      by (metis prod_cases5)
    with \<open>the (dhops rt dip) \<ge> 1\<close> and \<open>dip\<in>kD(rt)\<close> have "hops\<^sub>n \<ge> 1"
      by (metis proj5_eq_dhops projs(4))
    from \<open>dip\<in>kD(rt)\<close> rtn have [simp]: "sqn rt dip = dsn\<^sub>n"
                           and [simp]: "the (dhops rt dip) = hops\<^sub>n"
                           and [simp]: "the (flag rt dip) = f\<^sub>n"
      by (simp add: sqn_def proj5_eq_dhops [symmetric]
                            proj4_eq_flag [symmetric])+

    from \<open>update_arg_wf r\<close> have "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
                                  \<sqsubseteq> the ((update rt dip r) dip)"
      proof (rule wf_r_cases)
        fix nhip
        from \<open>hops\<^sub>n \<ge> 1\<close> have "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
                                        \<sqsubseteq> (dsn\<^sub>n, unk, val, Suc 0, nhip)"
          unfolding fresher_def sqn_def by (cases f\<^sub>n) auto
        thus "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
               \<sqsubseteq> the (update rt dip (0, unk, val, Suc 0, nhip) dip)"
          using \<open>dip\<in>kD(rt)\<close> by - (rule update_cases_kD, simp_all)
      next
        fix dsn :: sqn and hops nhip
        assume "0 < dsn"
        show "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
               \<sqsubseteq> the (update rt dip (dsn, kno, val, hops, nhip) dip)"
        proof (rule update_cases_kD [OF _ \<open>dip\<in>kD(rt)\<close>], simp_all add: \<open>0 < dsn\<close>)
          assume "dsn\<^sub>n < dsn"
            thus "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip)"
              unfolding fresher_def by auto
        next
          assume "dsn\<^sub>n = dsn"
             and "hops < hops\<^sub>n"
            thus "(dsn, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip)"
              unfolding fresher_def nsqn\<^sub>r_def by simp
        next
          assume "dsn\<^sub>n = dsn"
            with \<open>0 < dsn\<close>
            show "(dsn, dsk\<^sub>n, inv, hops\<^sub>n, nhip\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip)"
              unfolding fresher_def by simp
        qed
      qed
    hence "rt \<sqsubseteq>\<^bsub>dip\<^esub> update rt dip r"
      by - (rule single_rt_fresher, simp)
    with \<open>dip = ip\<close> show ?thesis by simp
  qed

theorem rt_fresher_invalidate [simp]:
  assumes "dip\<in>kD(rt)"
      and indests: "\<forall>rip\<in>dom(dests). rip\<in>vD(rt) \<and> sqn rt rip < the (dests rip)"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> invalidate rt dests"
  proof (cases "dip\<in>dom(dests)")
    assume "dip\<notin>dom(dests)"
      thus ?thesis using \<open>dip\<in>kD(rt)\<close>
      by - (rule single_rt_fresher, simp)
  next
    assume "dip\<in>dom(dests)"
    moreover with indests have "dip\<in>vD(rt)"
                           and "sqn rt dip < the (dests dip)"
      by auto
    ultimately show ?thesis
      unfolding invalidate_def sqn_def
      by - (rule single_rt_fresher, auto simp: fresher_def)
  qed

lemma nsqn\<^sub>r_invalidate [simp]:
  assumes "dip\<in>kD(rt)"
      and "dip\<in>dom(dests)"
    shows "nsqn\<^sub>r (the (invalidate rt dests dip)) = the (dests dip) - 1"
  using assms unfolding invalidate_def by auto

lemma rt_fresh_as_inc_invalidate [simp]:
  assumes "dip\<in>kD(rt)"
      and "\<forall>rip\<in>dom(dests). rip\<in>vD(rt) \<and> the (dests rip) = inc (sqn rt rip)"
    shows "rt \<approx>\<^bsub>dip\<^esub> invalidate rt dests"
  proof (cases "dip\<in>dom(dests)")
    assume "dip\<notin>dom(dests)"
    with \<open>dip\<in>kD(rt)\<close> have "dip\<in>kD(invalidate rt dests)"
      by simp
    with \<open>dip\<in>kD(rt)\<close> show ?thesis
      by rule (simp_all add: \<open>dip\<notin>dom(dests)\<close>)
  next
    assume "dip\<in>dom(dests)"
    with assms(2) have "dip\<in>vD(rt)"
                  and "the (dests dip) = inc (sqn rt dip)" by auto
    from \<open>dip\<in>vD(rt)\<close> have "dip\<in>kD(rt)" by simp
    moreover then have "dip\<in>kD(invalidate rt dests)" by simp
    ultimately show ?thesis
    proof (rule nsqn_rt_fresh_asI)
      from \<open>dip\<in>vD(rt)\<close> have "nsqn rt dip = sqn rt dip" by simp
      also have "sqn rt dip = nsqn\<^sub>r (the (invalidate rt dests dip))"
      proof -
        from \<open>dip\<in>kD(rt)\<close> have "nsqn\<^sub>r (the (invalidate rt dests dip)) = the (dests dip) - 1"
          using \<open>dip\<in>dom(dests)\<close> by (rule nsqn\<^sub>r_invalidate)
        with \<open>the (dests dip) = inc (sqn rt dip)\<close>
          show "sqn rt dip = nsqn\<^sub>r (the (invalidate rt dests dip))" by simp
      qed
      also from \<open>dip\<in>kD(invalidate rt dests)\<close>
        have "nsqn\<^sub>r (the (invalidate rt dests dip)) = nsqn (invalidate rt dests) dip"
          by (simp add: kD_nsqn)
      finally show "nsqn rt dip = nsqn (invalidate rt dests) dip" .
    qed simp
  qed

lemmas rt_fresher_inc_invalidate [simp] = rt_fresh_as_inc_invalidate [THEN rt_fresh_asD1]

subsection "Strictly comparing routing tables "

definition rt_strictly_fresher :: "ip \<Rightarrow> rt \<Rightarrow> rt \<Rightarrow> bool"
where
  "rt_strictly_fresher \<equiv> \<lambda>dip rt1 rt2. (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2) \<and> \<not>(rt1 \<approx>\<^bsub>dip\<^esub> rt2)"

abbreviation
   rt_strictly_fresher_syn :: "rt \<Rightarrow> ip \<Rightarrow> rt \<Rightarrow> bool" ("(_/ \<sqsubset>\<^bsub>_\<^esub> _)"  [51, 999, 51] 50)
where
  "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2 \<equiv> rt_strictly_fresher i rt1 rt2"

lemma rt_strictly_fresher_def'':
  "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2 = ((rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2) \<and> \<not>(rt2 \<sqsubseteq>\<^bsub>i\<^esub> rt1))"
  unfolding rt_strictly_fresher_def rt_fresh_as_def by auto

lemma rt_strictly_fresherI' [intro]:
  assumes "rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2"
      and "\<not>(rt2 \<sqsubseteq>\<^bsub>i\<^esub> rt1)"
    shows "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
  using assms unfolding rt_strictly_fresher_def'' by simp

lemma rt_strictly_fresherE' [elim]:
  assumes "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
      and "\<lbrakk> rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2; \<not>(rt2 \<sqsubseteq>\<^bsub>i\<^esub> rt1) \<rbrakk> \<Longrightarrow> P rt1 rt2 i"
    shows "P rt1 rt2 i"
  using assms unfolding rt_strictly_fresher_def'' by simp

lemma rt_strictly_fresherI [intro]:
  assumes "rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2"
      and "\<not>(rt1 \<approx>\<^bsub>i\<^esub> rt2)"
    shows "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
  unfolding rt_strictly_fresher_def using assms ..

lemmas rt_strictly_fresher_singleI [elim] = rt_strictly_fresherI [OF single_rt_fresher]

lemma rt_strictly_fresherE [elim]:
  assumes "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
      and "\<lbrakk> rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2; \<not>(rt1 \<approx>\<^bsub>i\<^esub> rt2) \<rbrakk> \<Longrightarrow> P rt1 rt2 i"
    shows "P rt1 rt2 i"
  using assms(1) unfolding rt_strictly_fresher_def
  by rule (erule(1) assms(2))

lemma rt_strictly_fresher_def':
  "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2 =
     (nsqn\<^sub>r (the (rt1 i)) < nsqn\<^sub>r (the (rt2 i))
       \<or> (nsqn\<^sub>r (the (rt1 i)) = nsqn\<^sub>r (the (rt2 i)) \<and> \<pi>\<^sub>5(the (rt1 i)) > \<pi>\<^sub>5(the (rt2 i))))"
  unfolding rt_strictly_fresher_def'' rt_fresher_def fresher_def by auto

lemma rt_strictly_fresher_fresherD [dest]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
    shows "the (rt1 dip) \<sqsubseteq> the (rt2 dip)"
  using assms unfolding rt_strictly_fresher_def rt_fresher_def by auto

lemma rt_strictly_fresher_not_fresh_asD [dest]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
    shows "\<not> rt1 \<approx>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_strictly_fresher_def by auto

lemma rt_strictly_fresher_trans [elim, trans]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
  using assms proof -
    from \<open>rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2\<close> obtain "the (rt1 dip) \<sqsubseteq> the (rt2 dip)" by auto
    also from \<open>rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3\<close> obtain "the (rt2 dip) \<sqsubseteq> the (rt3 dip)" by auto
    finally have "the (rt1 dip) \<sqsubseteq> the (rt3 dip)" .

    moreover have "\<not> (rt1 \<approx>\<^bsub>dip\<^esub> rt3)"
    proof -
      from \<open>rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2\<close> obtain "\<not>(the (rt2 dip) \<sqsubseteq> the (rt1 dip))" by auto
      also from \<open>rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3\<close> obtain "\<not>(the (rt3 dip) \<sqsubseteq> the (rt2 dip))" by auto
      finally have "\<not>(the (rt3 dip) \<sqsubseteq> the (rt1 dip))" .
      thus ?thesis ..
    qed
    ultimately show "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3" ..
 qed

lemma rt_strictly_fresher_irefl [simp]: "\<not> (rt \<sqsubset>\<^bsub>dip\<^esub> rt)"
  unfolding rt_strictly_fresher_def
  by clarsimp

lemma rt_fresher_trans_rt_strictly_fresher [elim, trans]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
  proof -
    from \<open>rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2\<close> have "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
                           and "\<not>(rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
      unfolding rt_strictly_fresher_def'' by auto
    from this(1) and \<open>rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3\<close> have "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt3" ..

    moreover from \<open>\<not>(rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)\<close> have "\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
      proof (rule contrapos_nn)
        assume "rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
        with \<open>rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3\<close> show "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1" ..
      qed

    ultimately show "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
      unfolding rt_strictly_fresher_def'' by auto
  qed

lemma rt_fresher_trans_rt_strictly_fresher' [elim, trans]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
  proof -
    from \<open>rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3\<close> have "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
                           and "\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)"
      unfolding rt_strictly_fresher_def'' by auto
    from \<open>rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2\<close> and this(1) have "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt3" ..

    moreover from \<open>\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)\<close> have "\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
      proof (rule contrapos_nn)
        assume "rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
        thus "rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt2" using \<open>rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2\<close> ..
      qed

    ultimately show "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
      unfolding rt_strictly_fresher_def'' by auto
  qed

lemma rt_fresher_imp_nsqn_le:
  assumes "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
      and "ip \<in> kD rt1"
      and "ip \<in> kD rt2"
    shows "nsqn rt1 ip \<le> nsqn rt2 ip"
  using assms(1)
  by (auto simp add: rt_fresher_def2 [OF assms(2-3)])

lemma rt_strictly_fresher_ltI [intro]:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "nsqn rt1 dip < nsqn rt2 dip"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
  proof
    from assms show "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2" ..
  next
    show "\<not>(rt1 \<approx>\<^bsub>dip\<^esub> rt2)"
    proof
      assume "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
      hence "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1" ..
      hence "nsqn rt2 dip \<le> nsqn rt1 dip"
        using \<open>dip \<in> kD(rt2)\<close> \<open>dip \<in> kD(rt1)\<close>
        by (rule rt_fresher_imp_nsqn_le)
      with \<open>nsqn rt1 dip < nsqn rt2 dip\<close> show "False"
        by simp
    qed
  qed

lemma rt_strictly_fresher_eqI [intro]:
  assumes "i\<in>kD(rt1)"
      and "i\<in>kD(rt2)"
      and "nsqn rt1 i = nsqn rt2 i"
      and "\<pi>\<^sub>5(the (rt2 i)) < \<pi>\<^sub>5(the (rt1 i))"
    shows "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
  using assms unfolding rt_strictly_fresher_def' by (auto simp add: kD_nsqn)

lemma invalidate_rtsf_left [simp]:
  "\<And>dests dip rt rt'. dests dip = None \<Longrightarrow> (invalidate rt dests \<sqsubset>\<^bsub>dip\<^esub> rt') = (rt \<sqsubset>\<^bsub>dip\<^esub> rt')"
  unfolding invalidate_def rt_strictly_fresher_def'
  by (rule iffI) (auto split: option.split_asm)

lemma vD_invalidate_rt_strictly_fresher [simp]:
  assumes "dip \<in> vD(invalidate rt1 dests)"
    shows "(invalidate rt1 dests \<sqsubset>\<^bsub>dip\<^esub> rt2) = (rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2)"
  proof (cases "dip \<in> dom(dests)")
    assume "dip \<in> dom(dests)"
    hence "dip \<notin> vD(invalidate rt1 dests)"
      unfolding invalidate_def vD_def
      by clarsimp (metis assms option.simps(3) vD_invalidate_vD_not_dests)
    with \<open>dip \<in> vD(invalidate rt1 dests)\<close> show ?thesis by simp
  next
    assume "dip \<notin> dom(dests)"
    hence "dests dip = None" by auto
    moreover with \<open>dip \<in> vD(invalidate rt1 dests)\<close> have "dip \<in> vD(rt1)"
      unfolding invalidate_def vD_def
      by clarsimp (metis (hide_lams, no_types) assms vD_Some vD_invalidate_vD_not_dests)
    ultimately show ?thesis
      unfolding invalidate_def rt_strictly_fresher_def' by auto
  qed

lemma rt_strictly_fresher_update_other [elim!]:
  "\<And>dip ip rt r rt'. \<lbrakk> dip \<noteq> ip; rt \<sqsubset>\<^bsub>dip\<^esub> rt' \<rbrakk> \<Longrightarrow> update rt ip r \<sqsubset>\<^bsub>dip\<^esub> rt'"
  unfolding rt_strictly_fresher_def' by clarsimp

lemma lt_sqn_imp_update_strictly_fresher:
  assumes "dip \<in> vD (rt2 nhip)"
      and  *: "osn < sqn (rt2 nhip) dip"
      and **: "rt \<noteq> update rt dip (osn, kno, val, hops, nhip)"
    shows "update rt dip (osn, kno, val, hops, nhip) \<sqsubset>\<^bsub>dip\<^esub> rt2 nhip"
  unfolding rt_strictly_fresher_def'
  proof (rule disjI1)
    from ** have "nsqn (update rt dip (osn, kno, val, hops, nhip)) dip = osn"
      by (rule nsqn_update_changed_kno_val)
    with \<open>dip\<in>vD(rt2 nhip)\<close>
      have "nsqn\<^sub>r (the (update rt dip (osn, kno, val, hops, nhip) dip)) = osn"
        by (simp add: kD_nsqn)
    also have "osn < sqn (rt2 nhip) dip" by (rule *)
    also have "sqn (rt2 nhip) dip = nsqn\<^sub>r (the (rt2 nhip dip))"
      unfolding nsqn\<^sub>r_def using \<open>dip \<in> vD (rt2 nhip)\<close>
      by - (metis vD_flag_val proj2_eq_sqn proj4_eq_flag vD_iD_gives_kD(1))
    finally show "nsqn\<^sub>r (the (update rt dip (osn, kno, val, hops, nhip) dip))
                                                              < nsqn\<^sub>r (the (rt2 nhip dip))" .
  qed

lemma dhops_le_hops_imp_update_strictly_fresher:
  assumes "dip \<in> vD(rt2 nhip)"
      and sqn: "sqn (rt2 nhip) dip = osn"
      and hop: "the (dhops (rt2 nhip) dip) \<le> hops"
      and **: "rt \<noteq> update rt dip (osn, kno, val, Suc hops, nhip)"
    shows "update rt dip (osn, kno, val, Suc hops, nhip) \<sqsubset>\<^bsub>dip\<^esub> rt2 nhip"
  unfolding rt_strictly_fresher_def'
  proof (rule disjI2, rule conjI)
    from ** have "nsqn (update rt dip (osn, kno, val, Suc hops, nhip)) dip = osn"
      by (rule nsqn_update_changed_kno_val)
    with \<open>dip\<in>vD(rt2 nhip)\<close>
      have "nsqn\<^sub>r (the (update rt dip (osn, kno, val, Suc hops, nhip) dip)) = osn"
        by (simp add: kD_nsqn)
    also have "osn = sqn (rt2 nhip) dip" by (rule sqn [symmetric])
    also have "sqn (rt2 nhip) dip = nsqn\<^sub>r (the (rt2 nhip dip))"
      unfolding nsqn\<^sub>r_def using \<open>dip \<in> vD(rt2 nhip)\<close>
      by - (metis vD_flag_val proj2_eq_sqn proj4_eq_flag vD_iD_gives_kD(1))
    finally show "nsqn\<^sub>r (the (update rt dip (osn, kno, val, Suc hops, nhip) dip))
                                                              = nsqn\<^sub>r (the (rt2 nhip dip))" .
  next
    have "the (dhops (rt2 nhip) dip) \<le> hops" by (rule hop)
    also have "hops < hops + 1" by simp
    also have "hops + 1 = the (dhops (update rt dip (osn, kno, val, Suc hops, nhip)) dip)"
      using ** by simp
    finally have "the (dhops (rt2 nhip) dip)
                        < the (dhops (update rt dip (osn, kno, val, Suc hops, nhip)) dip)" .
    thus "\<pi>\<^sub>5 (the (rt2 nhip dip)) < \<pi>\<^sub>5 (the (update rt dip (osn, kno, val, Suc hops, nhip) dip))"
      using \<open>dip \<in> vD(rt2 nhip)\<close> by (simp add: proj5_eq_dhops)
  qed

lemma nsqn_invalidate:
  assumes "dip \<in> kD(rt)"
      and "\<forall>ip\<in>dom(dests). ip \<in> vD(rt) \<and> the (dests ip) = inc (sqn rt ip)"
    shows "nsqn (invalidate rt dests) dip = nsqn rt dip"
  proof -
    from \<open>dip \<in> kD(rt)\<close> have "dip \<in> kD(invalidate rt dests)" by simp

    from assms have "rt \<approx>\<^bsub>dip\<^esub> invalidate rt dests"
      by (rule rt_fresh_as_inc_invalidate)
    with \<open>dip \<in> kD(rt)\<close> \<open>dip \<in> kD(invalidate rt dests)\<close> show ?thesis
      by (simp add: kD_nsqn del: invalidate_kD_inv)
         (erule(2) rt_fresh_as_nsqnr)
  qed

end


(*  Title:      HOL/Datatype_Examples/Lift_BNF.thy
    Author:     Dmitriy Traytel, ETH Zürich
    Copyright   2015

Demonstration of the "lift_bnf" command.
*)

section \<open>Demonstration of the \textbf{lift_bnf} Command\<close>

theory Lift_BNF
imports Main
begin

subsection \<open>Lifting \textbf{typedef}s\<close>

typedef 'a nonempty_list = "{xs :: 'a list. xs \<noteq> []}"
  by blast
setup_lifting type_definition_nonempty_list

lift_bnf (no_warn_wits) (neset: 'a) nonempty_list
  for map: nemap rel: nerel
  by auto

typedef ('a :: finite, 'b) fin_nonempty_list = "{(xs :: 'a set, ys :: 'b list). ys \<noteq> []}"
  by blast
setup_lifting type_definition_fin_nonempty_list

lift_bnf (no_warn_wits) (dead 'a :: finite, 'b) fin_nonempty_list
  [wits: "\<lambda>b. ({} :: 'a :: finite set, [b :: 'b])"]
  by auto

datatype 'a tree = Leaf | Node 'a "'a tree nonempty_list"

record 'a point =
  xCoord :: 'a
  yCoord :: 'a

copy_bnf (no_warn_transfer) ('a, 's) point_ext

typedef 'a it = "UNIV :: 'a set"
  by blast

setup_lifting type_definition_it

copy_bnf (plugins del: size) 'a it

typedef ('a, 'b) T_prod = "UNIV :: ('a \<times> 'b) set"
  by blast

setup_lifting type_definition_T_prod

copy_bnf ('a, 'b) T_prod

typedef ('a, 'b, 'c) T_func = "UNIV :: ('a \<Rightarrow> 'b * 'c) set"
  by blast

setup_lifting type_definition_T_func

copy_bnf ('a, 'b, 'c) T_func

typedef ('a, 'b) sum_copy = "UNIV :: ('a + 'b) set"
  by blast

setup_lifting type_definition_sum_copy

copy_bnf ('a, 'b) sum_copy

typedef ('a, 'b) T_sum = "{Inl x | x. True} :: ('a + 'b) set"
  by blast

lift_bnf (no_warn_wits, no_warn_transfer) ('a, 'b) T_sum [wits: "Inl :: 'a \<Rightarrow> 'a + 'b"]
  by (force simp: map_sum_def sum_set_defs split: sum.splits)+

typedef ('key, 'value) alist = "{xs :: ('key \<times> 'value) list. (distinct \<circ> map fst) xs}"
  morphisms impl_of Alist
proof
  show "[] \<in> {xs. (distinct o map fst) xs}"
    by simp
qed

setup_lifting type_definition_alist

lift_bnf (dead 'k, 'v) alist [wits: "Nil :: ('k \<times> 'v) list"]
  by auto

typedef 'a myopt = "{X :: 'a set. finite X \<and> card X \<le> 1}" by (rule exI[of _ "{}"]) auto
lemma myopt_type_def: "type_definition
  (\<lambda>X. if card (Rep_myopt X) = 1 then Some (the_elem (Rep_myopt X)) else None)
  (\<lambda>x. Abs_myopt (case x of Some x \<Rightarrow> {x} | _ \<Rightarrow> {}))
  (UNIV :: 'a option set)"
  apply unfold_locales
    apply (auto simp: Abs_myopt_inverse dest!: card_eq_SucD split: option.splits)
   apply (metis Rep_myopt_inverse)
  apply (metis One_nat_def Rep_myopt Rep_myopt_inverse Suc_le_mono card_0_eq le0 le_antisym mem_Collect_eq nat.exhaust)
  done

copy_bnf (no_warn_transfer) 'a myopt via myopt_type_def

typedef ('k, 'v) fmap = "{M :: ('k \<rightharpoonup> 'v). finite (dom M)}"
  by (rule exI[of _ Map.empty]) simp_all
setup_lifting type_definition_fmap

lift_bnf (dead 'k, 'v) fmap [wits: "Map.empty :: 'k \<Rightarrow> 'v option"]
  by auto

typedef ('a, 'b) tuple_dead = "UNIV :: ('a \<times> 'b) set" ..
typedef ('a, 'b) tuple_dead1 = "UNIV :: ('a \<times> 'b) set" ..
typedef ('a, 'b) tuple_dead2 = "UNIV :: ('a \<times> 'b) set" ..
typedef ('a, 'b, 'c) triple_dead = "UNIV :: ('a \<times> 'b \<times> 'c) set" ..
typedef ('a, 'b, 'c) triple_dead1 = "UNIV :: ('a \<times> 'b \<times> 'c) set" ..
typedef ('a, 'b, 'c) triple_dead2 = "UNIV :: ('a \<times> 'b \<times> 'c) set" ..
typedef ('a, 'b, 'c) triple_dead3 = "UNIV :: ('a \<times> 'b \<times> 'c) set" ..
typedef ('a, 'b, 'c) triple_dead12 = "UNIV :: ('a \<times> 'b \<times> 'c) set" ..
typedef ('a, 'b, 'c) triple_dead13 = "UNIV :: ('a \<times> 'b \<times> 'c) set" ..
typedef ('a, 'b, 'c) triple_dead23 = "UNIV :: ('a \<times> 'b \<times> 'c) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead =    "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead1 =   "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead2 =   "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead3 =   "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead4 =   "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead12 =  "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead13 =  "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead14 =  "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead23 =  "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead24 =  "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead34 =  "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead123 = "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead124 = "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead134 = "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
typedef ('a, 'b, 'c, 'd) quadruple_dead234 = "UNIV :: ('a \<times> 'b \<times> 'c \<times> 'd) set" ..
setup_lifting type_definition_tuple_dead
setup_lifting type_definition_tuple_dead1
setup_lifting type_definition_tuple_dead2
setup_lifting type_definition_triple_dead
setup_lifting type_definition_triple_dead1
setup_lifting type_definition_triple_dead2
setup_lifting type_definition_triple_dead3
setup_lifting type_definition_triple_dead12
setup_lifting type_definition_triple_dead13
setup_lifting type_definition_triple_dead23
setup_lifting type_definition_quadruple_dead
setup_lifting type_definition_quadruple_dead1
setup_lifting type_definition_quadruple_dead2
setup_lifting type_definition_quadruple_dead3
setup_lifting type_definition_quadruple_dead4
setup_lifting type_definition_quadruple_dead12
setup_lifting type_definition_quadruple_dead13
setup_lifting type_definition_quadruple_dead14
setup_lifting type_definition_quadruple_dead23
setup_lifting type_definition_quadruple_dead24
setup_lifting type_definition_quadruple_dead34
setup_lifting type_definition_quadruple_dead123
setup_lifting type_definition_quadruple_dead124
setup_lifting type_definition_quadruple_dead134
setup_lifting type_definition_quadruple_dead234

lift_bnf (no_warn_wits) (     'a,      'b) tuple_dead by auto
lift_bnf (no_warn_wits) (dead 'a,      'b) tuple_dead1 by auto
lift_bnf (no_warn_wits) (     'a, dead 'b) tuple_dead2 by auto
lift_bnf (no_warn_wits) (     'a,      'b,      'c) triple_dead by auto
lift_bnf (no_warn_wits) (dead 'a,      'b,      'c) triple_dead1 by auto
lift_bnf (no_warn_wits) (     'a, dead 'b,      'c) triple_dead2 by auto
lift_bnf (no_warn_wits) (     'a,      'b, dead 'c) triple_dead3 by auto
lift_bnf (no_warn_wits) (dead 'a, dead 'b,      'c) triple_dead12 by auto
lift_bnf (no_warn_wits) (dead 'a,      'b, dead 'c) triple_dead13 by auto
lift_bnf (no_warn_wits) (     'a, dead 'b, dead 'c) triple_dead23 by auto
lift_bnf (no_warn_wits) (     'a,      'b,      'c,      'd) quadruple_dead  by auto
lift_bnf (no_warn_wits) (dead 'a,      'b,      'c,      'd) quadruple_dead1 by auto
lift_bnf (no_warn_wits) (     'a, dead 'b,      'c,      'd) quadruple_dead2 by auto
lift_bnf (no_warn_wits) (     'a,      'b, dead 'c,      'd) quadruple_dead3 by auto
lift_bnf (no_warn_wits) (     'a,      'b,      'c, dead 'd) quadruple_dead4 by auto
lift_bnf (no_warn_wits) (dead 'a, dead 'b,      'c,      'd) quadruple_dead12  by auto
lift_bnf (no_warn_wits) (dead 'a,      'b, dead 'c,      'd) quadruple_dead13  by auto
lift_bnf (no_warn_wits) (dead 'a,      'b,      'c, dead 'd) quadruple_dead14  by auto
lift_bnf (no_warn_wits) (     'a, dead 'b, dead 'c,      'd) quadruple_dead23  by auto
lift_bnf (no_warn_wits) (     'a, dead 'b,      'c, dead 'd) quadruple_dead24  by auto
lift_bnf (no_warn_wits) (     'a,      'b, dead 'c, dead 'd) quadruple_dead34  by auto
lift_bnf (no_warn_wits) (dead 'a, dead 'b, dead 'c,      'd) quadruple_dead123 by auto
lift_bnf (no_warn_wits) (dead 'a, dead 'b,      'c, dead 'd) quadruple_dead124 by auto
lift_bnf (no_warn_wits) (dead 'a,      'b, dead 'c, dead 'd) quadruple_dead134 by auto
lift_bnf (no_warn_wits) (     'a, dead 'b, dead 'c, dead 'd) quadruple_dead234 by auto

subsection \<open>Lifting \textbf{quotient_type}s\<close>

quotient_type 'a cpy_list = "'a list" / "(=)"
  by (rule identity_equivp)

lift_bnf 'a cpy_list
  by (auto intro: list_all2_trans)

quotient_type ('a, 'b) funk = "('a \<Rightarrow> 'b)" / "\<lambda>f g. \<forall>a. f a = g a"
  unfolding equivp_def by metis

lemma funk_closure: "{(x, x'). \<forall>a. x a = x' a} `` {x. range x \<subseteq> A} = {x. range x \<subseteq> A}"
  by auto

lift_bnf (dead 'a, 'b) funk
  unfolding funk_closure rel_fun_def by (auto 0 10 split: if_splits)

lemma assumes "equivp REL"
  shows "REL OO REL OO R = REL OO R"
  using equivp_transp[OF assms] equivp_reflp[OF assms]
  by blast

inductive ignore_Inl :: "'a + 'a \<Rightarrow> 'a + 'a \<Rightarrow> bool" where
  "ignore_Inl (Inl x) (Inl y)"
| "ignore_Inl (Inr x) (Inr x)"

inductive_simps [simp]:
  "ignore_Inl (Inl x) y"
  "ignore_Inl (Inr x') y"
  "ignore_Inl y (Inl x)"
  "ignore_Inl y (Inr x')"

quotient_type 'a opt = "'a + 'a" / ignore_Inl
  apply(auto intro!: equivpI simp add: reflp_def symp_def transp_def elim!: ignore_Inl.cases)
  subgoal for x by(cases x) simp_all.

lemma ignore_Inl_map_respect:
  "(rel_fun (=) (rel_fun ignore_Inl ignore_Inl)) (\<lambda>f. map_sum f f) (\<lambda>f. map_sum f f)"
  by(auto simp add: rel_fun_def elim: ignore_Inl.cases)

lemma ignore_Inl_pos_distr:
  "A OO B \<noteq> bot \<Longrightarrow> ignore_Inl OO rel_sum A A OO ignore_Inl OO rel_sum B B OO ignore_Inl \<le>
   ignore_Inl OO rel_sum (A OO B) (A OO B) OO ignore_Inl"
  by(fastforce elim!: ignore_Inl.cases simp add: relcompp_apply fun_eq_iff intro: exI[where x="Inl _"])

lemma ignore_Inl_Inter:
  "\<lbrakk> S \<noteq> {}; \<Inter>S \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Inter>A\<in>S. {(x, y). ignore_Inl x y} `` {x. Basic_BNFs.setl x \<union> Basic_BNFs.setr x \<subseteq> A}) \<subseteq> {(x, y). ignore_Inl x y} `` (\<Inter>A\<in>S. {x. Basic_BNFs.setl x \<union> Basic_BNFs.setr x \<subseteq> A})"
  apply(clarsimp; safe; clarsimp)
  subgoal for x A x'
    apply(cases x)
     apply(drule bspec[where x="Inl x'"])
      apply clarsimp
     apply simp
    apply clarsimp
    apply(drule bspec[where x="Inr _"])
     apply simp
    apply simp
    done
  done

lift_bnf 'a opt [wits: "(Inl undefined :: 'a + 'a)"]
   apply(auto simp add: rel_fun_def elim: ignore_Inl.cases)[]
  apply(fastforce simp add: rel_sum.simps)
  subgoal for Ss
    using ignore_Inl_Inter[unfolded Plus_def, of Ss]
    by blast
  apply (auto simp: Ball_def image_iff sum_set_defs elim: ignore_Inl.cases split: sum.splits) []
  done

end


(*<*)
(*
 * The Maybe monad.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Maybe
imports HOLCF
begin
(*>*)

section{* The @{text "'a Maybe"} Monad *}

text{* This section defines the monadic machinery for the @{text "'a
Maybe"} type. @{term "return"} is @{term "Just"}. *}

domain 'a Maybe = Nothing | Just (lazy "'a")

definition
  mfail :: "'a Maybe"
where
  "mfail \<equiv> Nothing"

definition
  mcatch :: "'a Maybe \<rightarrow> 'a Maybe \<rightarrow> 'a Maybe"
where
  "mcatch \<equiv> \<Lambda> body handler. case body of Nothing \<Rightarrow> handler | Just\<cdot>x \<Rightarrow> Just\<cdot>x"

lemma mcatch_strict[simp]: "mcatch\<cdot>\<bottom> = \<bottom>"
  by (rule cfun_eqI, simp add: mcatch_def)

definition
  mbind :: "'a Maybe \<rightarrow> ('a \<rightarrow> 'b Maybe) \<rightarrow> 'b Maybe" where
  "mbind \<equiv> \<Lambda> f g. (case f of Nothing \<Rightarrow> Nothing | Just\<cdot>f' \<Rightarrow> g\<cdot>f')"

abbreviation
  mbind_syn :: "'a Maybe \<Rightarrow> ('a \<rightarrow> 'b Maybe) \<Rightarrow> 'b Maybe" (infixl ">>=\<^sub>M" 55) where
  "f >>=\<^sub>M g \<equiv> mbind\<cdot>f\<cdot>g"

lemma mbind_strict1[simp]: "\<bottom> >>=\<^sub>M g = \<bottom>" by (simp add: mbind_def)

text{* The standard monad laws. *}

lemma leftID[simp]: "Just\<cdot>a >>=\<^sub>M f = f\<cdot>a" by (simp add: mbind_def)
lemma rightID[simp]: "m >>=\<^sub>M Just = m" by (cases m, simp_all add: mbind_def)

lemma assoc[simp]: "(m >>=\<^sub>M f) >>=\<^sub>M g = m >>=\<^sub>M (\<Lambda> x. f\<cdot>x >>=\<^sub>M g)"
  by (cases m, simp_all add: mbind_def)

text{* Reduction for the Maybe monad. *}

lemma nothing_bind[simp]: "Nothing >>=\<^sub>M f = Nothing" by (simp add: mbind_def)
lemma just_bind[simp]: "Just\<cdot>x >>=\<^sub>M f = f\<cdot>x" by (simp add: mbind_def)

definition
  mliftM2 :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<Rightarrow> 'a Maybe \<rightarrow> 'b Maybe \<rightarrow> 'c Maybe" where
  "mliftM2 f \<equiv> \<Lambda> x y. x >>=\<^sub>M (\<Lambda> x'. y >>=\<^sub>M (\<Lambda> y'. Just\<cdot>(f\<cdot>x'\<cdot>y')))"

lemma mliftM2_Nothing1[simp]: "mliftM2 f\<cdot>Nothing\<cdot>y = Nothing" by (simp add: mliftM2_def)
lemma mliftM2_Nothing2[simp]: "mliftM2 f\<cdot>(Just\<cdot>x)\<cdot>Nothing = Nothing" by (simp add: mliftM2_def)
lemma mliftM2_op[simp]: "mliftM2 f\<cdot>(Just\<cdot>x)\<cdot>(Just\<cdot>y) = Just\<cdot>(f\<cdot>x\<cdot>y)" by (simp add: mliftM2_def)

lemma mliftM2_strict1[simp]: "mliftM2 f\<cdot>\<bottom> = \<bottom>" by (rule cfun_eqI)+ (simp add: mliftM2_def)
lemma mliftM2_strict2[simp]: "mliftM2 f\<cdot>(Just\<cdot>x)\<cdot>\<bottom> = \<bottom>" by (simp add: mliftM2_def)

end


theory OrdRec_Model_Base
  imports "../../ModelKit/ModelComponents"
          "../../GZF/Model/GZF_Model"
          "Ordinal_Model"
begin

(*Formula \<open>ex_ordrec\<close> needs to be defined in context of both GZF_Model and Ordinal_Model
  Need a better workaround.*)
class foo = GZF_Model + Ordinal_Model
begin
(*Constrains \<open>Excluded\<close> to allow sets of ordinals to be formed in model building process*)
ML \<open>val ex_ordrec = @{prop \<open>\<not> Excluded set <ord, j'>\<close>}\<close>
end

context ModelBase begin
ML \<open>val ordrec_model = mcomp
 { name = "OrdRec_Model",
   deps = mcomps [set_model, ord_model],
   variant = NONE,
  excludes_formulas =
    [("not_excluded_set_mord", ex_ordrec)]
 }\<close>
end

local_setup \<open>snd o mk_mcomp_class ordrec_model\<close>

context OrdRec_Model
begin

definition mpredSet' :: \<open>'a \<Rightarrow> 'a\<close>
  where "mpredSet' j \<equiv> <set, ord \<oplus> predSet (snd j)>"

definition mpredSet :: \<open>'a \<Rightarrow> 'a\<close>
  where "mpredSet j \<equiv> if j : mOrd then mpredSet' j
                                  else OrdRec_Model_mdefault"

definition msupOrd' :: \<open>'a \<Rightarrow> 'a\<close>
  where "msupOrd' x \<equiv> <ord, supOrd {snd b | b \<in> snd x}>"

definition msupOrd :: \<open>'a \<Rightarrow> 'a\<close>
  where "msupOrd x \<equiv> if x : mSetOf mOrd then msupOrd' x
                                        else OrdRec_Model_mdefault"

definition forceM_ordrec :: \<open>'a \<Rightarrow> 'a\<close>
  where "forceM_ordrec b \<equiv> if b : M then b else OrdRec_Model_mdefault"

lemma forceM_ordrec_m : "forceM_ordrec b : M"
  unfolding forceM_ordrec_def using OrdRec_Model_mdefault_m
  by auto

lemma forceM_ordrec_eq :
  assumes "b : M"
  shows "forceM_ordrec b = b"
  using assms unfolding forceM_ordrec_def
  by auto

definition forceM_ordrec_fun
  where "forceM_ordrec_fun f \<equiv> f "

definition mordrecG where
  "mordrecG G u' (f' :: 'a \<Rightarrow> 'a) \<equiv> forceM_ordrec (G (<ord, u'>)
    (\<lambda>j. if j \<lless> <ord,u'> then f' (snd j) else OrdRec_Model_mdefault))"

definition mordrecF where
  "mordrecF F j' b \<equiv> forceM_ordrec (F (<ord, j'>) b)"

definition mOrdRec'
  where "mOrdRec' G F A b \<equiv>
    OrdRec (mordrecG G) (mordrecF F) (forceM_ordrec A) (snd b)"

definition mOrdRec
  where "mOrdRec G F A j \<equiv> (if G : LimFun \<and> F : M \<rightarrow> M \<rightarrow> M \<and> A : M \<and> j : mOrd
                            then mOrdRec' G F A j
                            else OrdRec_Model_mdefault)"

end
end


theory Proof_4_338
  imports Proofs4
begin

abbreviation s where " s s0 PdOut'value paid'value opened'value \<equiv>
 (toEnv
   (setPstate
     (setVarBool
       (setPstate
         (setVarBool
           (setPstate
             (setVarBool
               (setVarBool
                 (setVarBool (setVarBool (setVarBool s0 PdOut' PdOut'value) paid' paid'value) opened'
                   opened'value)
                 Controller'minimalOpened' True)
               EntranceController'isOpened' False)
             Init'init' Controller'minimalOpened')
           EntranceController'isClosed' True)
         Controller'isClosed' EntranceController'isOpened')
       Controller'isOpened' False)
     Controller'minimalOpened' STOP))"

theorem proof_4_338: "VC338 inv4 env s0 PdOut_value paid_value opened_value"
  apply(simp only: VC338_def inv4_def R4_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
   apply(drule conjE)
    prefer 2
    apply assumption
   apply(drule conjE)
    prefer 2
    apply assumption
   apply((rule allI)+)
  subgoal premises vc_prems for s1 s2
    using vc_prems(2) apply -
    apply(drule conjE)
     prefer 2
     apply assumption
    subgoal premises invs0
      apply(rule impI)
      apply(rule disjE[of "100 < toEnvNum s2 (s s0 PdOut_value paid_value opened_value)"
"100 = toEnvNum s2 (s s0 PdOut_value paid_value opened_value)"])
      using le_imp_less_or_eq apply blast
      apply(rule cut_rl[of "\<exists>s4. toEnvP s4 \<and>
         substate s2 s4 \<and>
         substate s4 s0 \<and>
         toEnvNum s2 s4 \<le> 100 \<and>
         \<not> getVarBool s4 Controller'minimalOpened' \<and>
         (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow> getVarBool s3 Controller'minimalOpened')"])
        apply(drule exE)
         prefer 2
         apply assumption
      subgoal for s4
        apply(rule exI[of _ s4])
        by simp
      subgoal premises req_prems
        using invs0(1) req_prems apply -
        apply(drule conjE)
         prefer 2
         apply assumption
        apply(drule allE[of _ s1])
        prefer 2
         apply assumption
        apply(drule allE[of _ s2])
        prefer 2
         apply assumption
        by(simp split: if_splits)
      apply(rule cut_rl[of "\<forall> s5. toEnvP s5 \<and> substate s2 s5 \<and> substate s5 (s s0 PdOut_value paid_value opened_value) \<longrightarrow>
pred4 s1 s2 (s s0 PdOut_value paid_value opened_value) s5"])
       apply(drule allE[of _ s2])
      prefer 2
        apply assumption
       apply(drule impE)
      prefer 3
      apply assumption
      using substate_refl apply blast
       apply(simp only: pred4_def)
       apply(drule impE)
      prefer 3
      apply assumption
      using substate_refl substate_trans substate_antisym apply blast
       apply assumption
      apply(rule allI)
      subgoal premises prems for s5
        apply(induction rule: state_ind)
        using prems(1) apply simp
         apply(simp only: pred4_def)
         apply(rule impI)

        subgoal
          apply((drule conjE[of _ _ ?thesis])+)
                   defer
                   apply assumption+
          apply(drule allE[of _ s0])
           prefer 2
           apply assumption
          apply(drule impE)
            prefer 3
            apply assumption
          using invs0(1) substate_refl apply(simp split: if_splits)
          using vc_prems(1) apply(simp split: if_splits)
          using invs0(2) substate_refl
          by meson

        subgoal for s5
          apply(simp only: pred4_def)
          apply(rule impI)
          apply(cases "getVarBool (predEnv s5) open' = False")
           apply(rule exI[of _ "predEnv s5"])
           apply(rule conjI)
        apply(rule toEnvP_substate_pred_imp_toEnvP_pred[of s2])
            apply blast
       apply(rule conjI)
          using substate_refl apply simp
       apply(rule conjI)
      using predEnv_substate substate_trans apply blast
       apply(rule conjI)
      using toEnvNum3[of s2 "predEnv s5"
 "(s s0 PdOut_value paid_value opened_value) "]
        apply force
       apply(rule conjI)
        apply blast
      using substate_antisym apply blast
      apply(drule impE)
        prefer 3
        apply assumption
       apply(((rule conjI),blast)+)
      using substate_imp_substatete_predEnv_or_eq apply blast
      apply(drule exE)
       prefer 2
       apply assumption
      subgoal for s4
        apply(rule exI[of _ s4])
       apply(rule conjI)
         apply blast
        apply(rule conjI)
        using predEnv_substate substate_trans apply blast
        apply(((rule conjI),blast)+)
        using predEnv_substate_imp_substate_or_eq by blast
      done
    done
  done
  done