theory Permutations_2
imports
  "HOL-Combinatorics.Permutations"
  Graph_Theory.Auxiliary
  Executable_Permutations
begin

section \<open>More\<close>

abbreviation funswapid :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<rightleftharpoons>\<^sub>F" 90) where
  "x \<rightleftharpoons>\<^sub>F y \<equiv> transpose x y"

lemma in_funswapid_image_iff: "x \<in> (a \<rightleftharpoons>\<^sub>F b) ` S \<longleftrightarrow> (a \<rightleftharpoons>\<^sub>F b) x \<in> S"
  by (fact in_transpose_image_iff)

lemma bij_swap_compose: "bij (x \<rightleftharpoons>\<^sub>F y \<circ> f) \<longleftrightarrow> bij f"
  by (metis UNIV_I bij_betw_comp_iff2 bij_betw_id bij_swap_iff subsetI)

lemma bij_eq_iff:
  assumes "bij f" shows "f x = f y \<longleftrightarrow> x = y"
  using assms by (auto simp add: bij_iff)

lemma swap_swap_id[simp]: "(x \<rightleftharpoons>\<^sub>F y) ((x \<rightleftharpoons>\<^sub>F y) z) = z"
  by (fact transpose_involutory)

section \<open>Modifying Permutations\<close>

definition perm_swap :: "'a \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "perm_swap x y f \<equiv> x \<rightleftharpoons>\<^sub>F y o f o x \<rightleftharpoons>\<^sub>F y"

definition perm_rem :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "perm_rem x f \<equiv> if f x \<noteq> x then x \<rightleftharpoons>\<^sub>F f x o f else f"

text \<open>
  An example:

  @{lemma "perm_rem (2 :: nat) (list_succ [1,2,3,4]) x = list_succ [1,3,4] x"
      by (auto simp: perm_rem_def Fun.swap_def list_succ_def)}
\<close>
lemma perm_swap_id[simp]: "perm_swap a b id = id"
  by (auto simp: perm_swap_def)

lemma perm_rem_permutes:
  assumes "f permutes S \<union> {x}"
  shows "perm_rem x f permutes S"
  using assms by (auto simp: permutes_def perm_rem_def) (metis transpose_def)+

lemma perm_rem_same:
  assumes "bij f" "f y = y" shows "perm_rem x f y = f y"
  using assms by (auto simp: perm_rem_def bij_iff transpose_def)

lemma perm_rem_simps:
  assumes "bij f"
  shows
  "x = y \<Longrightarrow> perm_rem x f y = x"
  "f y = x \<Longrightarrow> perm_rem x f y = f x"
  "y \<noteq> x \<Longrightarrow> f y \<noteq> x \<Longrightarrow> perm_rem x f y = f y"
  using assms by (auto simp: perm_rem_def transpose_def bij_iff)

lemma bij_perm_rem[simp]: "bij (perm_rem x f) \<longleftrightarrow> bij f"
  by (simp add: perm_rem_def bij_swap_compose)

lemma perm_rem_conv: "\<And>f x y. bij f \<Longrightarrow> perm_rem x f y = (
    if x = y then x
    else if f y = x then f (f y)
    else f y)"
  by (auto simp: perm_rem_simps)

lemma perm_rem_commutes:
  assumes "bij f" shows "perm_rem a (perm_rem b f) = perm_rem b (perm_rem a f)"
proof -
  have bij_simp: "\<And>x y. f x = f y \<longleftrightarrow> x = y"
    using assms by (auto simp: bij_iff)
  show ?thesis using assms by (auto simp: perm_rem_conv bij_simp fun_eq_iff)
qed

lemma perm_rem_id[simp]: "perm_rem a id = id"
  by (simp add: perm_rem_def)

lemma perm_swap_comp: "perm_swap a b (f \<circ> g) x = perm_swap a b f (perm_swap a b g x)"
  by (auto simp: perm_swap_def)

lemma bij_perm_swap_iff[simp]: "bij (perm_swap a b f) \<longleftrightarrow> bij f"
  by (simp add: bij_swap_compose bij_swap_iff perm_swap_def)

lemma funpow_perm_swap: "perm_swap a b f ^^ n = perm_swap a b (f ^^ n)"
  by (induct n) (auto simp: perm_swap_def fun_eq_iff)

lemma orbit_perm_swap: "orbit (perm_swap a b f) x = (a \<rightleftharpoons>\<^sub>F b) ` orbit f ((a \<rightleftharpoons>\<^sub>F b) x)"
  by (auto simp: orbit_altdef funpow_perm_swap) (auto simp: perm_swap_def)

lemma has_dom_perm_swap: "has_dom (perm_swap a b f) S = has_dom f ((a \<rightleftharpoons>\<^sub>F b) ` S)"
  by (auto simp: has_dom_def perm_swap_def inj_image_mem_iff) (metis image_iff swap_swap_id)

lemma perm_restrict_dom_subset:
  assumes "has_dom f A" shows "perm_restrict f A = f"
proof -
  from assms have "\<And>x. x \<notin> A \<Longrightarrow> f x = x" by (auto simp: has_dom_def)
  then show ?thesis by (auto simp: perm_restrict_def fun_eq_iff)
qed

lemma perm_swap_permutes2:
  assumes "f permutes ((x \<rightleftharpoons>\<^sub>F y) ` S)"
  shows "perm_swap x y f permutes S"
  using assms
  by (auto simp: perm_swap_def permutes_conv_has_dom has_dom_perm_swap [unfolded perm_swap_def] intro!: bij_comp)

section \<open>Cyclic Permutations\<close>

lemma cyclic_on_perm_swap:
  assumes "cyclic_on f S" shows "cyclic_on (perm_swap x y f) ((x \<rightleftharpoons>\<^sub>F y) ` S)"
  using assms by (rule cyclic_on_image) (auto simp: perm_swap_def)

lemma orbit_perm_rem:
  assumes "bij f" "x \<noteq> y" shows "orbit (perm_rem y f) x = orbit f x - {y}" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix z assume "z \<in> ?L"
  then show "z \<in> ?R"
    using assms by induct (auto simp: perm_rem_conv bij_iff intro: orbit.intros)
next
  fix z assume A: "z \<in> ?R"

  { assume "z \<in> orbit f x"
    then have "(z \<noteq> y \<longrightarrow> z \<in> ?L) \<and> (z = y \<longrightarrow> f z \<in> ?L)"
    proof induct
      case base with assms show ?case by (auto intro: orbit_eqI(1) simp: perm_rem_conv)
    next
      case (step z) then show ?case
        using assms by (cases "y = z") (auto intro: orbit_eqI simp: perm_rem_conv)
    qed
  } with A show "z \<in> ?L" by auto
qed

lemma orbit_perm_rem_eq:
  assumes "bij f" shows "orbit (perm_rem y f) x = (if x = y then {y} else orbit f x - {y})"
  using assms by (simp add: orbit_eq_singleton_iff orbit_perm_rem perm_rem_simps)

lemma cyclic_on_perm_rem:
  assumes "cyclic_on f S" "bij f" "S \<noteq> {x}" shows "cyclic_on (perm_rem x f) (S - {x})"
  using assms[unfolded cyclic_on_alldef] by (simp add: cyclic_on_def orbit_perm_rem_eq) auto

end


(*  Title:       Proving the Correctness of Disk Paxos

    Author:      Mauro J. Jaskelioff, Stephan Merz, 2005
    Maintainer:  Mauro J. Jaskelioff <mauro at fceia.unr.edu.ar>
*)

theory DiskPaxos_Inv4 imports DiskPaxos_Inv2  begin

subsection \<open>Invariant 4\<close>

text \<open>
  This invariant expresses relations among $mbal$ and $bal$ values of a
  processor and of its disk blocks.
  $HInv4a$ asserts that, when $p$ is not recovering from a failure, its
  $mbal$ value is at least as large as the $bal$ field of any of its blocks,
  and at least as large as the $mbal$ field of its block on some disk in
  any majority set.
  $HInv4b$ conjunct asserts that, in phase 1, its $mbal$ value is actually
  greater than the $bal$ field of any of its blocks.
  $HInv4c$ asserts that, in phase 2, its $bal$ value is the $mbal$ field
  of all its blocks on some majority set of disks.
  $HInv4d$ asserts that the $bal$ field of any of its blocks is at most as
  large as the $mbal$ field of all its disk blocks on some majority set of disks.
\<close>

definition MajoritySet :: "Disk set set"
  where "MajoritySet = {D. IsMajority(D) }"

definition HInv4a1 :: "state \<Rightarrow> Proc \<Rightarrow> bool"
  where "HInv4a1 s p = (\<forall>bk \<in> blocksOf s p. bal bk  \<le> mbal (dblock s p))"

definition HInv4a2 :: "state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "HInv4a2 s p = (\<forall>D \<in> MajoritySet.(\<exists>d \<in> D.  mbal(disk s d p) \<le> mbal(dblock s p)
                                           \<and> bal(disk s d p) \<le> bal(dblock s p)))"

definition HInv4a :: "state \<Rightarrow> Proc \<Rightarrow> bool"
  where "HInv4a s p = (phase s p \<noteq> 0 \<longrightarrow> HInv4a1 s p \<and> HInv4a2 s p)"

definition HInv4b :: "state \<Rightarrow> Proc \<Rightarrow> bool"
  where "HInv4b s p = (phase s p = 1 \<longrightarrow> (\<forall>bk \<in> blocksOf s p. bal bk < mbal(dblock s p)))"

definition HInv4c :: "state \<Rightarrow> Proc \<Rightarrow> bool"
  where "HInv4c s p = (phase s p \<in> {2,3} \<longrightarrow> (\<exists>D\<in>MajoritySet. \<forall>d\<in>D. mbal(disk s d p) = bal (dblock s p)))"

definition HInv4d :: "state \<Rightarrow> Proc \<Rightarrow> bool"
  where "HInv4d s p = (\<forall>bk \<in> blocksOf s p. \<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s d p))"

definition HInv4 :: "state \<Rightarrow> bool"
  where "HInv4 s = (\<forall>p. HInv4a s p \<and> HInv4b s p \<and> HInv4c s p \<and> HInv4d s p)"

text \<open>The initial state implies Invariant 4.\<close>

theorem HInit_HInv4: "HInit s \<Longrightarrow> HInv4 s"
  using Disk_isMajority
  by(auto simp add: HInit_def Init_def HInv4_def HInv4a_def HInv4a1_def
                    HInv4a2_def HInv4b_def HInv4c_def HInv4d_def
                    MajoritySet_def blocksOf_def InitDB_def rdBy_def)

text \<open>To prove that the actions preserve $HInv4$,
        we do it for one conjunct at a time.

  For each action $action s s' q$ and conjunct $x\in{a,b,c,d}$ of $HInv4x s' p$,
  we prove two lemmas.
The first lemma $action$-$HInv4x$-$p$ proves the case of $p=q$, while
lemma $action$-$HInv4x$-$q$ proves the other case.
\<close>

subsubsection \<open>Proofs of Invariant 4a\<close>

lemma HStartBallot_HInv4a1:
  assumes act: "HStartBallot s s' p"
  and inv: "HInv4a1 s p"
  and inv2a: "Inv2a_inner s' p"
  shows "HInv4a1 s' p"
proof(auto simp add: HInv4a1_def)
  fix bk
  assume "bk \<in> blocksOf s' p"
  with HStartBallot_blocksOf[OF act]
  have "bk \<in> {dblock s' p} \<union> blocksOf s p"
    by blast
  thus "bal bk \<le> mbal (dblock s' p)"
  proof
    assume "bk \<in> {dblock s' p}"
    with inv2a
    show ?thesis
      by(auto simp add: Inv2a_innermost_def Inv2a_inner_def blocksOf_def)
  next
    assume "bk \<in> blocksOf s p"
    with inv act
    show ?thesis
      by(auto simp add: StartBallot_def HInv4a1_def)
  qed
qed

lemma HStartBallot_HInv4a2:
  assumes act: "HStartBallot s s' p"
  and inv: "HInv4a2 s p"
  shows "HInv4a2 s' p"
proof(auto simp add: HInv4a2_def)
  fix D
  assume Dmaj: "D \<in> MajoritySet"
  from inv Dmaj
  have "\<exists>d\<in>D.   mbal (disk s d p) \<le> mbal (dblock s p)
              \<and> bal (disk s d p) \<le> bal (dblock s p)"
    by(auto simp add: HInv4a2_def)
  then obtain d
    where "  d\<in>D
           \<and> mbal (disk s d p) \<le> mbal (dblock s p)
           \<and> bal (disk s d p) \<le> bal (dblock s p)"
    by auto
  with act
  have "  d\<in>D
        \<and> mbal (disk s' d p) \<le> mbal (dblock s' p)
        \<and> bal (disk s' d p) \<le> bal (dblock s' p)"
    by(auto simp add: StartBallot_def)
  with Dmaj
  show "\<exists>d\<in>D.   mbal (disk s' d p) \<le> mbal (dblock s' p)
              \<and> bal (disk s' d p) \<le> bal (dblock s' p)"
    by auto
qed

lemma HStartBallot_HInv4a_p:
  assumes act: "HStartBallot s s' p"
  and inv: "HInv4a s p"
  and inv2a: "Inv2a_inner s' p"
  shows "HInv4a s' p"
using act inv inv2a
proof -
  from act
  have phase: "0 < phase s p"
    by(auto simp add: StartBallot_def)
  from act inv inv2a
  show ?thesis
    by(auto simp del: HStartBallot_def simp  add: HInv4a_def phase
               elim: HStartBallot_HInv4a1 HStartBallot_HInv4a2)
qed

lemma HStartBallot_HInv4a_q:
  assumes act: "HStartBallot s s' p"
  and inv: "HInv4a s q"
  and pnq: "p\<noteq>q"
  shows "HInv4a s' q"
proof -
  from act pnq
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: StartBallot_def InitializePhase_def
                      blocksOf_def rdBy_def)
  with act inv pnq
  show ?thesis
    by(auto simp add: StartBallot_def HInv4a_def
                      HInv4a1_def HInv4a2_def)
qed

theorem HStartBallot_HInv4a:
  assumes act: "HStartBallot s s' p"
  and  inv: "HInv4a s q"
  and inv2a: "Inv2a s'"
  shows "HInv4a s' q"
proof(cases "p=q")
  case True
  from inv2a
  have "Inv2a_inner s' p"
    by(auto simp add: Inv2a_def)
  with act inv True
  show ?thesis
    by(blast dest: HStartBallot_HInv4a_p)
next
  case False
  with act inv
  show ?thesis
    by(blast dest: HStartBallot_HInv4a_q)
qed

lemma Phase1or2Write_HInv4a1:
  "\<lbrakk> Phase1or2Write s s' p d; HInv4a1 s q \<rbrakk> \<Longrightarrow> HInv4a1 s' q"
  by(auto simp add: Phase1or2Write_def HInv4a1_def
                    blocksOf_def rdBy_def)

lemma Phase1or2Write_HInv4a2:
  "\<lbrakk> Phase1or2Write s s' p d; HInv4a2 s q \<rbrakk> \<Longrightarrow> HInv4a2 s' q"
  by(auto simp add: Phase1or2Write_def HInv4a2_def)

theorem HPhase1or2Write_HInv4a:
  assumes act: "HPhase1or2Write s s' p d"
  and inv: "HInv4a s q"
  shows "HInv4a s' q"
proof -
  from act
  have phase': "phase s = phase s'"
    by(simp add: Phase1or2Write_def)
  show ?thesis
  proof(cases "phase s q = 0")
  case True
  with phase' act
  show ?thesis
    by(auto simp add: HInv4a_def)
next
  case False
  with phase' act inv
  show ?thesis
    by(auto simp add: HInv4a_def
                dest: Phase1or2Write_HInv4a1 Phase1or2Write_HInv4a2)
  qed
qed

lemma HPhase1or2ReadThen_HInv4a2:
  "\<lbrakk> HPhase1or2ReadThen s s' p d r; HInv4a2 s q \<rbrakk> \<Longrightarrow> HInv4a2 s' q"
  by(auto simp add: Phase1or2ReadThen_def HInv4a2_def)

lemma HPhase1or2ReadThen_HInv4a_p:
  assumes act: "HPhase1or2ReadThen s s' p d r"
  and inv: "HInv4a s p"
  and inv2b: "Inv2b s"
  shows "HInv4a s' p"
proof -
  from act inv2b
  have "phase s p \<in> {1,2}"
    by(auto simp add: Phase1or2ReadThen_def Inv2b_def Inv2b_inner_def)
  with act inv
  show ?thesis
    by(auto simp del: HPhase1or2ReadThen_def simp add: HInv4a_def
          elim: HPhase1or2ReadThen_HInv4a1_p HPhase1or2ReadThen_HInv4a2)
qed

lemma HPhase1or2ReadThen_HInv4a_q:
  assumes act: "HPhase1or2ReadThen s s' p d r"
  and inv: "HInv4a s q"
  and pnq: "p\<noteq>q"
  shows "HInv4a s' q"
proof -
  from act pnq
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: Phase1or2ReadThen_def InitializePhase_def
                      blocksOf_def rdBy_def)
  with act inv pnq
  show ?thesis
    by(auto simp add: Phase1or2ReadThen_def HInv4a_def
                      HInv4a1_def HInv4a2_def)
qed

theorem HPhase1or2ReadThen_HInv4a:
  "\<lbrakk> HPhase1or2ReadThen s s' p d r; HInv4a s q; Inv2b s \<rbrakk> \<Longrightarrow> HInv4a s' q"
  by(blast dest: HPhase1or2ReadThen_HInv4a_p HPhase1or2ReadThen_HInv4a_q)

theorem HPhase1or2ReadElse_HInv4a:
  assumes act: "HPhase1or2ReadElse s s' p d r"
  and inv: "HInv4a s q" and inv2a: "Inv2a s'"
  shows "HInv4a s' q"
proof -
  from act  have "HStartBallot s s' p"
    by(simp add: Phase1or2ReadElse_def)
  with inv inv2a show ?thesis
    by(blast dest: dest: HStartBallot_HInv4a )
qed

lemma HEndPhase1_HInv4a1:
  assumes act: "HEndPhase1 s s' p"
  and inv: "HInv4a1 s p"
  shows "HInv4a1 s' p"
proof(auto simp add: HInv4a1_def)
  fix bk
  assume bk: "bk \<in> blocksOf s' p"
  from bk HEndPhase1_blocksOf[OF act]
  have "bk \<in> {dblock s' p} \<union> blocksOf s p"
    by blast
  with act inv
  show "bal bk \<le> mbal (dblock s' p)"
    by(auto simp add: HInv4a_def HInv4a1_def EndPhase1_def)
qed

lemma HEndPhase1_HInv4a2:
  assumes act: "HEndPhase1 s s' p"
  and inv: "HInv4a2 s p"
  and inv2a: "Inv2a s"
  shows "HInv4a2 s' p"
proof(auto simp add: HInv4a2_def)
  fix D
  assume Dmaj: "D \<in> MajoritySet"
  from inv Dmaj
  have "\<exists>d\<in>D.   mbal (disk s d p) \<le> mbal (dblock s p)
              \<and> bal (disk s d p) \<le> bal (dblock s p)"
    by(auto simp add: HInv4a2_def)
  then obtain d
    where d_cond: "  d\<in>D
                   \<and> mbal (disk s d p) \<le> mbal (dblock s p)
                   \<and> bal (disk s d p) \<le> bal (dblock s p)"
    by auto
  have "disk s d p \<in> blocksOf s p"
    by(auto simp add: blocksOf_def)
  with inv2a
  have "bal(disk s d p) \<le> mbal (disk s d p)"
    by(auto simp add: Inv2a_def Inv2a_inner_def Inv2a_innermost_def)
  with act d_cond
  have "  d\<in>D
        \<and> mbal (disk s' d p) \<le> mbal (dblock s' p)
        \<and> bal (disk s' d p) \<le> bal (dblock s' p)"
    by(auto simp add: EndPhase1_def)
  with Dmaj
  show "\<exists>d\<in>D.   mbal (disk s' d p) \<le> mbal (dblock s' p)
              \<and> bal (disk s' d p) \<le> bal (dblock s' p)"
    by auto
qed

lemma HEndPhase1_HInv4a_p:
  assumes act: "HEndPhase1 s s' p"
  and inv: "HInv4a s p"
  and inv2a: "Inv2a s"
  shows "HInv4a s' p"
proof -
  from act
  have phase: "0 < phase s p"
    by(auto simp add: EndPhase1_def)
  with act inv inv2a
  show ?thesis
    by(auto simp del: HEndPhase1_def simp  add: HInv4a_def
               elim: HEndPhase1_HInv4a1 HEndPhase1_HInv4a2)
qed

lemma HEndPhase1_HInv4a_q:
  assumes act: "HEndPhase1 s s' p"
  and inv: "HInv4a s q"
  and pnq: "p\<noteq>q"
  shows "HInv4a s' q"
proof -
  from act pnq
  have "dblock s' q = dblock s q \<and> disk s' = disk s"
    by(auto simp add: EndPhase1_def)
  moreover
  from act pnq
  have "\<forall>p d. rdBy s' q p d \<subseteq> rdBy s q p d"
    by(auto simp add: EndPhase1_def InitializePhase_def rdBy_def)
  hence "(UN p d. rdBy s' q p d) \<subseteq> (UN p d. rdBy s q p d)"
    by(auto, blast)
  ultimately
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: blocksOf_def, blast)
  with act inv pnq
  show ?thesis
    by(auto simp add: EndPhase1_def HInv4a_def HInv4a1_def HInv4a2_def)
qed

theorem HEndPhase1_HInv4a:
  "\<lbrakk> HEndPhase1 s s' p; HInv4a s q;  Inv2a s \<rbrakk> \<Longrightarrow> HInv4a s' q"
  by(blast dest: HEndPhase1_HInv4a_p HEndPhase1_HInv4a_q)

theorem HFail_HInv4a:
  "\<lbrakk> HFail s s' p; HInv4a s q \<rbrakk> \<Longrightarrow> HInv4a s' q"
  by(auto simp add: Fail_def HInv4a_def HInv4a1_def
                    HInv4a2_def InitializePhase_def
                    blocksOf_def rdBy_def)

theorem HPhase0Read_HInv4a:
  "\<lbrakk> HPhase0Read s s' p d; HInv4a s q \<rbrakk> \<Longrightarrow> HInv4a s' q"
  by(auto simp add: Phase0Read_def HInv4a_def HInv4a1_def
                    HInv4a2_def InitializePhase_def
                    blocksOf_def rdBy_def)

theorem HEndPhase2_HInv4a:
  "\<lbrakk> HEndPhase2 s s' p; HInv4a s q \<rbrakk> \<Longrightarrow> HInv4a s' q"
  by(auto simp add: EndPhase2_def HInv4a_def HInv4a1_def HInv4a2_def
                    InitializePhase_def blocksOf_def rdBy_def)

lemma allSet:
  assumes aPQ: "\<forall>a. \<forall>r \<in> P a. Q r" and  rb: "rb \<in> P d"
  shows "Q rb"
proof -
  from aPQ have "\<forall>r \<in> P d. Q r" by auto
  with rb
  show ?thesis by auto
qed

lemma EndPhase0_44:
  assumes act: "EndPhase0 s s' p"
  and bk: "bk \<in> blocksOf s p"
  and inv4d: "HInv4d s p"
  and inv2c: "Inv2c_inner s p"
  shows "\<exists>d. \<exists>rb \<in> blocksRead s p d. bal bk \<le> mbal(block rb)"
proof -
  from bk inv4d
  have "\<exists>D1 \<in> MajoritySet.\<forall>d \<in> D1. bal bk \<le> mbal(disk s d p)"  \<comment> \<open>4.2\<close>
    by(auto simp add: HInv4d_def)
  with majorities_intersect
  have p43: "\<forall>D\<in>MajoritySet. \<exists>d\<in>D. bal bk \<le> mbal(disk s d p)"
    by(simp add: MajoritySet_def, blast)
  from act
  have "phase s p = 0" by(simp add: EndPhase0_def)
  with inv2c
  have "\<forall>d. \<forall>rb \<in> blocksRead s p d. block rb = disk s d p" \<comment> \<open>5.1\<close>
    by(simp add: Inv2c_inner_def)
  hence "\<forall>d. hasRead s p d p
              \<longrightarrow> (\<exists>rb\<in>blocksRead s p d. block rb = disk s d p)" \<comment> \<open>5.2\<close>
    (is "\<forall>d. ?H d \<longrightarrow> ?P d")
    by(auto simp add: hasRead_def)
  with act
  have p53: "\<exists>D \<in> MajoritySet. \<forall>d\<in>D. ?P d"
    by(auto simp add: MajoritySet_def EndPhase0_def)
  show ?thesis
  proof -
    from p43 p53
    have "\<exists>D\<in> MajoritySet.   (\<exists>d\<in>D. bal bk \<le> mbal(disk s d p))
                           \<and> (\<forall>d\<in>D. ?P d)"
      by auto
    thus ?thesis
      by force
  qed
qed

lemma HEndPhase0_HInv4a1_p:
  assumes act: "HEndPhase0 s s' p"
  and   inv2a': "Inv2a s'"
  and   inv2c: "Inv2c_inner s p"
  and   inv4d: "HInv4d s p"
  shows "HInv4a1 s' p"
proof(auto simp add: HInv4a1_def)
  fix bk
  assume "bk \<in> blocksOf s' p"
  with HEndPhase0_blocksOf[OF act]
  have "bk \<in> {dblock s' p} \<union> blocksOf s p" by auto
  thus "bal bk \<le> mbal (dblock s' p)"
  proof
    assume bk: "bk \<in> {dblock s' p}"
    with inv2a'
    have "Inv2a_innermost s' p bk"
      by(auto simp add: Inv2a_def Inv2a_inner_def blocksOf_def)
    with bk show ?thesis
      by(auto simp add: Inv2a_innermost_def)
  next
    assume bk: "bk \<in> blocksOf s p"
    from act
    have f1: "\<forall>r \<in> allBlocksRead s p. mbal r < mbal (dblock s' p)"
      by(auto simp add: EndPhase0_def)
    with act inv4d inv2c bk
    have "\<exists>d. \<exists>rb \<in> blocksRead s p d. bal bk \<le> mbal(block rb)"
      by(auto dest: EndPhase0_44)
    with f1
    show ?thesis
      by(auto simp add: EndPhase0_def allBlocksRead_def
                        allRdBlks_def dest: allSet)
  qed
qed

lemma hasRead_allBlks:
  assumes inv2c: "Inv2c_inner s p"
  and     phase: "phase s p = 0"
  shows "(\<forall>d\<in>{d. hasRead s p d p}. disk s d p \<in> allBlocksRead s p)"
proof
  fix d
  assume d: "d\<in>{d. hasRead s p d p}" (is "d\<in> ?D")
  hence br_ne: "blocksRead s p d\<noteq>{}"
    by (auto simp add: hasRead_def)
  from inv2c phase
  have "\<forall>br \<in> blocksRead s p d. block br = disk s d p"
    by(auto simp add: Inv2c_inner_def)
  with br_ne
  have "disk s d p \<in> block ` blocksRead s p d"
    by force
  thus "disk s d p \<in> allBlocksRead s p"
    by(auto simp add: allBlocksRead_def allRdBlks_def)
qed

lemma HEndPhase0_41:
  assumes act: "HEndPhase0 s s' p"
  and    inv1:  "Inv1 s"
  and   inv2c: "Inv2c_inner s p"
  shows "\<exists>D\<in>MajoritySet. \<forall>d\<in>D.   mbal(disk s d p) \<le> mbal(dblock s' p)
                               \<and> bal(disk s d p) \<le> bal(dblock s' p)"
proof -
  from act HEndPhase0_some[OF act inv1]
  have p51: "\<forall>br\<in>allBlocksRead s p.   mbal br < mbal(dblock s' p)
                                    \<and> bal br \<le> bal(dblock s' p)"
    and a: "IsMajority({d. hasRead s p d p})"
    and phase: "phase s p = 0"
    by(auto simp add: EndPhase0_def)+
  from inv2c phase
  have "(\<forall>d\<in>{d. hasRead s p d p}. disk s d p \<in> allBlocksRead s p)"
    by(auto dest: hasRead_allBlks)
  with p51
  have "(\<forall>d\<in>{d. hasRead s p d p}.   mbal(disk s d p) \<le> mbal(dblock s' p)
                                  \<and> bal(disk s d p) \<le> bal(dblock s' p))"
    by force
  with a show ?thesis
    by(auto simp add: MajoritySet_def)
qed

lemma Majority_exQ:
  assumes asm1: "\<exists>D \<in> MajoritySet. \<forall>d\<in>D. P d"
  shows "\<forall>D\<in>MajoritySet.\<exists>d\<in>D. P d"
using asm1
proof(auto simp add: MajoritySet_def)
  fix D1 D2
  assume D1: "IsMajority D1" and D2: "IsMajority D2"
     and Px: "\<forall>x\<in>D1. P x"
  from D1 D2 majorities_intersect
  have "\<exists>d\<in>D1. d\<in>D2" by auto
  with Px
  show "\<exists>x\<in>D2. P x"
    by auto
qed

lemma HEndPhase0_HInv4a2_p:
  assumes act: "HEndPhase0 s s' p"
  and    inv1:  "Inv1 s"
  and   inv2c: "Inv2c_inner s p"
  shows "HInv4a2 s' p"
proof(simp add: HInv4a2_def)
  from act
  have disk': "disk s' = disk s"
    by(simp add: EndPhase0_def)
  from act inv1 inv2c
  have "\<exists>D\<in>MajoritySet. \<forall>d\<in>D.   mbal(disk s d p) \<le> mbal(dblock s' p)
                              \<and> bal(disk s d p) \<le> bal(dblock s' p)"
    by(blast dest: HEndPhase0_41)
  from Majority_exQ[OF this]
  have  "\<forall>D\<in>MajoritySet. \<exists>d\<in>D.   mbal(disk s d p) \<le> mbal(dblock s' p)
                               \<and> bal(disk s d p) \<le> bal(dblock s' p)"
    (is "?P (disk s)") .
  from ssubst[OF disk', of ?P, OF this]
  show "\<forall>D\<in>MajoritySet. \<exists>d\<in>D.  mbal (disk s' d p) \<le> mbal (dblock s' p)
                              \<and> bal (disk s' d p) \<le> bal (dblock s' p)" .
qed

lemma HEndPhase0_HInv4a_p:
  assumes act: "HEndPhase0 s s' p"
  and   inv2a: "Inv2a s"
  and   inv2: "Inv2c s"
  and   inv4d: "HInv4d s p"
  and   inv1: "Inv1 s"
  and inv: "HInv4a s p"
  shows "HInv4a s' p"
proof -
  from inv2
  have inv2c: "Inv2c_inner s p"
    by(auto simp add: Inv2c_def)
  with inv1 inv2a act
  have inv2a': "Inv2a s'"
    by(blast dest: HEndPhase0_Inv2a)
  from act
  have "phase s' p = 1"
    by(auto simp add: EndPhase0_def)
  with act inv inv2c inv4d inv2a' inv1
  show ?thesis
    by(auto simp  add: HInv4a_def simp del: HEndPhase0_def
          elim: HEndPhase0_HInv4a1_p HEndPhase0_HInv4a2_p)
qed

lemma HEndPhase0_HInv4a_q:
  assumes act: "HEndPhase0 s s' p"
  and inv: "HInv4a s q"
  and pnq: "p\<noteq>q"
  shows "HInv4a s' q"
proof -
  from act pnq
  have "dblock s' q = dblock s q \<and> disk s' = disk s"
    by(auto simp add: EndPhase0_def)
  moreover
  from act pnq
  have "\<forall>p d. rdBy s' q p d \<subseteq> rdBy s q p d"
    by(auto simp add: EndPhase0_def InitializePhase_def rdBy_def)
  hence "(UN p d. rdBy s' q p d) \<subseteq> (UN p d. rdBy s q p d)"
    by(auto, blast)
  ultimately
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: blocksOf_def, blast)
  with act inv pnq
  show ?thesis
    by(auto simp add: EndPhase0_def HInv4a_def HInv4a1_def HInv4a2_def)
qed

theorem HEndPhase0_HInv4a:
  "\<lbrakk> HEndPhase0 s s' p; HInv4a s q; HInv4d s p;
     Inv2a s;  Inv1 s;   Inv2a s; Inv2c s\<rbrakk>
  \<Longrightarrow> HInv4a s' q"
  by(blast dest: HEndPhase0_HInv4a_p HEndPhase0_HInv4a_q)

subsubsection \<open>Proofs of Invariant 4b\<close>

lemma blocksRead_allBlocksRead:
  "rb \<in> blocksRead s p d \<Longrightarrow> block rb \<in> allBlocksRead s p"
 by(auto simp add: allBlocksRead_def allRdBlks_def)

lemma HEndPhase0_dblock_mbal:
  "\<lbrakk> HEndPhase0 s  s' p \<rbrakk>
     \<Longrightarrow> \<forall>br\<in>allBlocksRead s p. mbal br < mbal(dblock s' p)"
  by(auto simp add: EndPhase0_def)

lemma HEndPhase0_HInv4b_p_dblock:
  assumes act: "HEndPhase0 s  s' p"
  and inv1:  "Inv1 s"
  and inv2a: "Inv2a s"
  and inv2c: "Inv2c_inner s p"
  shows "bal(dblock s' p) < mbal(dblock s' p)"
proof -
  from act have "phase s p = 0" by(auto simp add: EndPhase0_def)
  with inv2c
  have "\<forall>d.\<forall>br\<in>blocksRead s p d. proc br = p \<and> block br = disk s d p"
    by(auto simp add: Inv2c_inner_def)
  hence allBlks_in_blocksOf: "allBlocksRead s p \<subseteq> blocksOf s p"
    by(auto simp add: allBlocksRead_def allRdBlks_def blocksOf_def)
  from act HEndPhase0_some[OF act inv1]
  have p53: "\<exists>br\<in>allBlocksRead s p. bal(dblock s' p)=bal br"
    by(auto simp add: EndPhase0_def)
  from inv2a
  have i2: "\<forall>p. \<forall>bk\<in>blocksOf s p. bal bk \<le> mbal bk"
    by(auto simp add: Inv2a_def Inv2a_inner_def Inv2a_innermost_def)
  with allBlks_in_blocksOf
  have "\<forall>bk\<in>allBlocksRead s p. bal bk \<le> mbal bk"
    by auto
  with p53
  have "\<exists>br\<in>allBlocksRead s p. bal(dblock s' p)\<le> mbal br"
    by force
  with HEndPhase0_dblock_mbal[OF act]
  show ?thesis
    by auto
qed

lemma HEndPhase0_HInv4b_p_blocksOf:
  assumes act: "HEndPhase0 s  s' p"
  and inv4d: "HInv4d s p"
  and inv2c: "Inv2c_inner s p"
  and bk: "bk \<in> blocksOf s p"
  shows "bal bk < mbal(dblock s' p)"
proof -
  from inv4d  majorities_intersect bk
  have p43: "\<forall>D\<in>MajoritySet.\<exists>d\<in>D. bal bk \<le> mbal(disk s d p)"
    by(auto simp add: HInv4d_def MajoritySet_def Majority_exQ)
  have "\<exists>br \<in> allBlocksRead s p. bal bk \<le> mbal br"
  proof -
    from act
    have maj: "IsMajority({d. hasRead s p d p})" (is "IsMajority(?D)")
     and phase: "phase s p = 0"
      by(simp add: EndPhase0_def)+
    have br_ne: "\<forall>d\<in>?D. blocksRead s p d \<noteq> {}"
      by(auto simp add: hasRead_def)
    from phase inv2c
    have "\<forall>d\<in>?D.\<forall>br\<in>blocksRead s p d. block br = disk s d p"
      by(auto simp add: Inv2c_inner_def)
    with br_ne
    have "\<forall>d\<in>?D. \<exists>br\<in> allBlocksRead s p. br = disk s d p"
      by(blast dest: blocksRead_allBlocksRead)
    with p43 maj
    show ?thesis
      by(auto simp add: MajoritySet_def)
  qed
  with HEndPhase0_dblock_mbal[OF act]
  show ?thesis
    by auto
qed

lemma HEndPhase0_HInv4b_p:
  assumes act: "HEndPhase0 s  s' p"
  and inv4d: "HInv4d s p"
  and inv1:  "Inv1 s"
  and inv2a: "Inv2a s"
  and inv2c: "Inv2c_inner s p"
  shows "HInv4b s' p"
proof(clarsimp simp add: HInv4b_def)
  from act
  have  phase: "phase s p = 0"
    by(auto simp add: EndPhase0_def)
  fix bk
  assume bk: "bk\<in> blocksOf s' p"
  with HEndPhase0_blocksOf[OF act]
  have "bk\<in>{dblock s' p} \<or> bk\<in>blocksOf s p"
    by blast
  thus "bal bk < mbal (dblock s' p)"
  proof
    assume bk: "bk\<in>{dblock s' p}"
    with act inv1 inv2a inv2c
    show ?thesis
      by(auto simp del: HEndPhase0_def
                  dest: HEndPhase0_HInv4b_p_dblock )
  next
    assume bk: "bk \<in> blocksOf s p"
    with act inv2c inv4d
    show ?thesis
      by(blast dest: HEndPhase0_HInv4b_p_blocksOf)
  qed
qed

lemma HEndPhase0_HInv4b_q:
  assumes act: "HEndPhase0 s  s' p"
  and pnq: "p\<noteq>q"
  and inv: "HInv4b s q"
  shows "HInv4b s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
   and dblock': "dblock s' q=dblock s q"
   and phase': "phase s' q =phase s q"
    by(auto simp add: EndPhase0_def)
  from act pnq
  have blocksRead': "\<forall>q. allRdBlks s' q \<subseteq> allRdBlks s q"
    by(auto simp add: EndPhase0_def InitializePhase_def allRdBlks_def)
  with disk' dblock'
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: allRdBlks_def blocksOf_def rdBy_def, blast)
  with inv phase' dblock'
  show ?thesis
    by(auto simp add: HInv4b_def)
qed

theorem HEndPhase0_HInv4b:
  assumes act: "HEndPhase0 s  s' p"
  and inv: "HInv4b s q"
  and inv4d: "HInv4d s p"
  and inv1: "Inv1 s"
  and inv2a: "Inv2a s"
  and inv2c: "Inv2c_inner s p"
  shows "HInv4b s' q"
proof(cases "p=q")
  case True
  with HEndPhase0_HInv4b_p[OF act inv4d inv1 inv2a inv2c]
  show ?thesis by simp
next
  case False
  from HEndPhase0_HInv4b_q[OF act False inv]
  show ?thesis .
qed

lemma HStartBallot_HInv4b_p:
  assumes act: "HStartBallot s  s' p"
  and inv2a: "Inv2a_innermost s p (dblock s p)"
  and inv4b: "HInv4b s p"
  and inv4a: "HInv4a s p"
  shows "HInv4b s' p"
proof(clarsimp simp add: HInv4b_def)
  fix bk
  assume bk: "bk \<in> blocksOf s' p"
  from act
  have phase': "phase s' p = 1"
    and phase: "phase s p \<in> {1,2}"
    by(auto simp add: StartBallot_def)
  from act
  have p42: "  mbal (dblock s p)< mbal (dblock s' p)
        \<and> bal(dblock s p) = bal(dblock s' p)"
    by(auto simp add: StartBallot_def)
  from HStartBallot_blocksOf[OF act] bk
  have "bk \<in> {dblock s' p} \<union> blocksOf s p"
    by blast
  thus "bal bk < mbal (dblock s' p)"
  proof
    assume bk: "bk \<in> {dblock s' p}"
    from inv2a
    have "bal (dblock s p) \<le> mbal (dblock s p)"
      by(auto simp add: Inv2a_innermost_def)
    with p42 bk
    show ?thesis by auto
  next
    assume bk: "bk \<in> blocksOf s p"
    from phase inv4a
    have p41: "HInv4a1 s p"
      by(auto simp add: HInv4a_def)
    with p42 bk
    show ?thesis
      by(auto simp add: HInv4a1_def)
  qed
qed

lemma HStartBallot_HInv4b_q:
  assumes act: "HStartBallot s  s' p"
  and pnq: "p\<noteq>q"
  and inv: "HInv4b s q"
  shows "HInv4b s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
   and dblock': "dblock s' q=dblock s q"
   and phase': "phase s' q =phase s q"
    by(auto simp add: StartBallot_def)
  from act pnq
  have blocksRead': "\<forall>q. allRdBlks s' q \<subseteq> allRdBlks s q"
    by(auto simp add: StartBallot_def InitializePhase_def allRdBlks_def)
  with disk' dblock'
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: allRdBlks_def blocksOf_def rdBy_def, blast)
  with inv phase' dblock'
  show ?thesis
    by(auto simp add: HInv4b_def)
qed

theorem HStartBallot_HInv4b:
  assumes act: "HStartBallot s  s' p"
  and inv2a: "Inv2a s"
  and inv4b: "HInv4b s q"
  and inv4a: "HInv4a s p"
  shows "HInv4b s' q"
using act inv2a inv4b inv4a
proof (cases "p=q")
  case True
  from inv2a
  have "Inv2a_innermost s p (dblock s p)"
    by(auto simp add: Inv2a_def Inv2a_inner_def blocksOf_def)
  with act True inv4b inv4a
  show ?thesis
    by(blast dest: HStartBallot_HInv4b_p)
next
  case False
  with act inv4b
  show ?thesis
    by(blast dest: HStartBallot_HInv4b_q)
qed

theorem HPhase1or2Write_HInv4b:
  "\<lbrakk> HPhase1or2Write s s' p d; HInv4b s q \<rbrakk> \<Longrightarrow> HInv4b s' q"
  by(auto simp add: Phase1or2Write_def HInv4b_def
                    blocksOf_def rdBy_def)

lemma HPhase1or2ReadThen_HInv4b_p:
  assumes act: "HPhase1or2ReadThen s s' p d q"
  and inv: "HInv4b s p"
  shows "HInv4b s' p"
proof -
  from HPhase1or2ReadThen_blocksOf[OF act] inv act
  show ?thesis
    by(auto simp add: HInv4b_def Phase1or2ReadThen_def)
qed

lemma HPhase1or2ReadThen_HInv4b_q:
  assumes act: "HPhase1or2ReadThen s s' p d r"
  and inv: "HInv4b s q"
  and pnq: "p\<noteq>q"
  shows "HInv4b s' q"
  using assms HPhase1or2ReadThen_blocksOf[OF act]
  by(auto simp add: Phase1or2ReadThen_def HInv4b_def)

theorem HPhase1or2ReadThen_HInv4b:
  "\<lbrakk> HPhase1or2ReadThen s s' p d q; HInv4b s r\<rbrakk> \<Longrightarrow> HInv4b s' r"
  by(blast dest: HPhase1or2ReadThen_HInv4b_p
                 HPhase1or2ReadThen_HInv4b_q)

theorem HPhase1or2ReadElse_HInv4b:
  "\<lbrakk> HPhase1or2ReadElse s s' p d q; HInv4b s r;
     Inv2a s; HInv4a s p \<rbrakk>
  \<Longrightarrow> HInv4b s' r"
using HStartBallot_HInv4b
 by(auto simp add: Phase1or2ReadElse_def)

lemma HEndPhase1_HInv4b_p:
  "HEndPhase1 s s' p \<Longrightarrow> HInv4b s' p"
  by(auto simp add: EndPhase1_def HInv4b_def)

lemma HEndPhase1_HInv4b_q:
  assumes act: "HEndPhase1 s  s' p"
  and pnq: "p\<noteq>q"
  and inv: "HInv4b s q"
  shows "HInv4b s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
   and dblock': "dblock s' q=dblock s q"
   and phase': "phase s' q =phase s q"
    by(auto simp add: EndPhase1_def)
  from act pnq
  have blocksRead': "\<forall>q. allRdBlks s' q \<subseteq> allRdBlks s q"
    by(auto simp add: EndPhase1_def InitializePhase_def allRdBlks_def)
  with disk' dblock'
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: allRdBlks_def blocksOf_def rdBy_def, blast)
  with inv phase' dblock'
  show ?thesis
    by(auto simp add: HInv4b_def)
qed

theorem HEndPhase1_HInv4b:
  assumes act: "HEndPhase1 s  s' p"
  and inv: "HInv4b s q"
  shows "HInv4b s' q"
proof(cases "p=q")
  case True
  with HEndPhase1_HInv4b_p[OF act]
  show ?thesis by simp
next
  case False
  from HEndPhase1_HInv4b_q[OF act False inv]
  show ?thesis .
qed

lemma HEndPhase2_HInv4b_p:
  "HEndPhase2 s s' p \<Longrightarrow> HInv4b s' p"
  by(auto simp add: EndPhase2_def HInv4b_def)

lemma HEndPhase2_HInv4b_q:
  assumes act: "HEndPhase2 s  s' p"
  and pnq: "p\<noteq>q"
  and inv: "HInv4b s q"
  shows "HInv4b s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
   and dblock': "dblock s' q=dblock s q"
   and phase': "phase s' q =phase s q"
    by(auto simp add: EndPhase2_def)
  from act pnq
  have blocksRead': "\<forall>q. allRdBlks s' q \<subseteq> allRdBlks s q"
    by(auto simp add: EndPhase2_def InitializePhase_def allRdBlks_def)
  with disk' dblock'
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: allRdBlks_def blocksOf_def rdBy_def, blast)
  with inv phase' dblock'
  show ?thesis
    by(auto simp add: HInv4b_def)
qed

theorem HEndPhase2_HInv4b:
  assumes act: "HEndPhase2 s  s' p"
  and inv: "HInv4b s q"
  shows "HInv4b s' q"
proof(cases "p=q")
  case True
  with HEndPhase2_HInv4b_p[OF act]
  show ?thesis by simp
next
  case False
  from HEndPhase2_HInv4b_q[OF act False inv]
  show ?thesis .
qed

lemma HFail_HInv4b_q:
  assumes act: "HFail s  s' p"
  and pnq: "p\<noteq>q"
  and inv: "HInv4b s q"
  shows "HInv4b s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
   and dblock': "dblock s' q=dblock s q"
   and phase': "phase s' q =phase s q"
    by(auto simp add: Fail_def)
  from act pnq
  have blocksRead': "\<forall>q. allRdBlks s' q \<subseteq> allRdBlks s q"
    by(auto simp add: Fail_def InitializePhase_def allRdBlks_def)
  with disk' dblock'
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: allRdBlks_def blocksOf_def rdBy_def, blast)
  with inv phase' dblock'
  show ?thesis
    by(auto simp add: HInv4b_def)
qed

theorem HFail_HInv4b:
  assumes act: "HFail s  s' p"
  and inv: "HInv4b s q"
  shows "HInv4b s' q"
proof(cases "p=q")
  case True
  with HFail_HInv4b_p[OF act]
  show ?thesis by simp
next
  case False
  from HFail_HInv4b_q[OF act False inv]
  show ?thesis .
qed

lemma HPhase0Read_HInv4b_p:
  "HPhase0Read s s' p d \<Longrightarrow> HInv4b s' p"
  by(auto simp add: Phase0Read_def HInv4b_def)

lemma HPhase0Read_HInv4b_q:
  assumes act: "HPhase0Read s  s' p d"
  and pnq: "p\<noteq>q"
  and inv: "HInv4b s q"
  shows "HInv4b s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
   and dblock': "dblock s' q=dblock s q"
   and phase': "phase s' q =phase s q"
    by(auto simp add: Phase0Read_def)
  from HPhase0Read_blocksOf[OF act] inv phase' dblock'
  show ?thesis
    by(auto simp add: HInv4b_def)
qed

theorem HPhase0Read_HInv4b:
  assumes act: "HPhase0Read s  s' p d"
  and inv: "HInv4b s q"
  shows "HInv4b s' q"
proof(cases "p=q")
  case True
  with HPhase0Read_HInv4b_p[OF act]
  show ?thesis by simp
next
  case False
  from HPhase0Read_HInv4b_q[OF act False inv]
  show ?thesis .
qed

subsubsection \<open>Proofs of Invariant 4c\<close>

lemma  HStartBallot_HInv4c_p:
  "\<lbrakk> HStartBallot s s' p; HInv4c s p\<rbrakk> \<Longrightarrow> HInv4c s' p"
  by(auto simp add: StartBallot_def HInv4c_def)

lemma  HStartBallot_HInv4c_q:
  assumes act: "HStartBallot s s' p"
  and inv: "HInv4c s q"
  and pnq: "p\<noteq>q"
  shows "HInv4c s' q"
proof -
  from act pnq
  have phase: "phase s' q = phase s q"
   and dblock: "dblock s q = dblock s' q"
   and disk: "disk s' = disk s"
    by(auto simp add: StartBallot_def)
  with inv
  show ?thesis
    by(auto simp add: HInv4c_def)
qed

theorem HStartBallot_HInv4c:
  "\<lbrakk> HStartBallot s s' p; HInv4c s q\<rbrakk> \<Longrightarrow> HInv4c s' q"
  by(blast dest: HStartBallot_HInv4c_p HStartBallot_HInv4c_q)

lemma  HPhase1or2Write_HInv4c_p:
  assumes act: "HPhase1or2Write s s' p d"
      and inv: "HInv4c s p"
    and inv2c: "Inv2c s"
  shows "HInv4c s' p"
proof(cases "phase s' p = 2")
  assume phase': "phase s' p = 2"
  show ?thesis
  proof(auto simp add: HInv4c_def phase' MajoritySet_def)
    from act phase'
    have bal: "bal(dblock s' p)=bal(dblock s p)"
      and phase: "phase s p = 2"
      by(auto simp add: Phase1or2Write_def)
    from phase' inv2c act
    have "mbal(disk s' d p)=bal(dblock s p)"
      by(auto simp add: Phase1or2Write_def Inv2c_def Inv2c_inner_def)
    with bal
    have "bal(dblock s' p) = mbal(disk s' d p)"
      by auto
    with inv phase act
    show "\<exists>D.    IsMajority D
              \<and> (\<forall>d\<in>D. mbal (disk s' d p) = bal (dblock s' p))"
      by(auto simp add: HInv4c_def Phase1or2Write_def MajoritySet_def)
  qed
next
  case False
  with act
  show ?thesis
    by(auto simp add: HInv4c_def Phase1or2Write_def)
qed

lemma  HPhase1or2Write_HInv4c_q:
  assumes act: "HPhase1or2Write s s' p d"
  and inv: "HInv4c s q"
  and pnq: "p\<noteq>q"
  shows "HInv4c s' q"
proof -
  from act pnq
  have phase: "phase s' q = phase s q"
   and dblock: "dblock s q = dblock s' q"
    and disk: "\<forall>d. disk s' d q  = disk s d q"
    by(auto simp add: Phase1or2Write_def)
  with inv
  show ?thesis
    by(auto simp add: HInv4c_def)
qed

theorem HPhase1or2Write_HInv4c:
  "\<lbrakk> HPhase1or2Write s s' p d; HInv4c s q; Inv2c s \<rbrakk>
             \<Longrightarrow> HInv4c s' q"
  by(blast dest: HPhase1or2Write_HInv4c_p
                 HPhase1or2Write_HInv4c_q)

lemma  HPhase1or2ReadThen_HInv4c_p:
  "\<lbrakk> HPhase1or2ReadThen s s' p d q; HInv4c s p\<rbrakk> \<Longrightarrow> HInv4c s' p"
  by(auto simp add: Phase1or2ReadThen_def HInv4c_def)

lemma  HPhase1or2ReadThen_HInv4c_q:
  assumes act: "HPhase1or2ReadThen s s' p d r"
  and inv: "HInv4c s q"
  and pnq: "p\<noteq>q"
  shows "HInv4c s' q"
proof -
  from act pnq
  have phase: "phase s' q = phase s q"
   and dblock: "dblock s q = dblock s' q"
   and disk: "disk s' = disk s"
    by(auto simp add: Phase1or2ReadThen_def)
  with inv
  show ?thesis
    by(auto simp add: HInv4c_def)
qed

theorem HPhase1or2ReadThen_HInv4c:
  "\<lbrakk> HPhase1or2ReadThen s s' p d r; HInv4c s q\<rbrakk>
          \<Longrightarrow> HInv4c s' q"
  by(blast dest: HPhase1or2ReadThen_HInv4c_p
                 HPhase1or2ReadThen_HInv4c_q)

theorem HPhase1or2ReadElse_HInv4c:
  "\<lbrakk> HPhase1or2ReadElse s s' p d r; HInv4c s q\<rbrakk> \<Longrightarrow> HInv4c s' q"
using HStartBallot_HInv4c
  by(auto simp add: Phase1or2ReadElse_def)

lemma  HEndPhase1_HInv4c_p:
  assumes act: "HEndPhase1 s s' p"
  and inv2b: "Inv2b s"
  shows "HInv4c s' p"
proof -
  from act
  have maj: "   IsMajority {d. d\<in> disksWritten s p
             \<and> (\<forall>q\<in>(UNIV- {p}). hasRead s p d q)}"
    (is  "IsMajority ?M")
    by(simp add: EndPhase1_def)
  from inv2b
  have "\<forall>d\<in>?M. disk s d p = dblock s p"
    by(auto simp add: Inv2b_def Inv2b_inner_def)
  with act maj
  show ?thesis
    by(auto simp add: HInv4c_def EndPhase1_def MajoritySet_def)
qed

lemma  HEndPhase1_HInv4c_q:
  assumes act: "HEndPhase1 s s' p"
  and inv: "HInv4c s q"
  and pnq: "p\<noteq>q"
  shows "HInv4c s' q"
proof -
  from act pnq
  have phase: "phase s' q = phase s q"
   and dblock: "dblock s q = dblock s' q"
   and disk: "disk s' = disk s"
    by(auto simp add: EndPhase1_def)
  with inv
  show ?thesis
    by(auto simp add: HInv4c_def)
qed

theorem HEndPhase1_HInv4c:
  "\<lbrakk> HEndPhase1 s s' p; HInv4c s q; Inv2b s\<rbrakk> \<Longrightarrow> HInv4c s' q"
  by(blast dest: HEndPhase1_HInv4c_p HEndPhase1_HInv4c_q)

lemma  HEndPhase2_HInv4c_p:
  "\<lbrakk> HEndPhase2 s s' p; HInv4c s p\<rbrakk> \<Longrightarrow> HInv4c s' p"
  by(auto simp add: EndPhase2_def HInv4c_def)

lemma  HEndPhase2_HInv4c_q:
  assumes act: "HEndPhase2 s s' p"
  and inv: "HInv4c s q"
  and pnq: "p\<noteq>q"
  shows "HInv4c s' q"
proof -
  from act pnq
  have phase: "phase s' q = phase s q"
   and dblock: "dblock s q = dblock s' q"
   and disk: "disk s' = disk s"
    by(auto simp add: EndPhase2_def)
  with inv
  show ?thesis
    by(auto simp add: HInv4c_def)
qed

theorem HEndPhase2_HInv4c:
  "\<lbrakk> HEndPhase2 s s' p; HInv4c s q\<rbrakk> \<Longrightarrow> HInv4c s' q"
  by(blast dest: HEndPhase2_HInv4c_p HEndPhase2_HInv4c_q)

lemma  HFail_HInv4c_p:
  "\<lbrakk> HFail s s' p; HInv4c s p\<rbrakk> \<Longrightarrow> HInv4c s' p"
  by(auto simp add: Fail_def HInv4c_def)

lemma  HFail_HInv4c_q:
  assumes act: "HFail s s' p"
  and inv: "HInv4c s q"
  and pnq: "p\<noteq>q"
  shows "HInv4c s' q"
proof -
  from act pnq
  have phase: "phase s' q = phase s q"
   and dblock: "dblock s q = dblock s' q"
   and disk: "disk s' = disk s"
    by(auto simp add: Fail_def)
  with inv
  show ?thesis
    by(auto simp add: HInv4c_def)
qed

theorem HFail_HInv4c:
  "\<lbrakk> HFail s s' p; HInv4c s q\<rbrakk> \<Longrightarrow> HInv4c s' q"
  by(blast dest: HFail_HInv4c_p HFail_HInv4c_q)

lemma  HPhase0Read_HInv4c_p:
  "\<lbrakk> HPhase0Read s s' p d; HInv4c s p\<rbrakk> \<Longrightarrow> HInv4c s' p"
  by(auto simp add: Phase0Read_def HInv4c_def)

lemma  HPhase0Read_HInv4c_q:
  assumes act: "HPhase0Read s s' p d"
  and inv: "HInv4c s q"
  and pnq: "p\<noteq>q"
  shows "HInv4c s' q"
proof -
  from act pnq
  have phase: "phase s' q = phase s q"
   and dblock: "dblock s q = dblock s' q"
   and disk: "disk s' = disk s"
    by(auto simp add: Phase0Read_def)
  with inv
  show ?thesis
    by(auto simp add: HInv4c_def)
qed

theorem HPhase0Read_HInv4c:
  "\<lbrakk> HPhase0Read s s' p d; HInv4c s q\<rbrakk> \<Longrightarrow> HInv4c s' q"
  by(blast dest: HPhase0Read_HInv4c_p HPhase0Read_HInv4c_q)

lemma  HEndPhase0_HInv4c_p:
  "\<lbrakk> HEndPhase0 s s' p; HInv4c s p\<rbrakk> \<Longrightarrow> HInv4c s' p"
  by(auto simp add: EndPhase0_def HInv4c_def)

lemma  HEndPhase0_HInv4c_q:
  assumes act: "HEndPhase0 s s' p"
  and inv: "HInv4c s q"
  and pnq: "p\<noteq>q"
  shows "HInv4c s' q"
proof -
  from act pnq
  have phase: "phase s' q = phase s q"
   and dblock: "dblock s q = dblock s' q"
   and disk: "disk s' = disk s"
    by(auto simp add: EndPhase0_def)
  with inv
  show ?thesis
    by(auto simp add: HInv4c_def)
qed

theorem HEndPhase0_HInv4c:
  "\<lbrakk> HEndPhase0 s s' p; HInv4c s q\<rbrakk> \<Longrightarrow> HInv4c s' q"
  by(blast dest: HEndPhase0_HInv4c_p HEndPhase0_HInv4c_q)

subsubsection \<open>Proofs of Invariant 4d\<close>

lemma  HStartBallot_HInv4d_p:
  assumes act: "HStartBallot s s' p"
  and inv: "HInv4d s p"
  shows "HInv4d s' p"
proof(clarsimp simp add: HInv4d_def)
  fix bk
  assume bk: "bk \<in> blocksOf s' p"
  from act
  have bal': "bal (dblock s' p) = bal (dblock s p)"
    by(auto simp add: StartBallot_def)
  from subsetD[OF HStartBallot_blocksOf[OF act] bk]
  have "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s d p)"
  proof
    assume bk: "bk \<in> blocksOf s p"
    with inv
    show ?thesis
      by(auto simp add: HInv4d_def)
  next
    assume bk: "bk \<in> {dblock s' p}"
    with bal' inv
    show ?thesis
      by(auto simp add: HInv4d_def blocksOf_def)
  qed
  with act
  show "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s' d p)"
    by(auto simp add: StartBallot_def)
qed

lemma HStartBallot_HInv4d_q:
  assumes act: "HStartBallot s  s' p"
  and inv: "HInv4d s q"
  and pnq: "p\<noteq>q"
  shows "HInv4d s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
   and dblock': "dblock s' q=dblock s q"
    by(auto simp add: StartBallot_def)
  from act pnq
  have blocksRead': "\<forall>q. allRdBlks s' q \<subseteq> allRdBlks s q"
    by(auto simp add: StartBallot_def InitializePhase_def allRdBlks_def)
  with disk' dblock'
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: allRdBlks_def blocksOf_def rdBy_def, blast)
  from subsetD[OF this] inv
  have "\<forall>bk\<in>blocksOf s' q.
           \<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal(disk s d q)"
    by(auto simp add: HInv4d_def)
  with disk'
  show ?thesis
  by(auto simp add: HInv4d_def)
qed

theorem HStartBallot_HInv4d:
  "\<lbrakk> HStartBallot s s' p; HInv4d s q\<rbrakk> \<Longrightarrow> HInv4d s' q"
  by(blast dest: HStartBallot_HInv4d_p HStartBallot_HInv4d_q)

lemma  HPhase1or2Write_HInv4d_p:
  assumes act: "HPhase1or2Write s s' p d"
  and inv: "HInv4d s p"
  and inv4a: "HInv4a s p"
  shows "HInv4d s' p"
proof(clarsimp simp add: HInv4d_def)
  fix bk
  assume bk: "bk \<in> blocksOf s' p"
  from act
  have ddisk: "\<forall>dd. disk s' dd p = (if d = dd
                                       then dblock s p
                                       else disk s dd p)"
    and phase: "phase s p \<noteq> 0"
    by(auto simp add: Phase1or2Write_def)
  from inv subsetD[OF HPhase1or2Write_blocksOf[OF act] bk]
  have asm3: "\<exists>D\<in>MajoritySet. \<forall>dd\<in>D. bal bk \<le> mbal (disk s dd p)"
    by(auto simp add: HInv4d_def)
  from phase inv4a subsetD[OF HPhase1or2Write_blocksOf[OF act] bk] ddisk
  have p41: "bal bk \<le> mbal (disk s' d p)"
    by(auto simp add: HInv4a_def HInv4a1_def)
  with ddisk asm3
  show "\<exists>D\<in>MajoritySet. \<forall>dd\<in>D. bal bk \<le> mbal (disk s' dd p)"
    by(auto simp add: MajoritySet_def split: if_split_asm)
qed

lemma HPhase1or2Write_HInv4d_q:
  assumes act: "HPhase1or2Write s  s' p d"
  and inv: "HInv4d s q"
  and pnq: "p\<noteq>q"
  shows "HInv4d s' q"
proof -
  from act pnq
  have disk': "\<forall>d. disk s' d q =disk s  d q"
    by(auto simp add: Phase1or2Write_def)
  from act pnq
  have blocksRead': "\<forall>q. allRdBlks s' q \<subseteq> allRdBlks s q"
    by(auto simp add: Phase1or2Write_def
                      InitializePhase_def allRdBlks_def)
  with act pnq
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: Phase1or2Write_def allRdBlks_def
                      blocksOf_def rdBy_def)
  from subsetD[OF this] inv
  have "\<forall>bk\<in>blocksOf s' q.
            \<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal(disk s d q)"
    by(auto simp add: HInv4d_def)
  with disk'
  show ?thesis
  by(auto simp add: HInv4d_def)
qed

theorem HPhase1or2Write_HInv4d:
  "\<lbrakk> HPhase1or2Write s s' p d; HInv4d s q; HInv4a s p\<rbrakk> \<Longrightarrow> HInv4d s' q"
  by(blast dest: HPhase1or2Write_HInv4d_p HPhase1or2Write_HInv4d_q)

lemma  HPhase1or2ReadThen_HInv4d_p:
  assumes act: "HPhase1or2ReadThen s s' p d q"
  and inv: "HInv4d s p"
  shows "HInv4d s' p"
proof(clarsimp simp add: HInv4d_def)
  fix bk
  assume bk: "bk \<in> blocksOf s' p"
  from act
  have bal': "bal (dblock s' p) = bal (dblock s p)"
    by(auto simp add: Phase1or2ReadThen_def)
  from subsetD[OF HPhase1or2ReadThen_blocksOf[OF act] bk] inv
  have "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s d p)"
    by(auto simp add: HInv4d_def)
  with act
  show "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s' d p)"
    by(auto simp add: Phase1or2ReadThen_def)
qed

lemma HPhase1or2ReadThen_HInv4d_q:
  assumes act: "HPhase1or2ReadThen s  s' p d r"
  and inv: "HInv4d s q"
  and pnq: "p\<noteq>q"
  shows "HInv4d s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
    by(auto simp add: Phase1or2ReadThen_def)
  from act pnq
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: Phase1or2ReadThen_def allRdBlks_def
                      blocksOf_def rdBy_def)
  from subsetD[OF this] inv
  have "\<forall>bk\<in>blocksOf s' q.
             \<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal(disk s d q)"
    by(auto simp add: HInv4d_def)
  with disk'
  show ?thesis
  by(auto simp add: HInv4d_def)
qed

theorem HPhase1or2ReadThen_HInv4d:
  "\<lbrakk> HPhase1or2ReadThen s s' p d r; HInv4d s q\<rbrakk> \<Longrightarrow> HInv4d s' q"
  by(blast dest: HPhase1or2ReadThen_HInv4d_p
                 HPhase1or2ReadThen_HInv4d_q)

theorem HPhase1or2ReadElse_HInv4d:
  "\<lbrakk> HPhase1or2ReadElse s s' p d r; HInv4d s q\<rbrakk> \<Longrightarrow> HInv4d s' q"
using HStartBallot_HInv4d
  by(auto simp add: Phase1or2ReadElse_def)

lemma  HEndPhase1_HInv4d_p:
  assumes act: "HEndPhase1 s s' p"
  and inv: "HInv4d s p"
  and inv2b: "Inv2b s"
  and inv4c: "HInv4c s p"
  shows "HInv4d s' p"
proof(clarsimp simp add: HInv4d_def)
  fix bk
  assume bk: "bk \<in> blocksOf s' p"
  from HEndPhase1_HInv4c[OF act inv4c inv2b]
  have "HInv4c s' p" .
  with act
  have p31: "\<exists>D\<in>MajoritySet.
               \<forall>d\<in>D. mbal (disk s' d p) = bal(dblock s' p)"
    and disk': "disk s' = disk s"
    by(auto simp add: EndPhase1_def HInv4c_def)
  from subsetD[OF HEndPhase1_blocksOf[OF act] bk]
  show "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s' d p)"
  proof
    assume bk: "bk \<in> blocksOf s p"
    with inv disk'
    show ?thesis
      by(auto simp add: HInv4d_def)
  next
    assume bk: "bk \<in> {dblock s' p}"
    with p31
    show ?thesis
      by force
  qed
qed

lemma HEndPhase1_HInv4d_q:
  assumes act: "HEndPhase1 s  s' p"
  and inv: "HInv4d s q"
  and pnq: "p\<noteq>q"
  shows "HInv4d s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
   and dblock': "dblock s' q=dblock s q"
    by(auto simp add: EndPhase1_def)
  from act pnq
  have blocksRead': "\<forall>q. allRdBlks s' q \<subseteq> allRdBlks s q"
    by(auto simp add: EndPhase1_def InitializePhase_def
                      allRdBlks_def)
  with disk' dblock'
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: allRdBlks_def blocksOf_def rdBy_def, blast)
  from subsetD[OF this] inv
  have "\<forall>bk\<in>blocksOf s' q.
           \<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal(disk s d q)"
    by(auto simp add: HInv4d_def)
  with disk'
  show ?thesis
  by(auto simp add: HInv4d_def)
qed

theorem HEndPhase1_HInv4d:
  "\<lbrakk> HEndPhase1 s s' p; HInv4d s q; Inv2b s; HInv4c s p\<rbrakk>
         \<Longrightarrow> HInv4d s' q"
  by(blast dest: HEndPhase1_HInv4d_p HEndPhase1_HInv4d_q)

lemma  HEndPhase2_HInv4d_p:
  assumes act: "HEndPhase2 s s' p"
  and inv: "HInv4d s p"
  shows "HInv4d s' p"
proof(clarsimp simp add: HInv4d_def)
  fix bk
  assume bk: "bk \<in> blocksOf s' p"
  from act
  have bal': "bal (dblock s' p) = bal (dblock s p)"
    by(auto simp add: EndPhase2_def)
  from subsetD[OF HEndPhase2_blocksOf[OF act] bk] inv
  have "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s d p)"
    by(auto simp add: HInv4d_def)
  with act
  show "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s' d p)"
    by(auto simp add: EndPhase2_def)
qed

lemma HEndPhase2_HInv4d_q:
  assumes act: "HEndPhase2 s  s' p"
  and inv: "HInv4d s q"
  and pnq: "p\<noteq>q"
  shows "HInv4d s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
    by(auto simp add: EndPhase2_def)
  from act pnq
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: EndPhase2_def InitializePhase_def
                      allRdBlks_def blocksOf_def rdBy_def)
  from subsetD[OF this] inv
  have "\<forall>bk\<in>blocksOf s' q.
           \<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal(disk s d q)"
    by(auto simp add: HInv4d_def)
  with disk'
  show ?thesis
  by(auto simp add: HInv4d_def)
qed

theorem HEndPhase2_HInv4d:
  "\<lbrakk> HEndPhase2 s s' p; HInv4d s q\<rbrakk> \<Longrightarrow> HInv4d s' q"
  by(blast dest: HEndPhase2_HInv4d_p HEndPhase2_HInv4d_q)

lemma  HFail_HInv4d_p:
  assumes act: "HFail s s' p"
  and inv: "HInv4d s p"
  shows "HInv4d s' p"
proof(clarsimp simp add: HInv4d_def)
  fix bk
  assume bk: "bk \<in> blocksOf s' p"
  from act
  have disk': "disk s' = disk s"
    by(auto simp add: Fail_def)
  from subsetD[OF HFail_blocksOf[OF act] bk]
  show "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s' d p)"
  proof
    assume bk: "bk \<in> blocksOf s p"
    with inv disk'
    show ?thesis
      by(auto simp add: HInv4d_def)
  next
    assume bk: "bk \<in> {dblock s' p}"
    with act
    have "bal bk = 0"
      by(auto simp add: Fail_def InitDB_def)
    with Disk_isMajority
    show ?thesis
      by(auto simp add: MajoritySet_def)
  qed
qed

lemma HFail_HInv4d_q:
  assumes act: "HFail s  s' p"
  and inv: "HInv4d s q"
  and pnq: "p\<noteq>q"
  shows "HInv4d s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
   and dblock': "dblock s' q=dblock s q"
    by(auto simp add: Fail_def)
  from act pnq
  have blocksRead': "\<forall>q. allRdBlks s' q \<subseteq> allRdBlks s q"
    by(auto simp add: Fail_def InitializePhase_def allRdBlks_def)
  with disk' dblock'
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: allRdBlks_def blocksOf_def rdBy_def, blast)
  from subsetD[OF this] inv
  have "\<forall>bk\<in>blocksOf s' q.
          \<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal(disk s d q)"
    by(auto simp add: HInv4d_def)
  with disk'
  show ?thesis
  by(auto simp add: HInv4d_def)
qed

theorem HFail_HInv4d:
  "\<lbrakk> HFail s s' p; HInv4d s q \<rbrakk> \<Longrightarrow> HInv4d s' q"
  by(blast dest: HFail_HInv4d_p HFail_HInv4d_q)

lemma  HPhase0Read_HInv4d_p:
  assumes act: "HPhase0Read s s' p d"
  and inv: "HInv4d s p"
  shows "HInv4d s' p"
proof(clarsimp simp add: HInv4d_def)
  fix bk
  assume bk: "bk \<in> blocksOf s' p"
  from act
  have bal': "bal (dblock s' p) = bal (dblock s p)"
    by(auto simp add: Phase0Read_def)
  from subsetD[OF HPhase0Read_blocksOf[OF act] bk] inv
  have "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s d p)"
    by(auto simp add: HInv4d_def)
  with act
  show "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s' d p)"
    by(auto simp add: Phase0Read_def)
qed

lemma HPhase0Read_HInv4d_q:
  assumes act: "HPhase0Read s  s' p d"
  and inv: "HInv4d s q"
  and pnq: "p\<noteq>q"
  shows "HInv4d s' q"
proof -
  from act pnq
  have disk': "disk s'=disk s"
    by(auto simp add: Phase0Read_def)
  from act pnq
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: Phase0Read_def allRdBlks_def
                      blocksOf_def rdBy_def)
  from subsetD[OF this] inv
  have "\<forall>bk\<in>blocksOf s' q.
           \<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal(disk s d q)"
    by(auto simp add: HInv4d_def)
  with disk'
  show ?thesis
  by(auto simp add: HInv4d_def)
qed

theorem HPhase0Read_HInv4d:
  "\<lbrakk> HPhase0Read s s' p d; HInv4d s q\<rbrakk> \<Longrightarrow> HInv4d s' q"
  by(blast dest: HPhase0Read_HInv4d_p HPhase0Read_HInv4d_q)

lemma HEndPhase0_blocksOf2:
  assumes act: "HEndPhase0 s s' p"
  and inv2c: "Inv2c_inner s p"
  shows "allBlocksRead s p \<subseteq> blocksOf s p"
proof -
  from act inv2c
  have "\<forall>d.\<forall>br \<in> blocksRead s p d.   proc br =p
                                    \<and> block br = disk s d p"
    by(auto simp add: EndPhase0_def Inv2c_inner_def)
  thus ?thesis
    by(auto simp add: allBlocksRead_def allRdBlks_def
                      blocksOf_def)
qed

lemma  HEndPhase0_HInv4d_p:
  assumes act: "HEndPhase0 s s' p"
  and inv: "HInv4d s p"
  and inv2c: "Inv2c s"
  and inv1: "Inv1 s"
  shows "HInv4d s' p"
proof(clarsimp simp add: HInv4d_def)
  fix bk
  assume bk: "bk \<in> blocksOf s' p"
  from subsetD[OF HEndPhase0_blocksOf[OF act] bk]
  have "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s d p)"
  proof
    assume bk: "bk \<in> blocksOf s p"
    with inv
    show ?thesis
      by(auto simp add: HInv4d_def)
  next
    assume bk: "bk\<in> {dblock s' p}"
    from inv2c
    have inv2c_inner: "Inv2c_inner s p"
      by(auto simp add: Inv2c_def)
    from bk  HEndPhase0_some[OF act inv1]
         HEndPhase0_blocksOf2[OF act inv2c_inner] act
    have "bal bk \<in> bal `(blocksOf s p)"
      by(auto simp add: EndPhase0_def)
    with inv
    show ?thesis
      by(auto simp add: HInv4d_def)
  qed
  with act
  show "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal (disk s' d p)"
    by(auto simp add: EndPhase0_def)
qed

lemma HEndPhase0_HInv4d_q:
  assumes act: "HEndPhase0 s  s' p"
  and inv: "HInv4d s q"
  and pnq: "p\<noteq>q"
  shows "HInv4d s' q"
proof -
 from act pnq
  have "dblock s' q = dblock s q \<and> disk s' = disk s"
    by(auto simp add: EndPhase0_def)
  moreover
  from act pnq
  have "\<forall>p d. rdBy s' q p d \<subseteq> rdBy s q p d"
    by(auto simp add: EndPhase0_def InitializePhase_def rdBy_def)
  hence "(UN p d. rdBy s' q p d) \<subseteq> (UN p d. rdBy s q p d)"
    by(auto, blast)
  ultimately
  have "blocksOf s' q \<subseteq> blocksOf s q"
    by(auto simp add: blocksOf_def, blast)
  from subsetD[OF this] inv
  have "\<forall>bk\<in>blocksOf s' q.
           \<exists>D\<in>MajoritySet. \<forall>d\<in>D. bal bk \<le> mbal(disk s d q)"
    by(auto simp add: HInv4d_def)
  with act
  show ?thesis
  by(auto simp add: EndPhase0_def HInv4d_def)
qed

theorem HEndPhase0_HInv4d:
  "\<lbrakk> HEndPhase0 s s' p; HInv4d s q;
     Inv2c s; Inv1 s\<rbrakk> \<Longrightarrow> HInv4d s' q"
  by(blast dest: HEndPhase0_HInv4d_p HEndPhase0_HInv4d_q)

text\<open>Since we have already proved $HInv2$ is an invariant of $HNext$,
$HInv1 \wedge HInv2 \wedge HInv4$ is also an invariant of $HNext$.
\<close>

lemma I2d:
  assumes nxt: "HNext s s'"
  and inv: "HInv1 s \<and> HInv2 s \<and> HInv2 s' \<and> HInv4 s"
  shows "HInv4 s'"
 proof(auto simp add: HInv4_def)
   fix p
   show "HInv4a s' p" using assms
     by(auto simp add: HInv4_def HNext_def Next_def,
        auto simp add: HInv2_def intro: HStartBallot_HInv4a,
        auto intro: HPhase0Read_HInv4a,
        auto intro: HPhase1or2Write_HInv4a,
        auto simp add: Phase1or2Read_def
             intro: HPhase1or2ReadThen_HInv4a
                    HPhase1or2ReadElse_HInv4a,
        auto simp add: EndPhase1or2_def
             intro: HEndPhase1_HInv4a
                    HEndPhase2_HInv4a,
        auto intro: HFail_HInv4a,
        auto intro: HEndPhase0_HInv4a simp add: HInv1_def)
   show "HInv4b s' p" using assms
     by(auto simp add: HInv4_def HNext_def Next_def,
        auto simp add: HInv2_def
             intro: HStartBallot_HInv4b,
        auto intro: HPhase0Read_HInv4b,
        auto intro: HPhase1or2Write_HInv4b,
        auto simp add: Phase1or2Read_def
             intro: HPhase1or2ReadThen_HInv4b
                    HPhase1or2ReadElse_HInv4b,
        auto simp add: EndPhase1or2_def
             intro: HEndPhase1_HInv4b
                    HEndPhase2_HInv4b,
        auto intro: HFail_HInv4b,
        auto intro: HEndPhase0_HInv4b simp add: HInv1_def Inv2c_def)
   show "HInv4c s' p" using assms
     by(auto simp add: HInv4_def HNext_def Next_def,
        auto simp add: HInv2_def
             intro: HStartBallot_HInv4c,
        auto intro: HPhase0Read_HInv4c,
        auto intro: HPhase1or2Write_HInv4c,
        auto simp add: Phase1or2Read_def
             intro: HPhase1or2ReadThen_HInv4c
                    HPhase1or2ReadElse_HInv4c,
        auto simp add: EndPhase1or2_def
             intro: HEndPhase1_HInv4c
                    HEndPhase2_HInv4c,
        auto intro: HFail_HInv4c,
        auto intro: HEndPhase0_HInv4c simp add: HInv1_def)
   show "HInv4d s' p " using assms
     by(auto simp add: HInv4_def HNext_def Next_def,
        auto simp add: HInv2_def
             intro: HStartBallot_HInv4d,
        auto intro: HPhase0Read_HInv4d,
        auto intro: HPhase1or2Write_HInv4d,
        auto simp add: Phase1or2Read_def
             intro: HPhase1or2ReadThen_HInv4d
                    HPhase1or2ReadElse_HInv4d,
        auto simp add: EndPhase1or2_def
             intro: HEndPhase1_HInv4d
                    HEndPhase2_HInv4d,
        auto intro: HFail_HInv4d,
        auto intro: HEndPhase0_HInv4d simp add: HInv1_def)
qed

end


theory NominalExample imports Main Nominal2 "../Launchbury/Nominal-Utils" begin

atom_decl var

term permute
thm supp_def
thm fresh_def
find_theorems fresh permute
thm Abs1_eq_iff(3)

nominal_datatype exp =
  Const int
| Var var
| Ass v::var i::int body::exp  binds v in body

lemma "Ass a 0 (Var a) = Ass b 0 (Var b)" by auto

nominal_primrec eval :: "(var \<times> int) list \<Rightarrow> exp \<Rightarrow> int" where
  "eval _ (Const i) = i" |
  "eval l (Var v) = (case map_of l v of Some i \<Rightarrow> i | None \<Rightarrow> 0)" |
  "atom v \<sharp> l \<Longrightarrow> eval l (Ass v i b) = eval ((v,i)#l) b"
unfolding eqvt_def eval_graph_aux_def
(* Equivariance of the defintion *)
apply (rule, simp)
apply (perm_simp)
(* Invariant (no invariant present *)
apply rule
(* Exhaustiveness *)
apply (case_tac x)
apply (rule_tac y = b and c = a in exp.strong_exhaust)
apply (auto simp add: fresh_star_def fresh_Pair)[3]
(* Well-definedness *)
apply auto[5]
(* Last case very ugly, unfortunately. *)
apply (auto simp add: Abs1_eq_iff fresh_Pair)
apply (drule_tac p = "(v \<leftrightarrow> va)" in eqvt_at_apply')
apply (auto simp add: permute_pure fresh_Pair fresh_perm flip_fresh_fresh)
done

termination (eqvt) by lexicographic_order
thm eval.induct[no_vars]

inductive all_zeros where
  AZConst: "all_zeros (Const 0)" |
  AZVar: "all_zeros (Var n)" |
  AZAss: "all_zeros e \<Longrightarrow> all_zeros (Ass v 0 e)"

equivariance all_zeros

nominal_inductive all_zeros avoids AZAss: "v"
  by (auto simp add: fresh_star_def fresh_Pair pure_fresh)

lemma "all_zeros e \<Longrightarrow> ran (map_of l) \<subseteq> {0} \<Longrightarrow> eval l e = 0"
proof (induct arbitrary: l rule: all_zeros.induct)
  case AZConst
  show "eval l (Const 0) = 0" by auto
next
  case (AZVar n)
  thus "eval l (Var n) = 0" by (auto split:option.splits simp add: ran_def)
next
  case (AZAss e v)
    obtain v'::var where "atom v' \<sharp> l" and "atom v' \<sharp> v" by (metis obtain_fresh fresh_Pair)
    from `ran (map_of l) \<subseteq> {0}`
    have "ran (map_of ((v,0)#l)) \<subseteq> {0}" by (auto simp add: ran_def)
    hence "eval ((v, 0) # l) e = 0" by (rule AZAss.hyps)
    thus "eval l (Ass v 0 e) = 0"
      (* Need "atom v \<sharp> l" to proceed, but that is not guaranteed! *)
oops

thm all_zeros.induct all_zeros.strong_induct

lemma "all_zeros e \<Longrightarrow> ran (map_of l) \<subseteq> {0} \<Longrightarrow> eval l e = 0"
proof (nominal_induct avoiding: l rule: all_zeros.strong_induct)
  case AZConst
  show "eval l (Const 0) = 0" by auto
next
  case (AZVar n)
  thus "eval l (Var n) = 0" by (auto split:option.splits simp add: ran_def)
next
  case (AZAss e v)
    from `ran (map_of l) \<subseteq> {0}`
    have "ran (map_of ((v,0)#l)) \<subseteq> {0}" by (auto simp add: ran_def)
    hence "eval ((v, 0) # l) e = 0" by (rule AZAss.hyps)
    thus "eval l (Ass v 0 e) = 0" using `atom v \<sharp> l` by simp
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_bin_plus_comm
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

theorem property0 :
  "((plus x y) = (plus y x))"
  oops

end


header {* The direct sum of modules. *}

theory SumSpaces
imports Main
  "~~/src/HOL/Algebra/Module"
  "~~/src/HOL/Algebra/Coset"
  RingModuleFacts
  MonoidSums
  FunctionLemmas
  LinearCombinations
begin

text {* We define the direct sum $M_1\oplus M_2$ of 2 vector spaces as the set $M_1\times M_2$ under
componentwise addition and scalar multiplication.*}
definition direct_sum:: "('a,'b, 'd) module_scheme \<Rightarrow> ('a, 'c, 'e) module_scheme \<Rightarrow>('a, ('b\<times>'c)) module" (*(infixl "(\<oplus>)" 50)*)
  where  "direct_sum M1 M2 = \<lparr>carrier = carrier M1 \<times> carrier M2,
                  mult = (\<lambda> v w. (\<zero>\<^bsub>M1\<^esub>, \<zero>\<^bsub>M2\<^esub>)),
                  one =  (\<zero>\<^bsub>M1\<^esub>, \<zero>\<^bsub>M2\<^esub>),
                  zero = (\<zero>\<^bsub>M1\<^esub>, \<zero>\<^bsub>M2\<^esub>),
                  add = (\<lambda> v w. (fst v \<oplus>\<^bsub>M1\<^esub> fst w, snd v \<oplus>\<^bsub>M2\<^esub> snd w)),
                  smult = (\<lambda> c v. (c \<odot>\<^bsub>M1\<^esub> fst v, c \<odot>\<^bsub>M2\<^esub> snd v))\<rparr>"

lemma direct_sum_is_module:
  fixes R M1 M2
  assumes h1: "module R M1" and h2: "module R M2"
  shows "module R (direct_sum M1 M2)"
proof -
  from h1 have 1: "cring R" by (unfold module_def, auto)
  from h1 interpret v1: module R M1 by auto
  from h2 interpret v2: module R M2 by auto
  from h1 h2 have 2: "abelian_group (direct_sum M1 M2)"
    apply (intro abelian_groupI, auto)
         apply (unfold direct_sum_def, auto)
       by (auto simp add: v1.a_ac v2.a_ac)
  from h1 h2 assms have 3: "module_axioms R (direct_sum M1 M2)"
    apply (unfold module_axioms_def, auto)
        apply (unfold direct_sum_def, auto)
         by (auto simp add: v1.smult_l_distr v2.smult_l_distr v1.smult_r_distr v2.smult_r_distr
      v1.smult_assoc1 v2.smult_assoc1)
  from 1 2 3  show ?thesis by (unfold module_def, auto)
qed

definition inj1:: "('a,'b) module \<Rightarrow> ('a, 'c) module \<Rightarrow>('b\<Rightarrow>('b\<times>'c))"
  where "inj1 M1 M2 = (\<lambda>v. (v, \<zero>\<^bsub>M2\<^esub>))"

definition inj2:: "('a,'b) module \<Rightarrow> ('a, 'c) module \<Rightarrow>('c\<Rightarrow>('b\<times>'c))"
  where "inj2 M1 M2 = (\<lambda>v. (\<zero>\<^bsub>M1\<^esub>, v))"

lemma inj1_hom:
  fixes R M1 M2
  assumes h1: "module R M1" and h2: "module R M2"
  shows "mod_hom R M1 (direct_sum M1 M2) (inj1 M1 M2)"
proof -
  from h1 interpret v1:module R M1 by auto
  from h2 interpret v2:module R M2 by auto
  from h1 h2 show ?thesis
    apply (unfold mod_hom_def module_hom_def mod_hom_axioms_def inj1_def, auto)
       apply (rule direct_sum_is_module, auto)
      by (unfold direct_sum_def, auto)
qed

lemma inj2_hom:
  fixes R M1 M2
  assumes h1: "module R M1" and h2: "module R M2"
  shows "mod_hom R M2 (direct_sum M1 M2) (inj2 M1 M2)"
proof -
  from h1 interpret v1:module R M1 by auto
  from h2 interpret v2:module R M2 by auto
  from h1 h2 show ?thesis
    apply (unfold mod_hom_def module_hom_def mod_hom_axioms_def inj2_def, auto)
       apply (rule direct_sum_is_module, auto)
      by (unfold direct_sum_def, auto)
qed

text {*For submodules $M_1,M_2\subseteq M$, the map $M_1\oplus M_2\to M$ given by $(m_1,m_2)\mapsto
m_1+m_2$ is linear.*}
lemma (in module) sum_map_hom:
  fixes M1 M2
  assumes h1: "submodule R M1 M" and h2: "submodule R M2 M"
  shows "mod_hom R (direct_sum (md M1) (md M2)) M (\<lambda> v. (fst v) \<oplus>\<^bsub>M\<^esub> (snd v))"
proof -
  have 0: "module R M"..
  from h1 have 1: "module R (md M1)" by (rule submodule_is_module)
  from h2 have 2: "module R (md M2)" by (rule submodule_is_module)
  from h1 interpret w1: module R "(md M1)" by (rule submodule_is_module)
  from h2 interpret w2: module R "(md M2)" by (rule submodule_is_module)
  from 0 h1 h2 1 2 show ?thesis
    apply (unfold mod_hom_def mod_hom_axioms_def module_hom_def, auto)
       apply (rule direct_sum_is_module, auto)
      apply (unfold direct_sum_def, auto)
      apply (unfold submodule_def, auto)
     by (auto simp add: a_ac smult_r_distr ring_subset_carrier)
      (*key is a_ac, permutative rewrite rule*)
qed

lemma (in module) sum_is_submodule:
  fixes N1 N2
  assumes h1: "submodule R N1 M" and h2: "submodule R N2 M"
  shows "submodule R (submodule_sum N1 N2) M"
proof -
  from h1 h2 interpret l: mod_hom R "(direct_sum (md N1) (md N2))" M "(\<lambda> v. (fst v) \<oplus>\<^bsub>M\<^esub> (snd v))"
    by (rule sum_map_hom)
  have 1: "l.im =submodule_sum N1 N2"
    apply (unfold l.im_def submodule_sum_def)
    apply (unfold direct_sum_def, auto)
    by (unfold image_def, auto)
  have 2: "submodule R (l.im) M" by (rule l.im_is_submodule)
  from 1 2 show ?thesis by auto
qed

lemma (in module) in_sum:
  fixes N1 N2
  assumes h1: "submodule R N1 M" and h2: "submodule R N2 M"
  shows "N1 \<subseteq> submodule_sum N1 N2"
proof -
  from h1 h2 show ?thesis
    apply auto
    apply (unfold submodule_sum_def image_def, auto)
    apply (rename_tac v)
    apply (rule_tac x="v" in bexI)
     apply (rule_tac x="\<zero>\<^bsub>M\<^esub>" in bexI)
      by (unfold submodule_def, auto)
qed

lemma (in module) msum_comm:
  fixes N1 N2
  assumes h1: "submodule R N1 M" and h2: "submodule R N2 M"
  shows "(submodule_sum N1 N2) = (submodule_sum N2 N1)"
proof -
  (*have 0: "module R M"..*)
  from h1 h2 show ?thesis
    apply (unfold submodule_sum_def image_def, auto)
     apply (unfold submodule_def)
     apply (rename_tac v w)
     by (metis (full_types) M.add.m_comm subsetD)+
    (* Alternatively, apply (rule_tac x="w" in bexI, rule_tac x="v" in bexI,
      auto simp add: ring_subset_carrier M.a_ac)+ *)
qed

text {*If $M_1,M_2\subseteq M$ are submodules, then $M_1+M_2$ is the minimal subspace such that
both $M_1\subseteq M$ and $M_2\subseteq M$.*}
lemma (in module) sum_is_minimal:
  fixes N N1 N2
  assumes h1: "submodule R N1 M" and h2: "submodule R N2 M" and h3: "submodule R N M"
  shows "(submodule_sum N1 N2) \<subseteq> N \<longleftrightarrow> N1 \<subseteq> N \<and> N2 \<subseteq> N"
proof -
  have 1: "(submodule_sum N1 N2) \<subseteq> N \<Longrightarrow> N1 \<subseteq> N \<and> N2 \<subseteq> N"
  proof -
    assume 10: "(submodule_sum N1 N2) \<subseteq> N"
    from h1 h2 have 11: "N1\<subseteq>submodule_sum N1 N2" by (rule in_sum)
    from h2 h1 have 12: "N2\<subseteq>submodule_sum N2 N1" by (rule in_sum)
    from 12 h1 h2 have 13: "N2\<subseteq>submodule_sum N1 N2" by (metis msum_comm)
    from 10 11 13 show ?thesis by auto
  qed
  have 2: "N1 \<subseteq> N \<and> N2 \<subseteq> N \<Longrightarrow> (submodule_sum N1 N2) \<subseteq> N"
  proof -
    assume 19: "N1 \<subseteq> N \<and> N2 \<subseteq> N"
    {
    fix v
    assume 20: "v\<in>submodule_sum N1 N2"
    from 20 obtain w1 w2 where 21: "w1\<in>N1" and 22: "w2\<in>N2" and 23: "v=w1\<oplus>\<^bsub>M\<^esub> w2"
      by (unfold submodule_sum_def image_def, auto)
    from 19 21 22 23 h3 have "v \<in> N"
      apply (unfold submodule_def, auto)
      by (metis (poly_guards_query)  contra_subsetD)
(*how is an obtain goal rep'd?*)
    }
    thus ?thesis
      by (metis subset_iff)
  qed
  from 1 2 show ?thesis by metis
qed

text {* $\text{span} A\cup B = \text{span} A + \text{span} B$*}
lemma (in module) span_union_is_sum:
  fixes A B
  assumes  h2: "A\<subseteq>carrier M" and h3: "B\<subseteq>carrier M"
  shows "span (A\<union> B) = submodule_sum (span A) (span B)"
proof-
  let ?AplusB="submodule_sum (span A) (span B)"
  from  h2 have s0: "submodule R (span A) M" by (rule span_is_submodule)
  from  h3 have s1: "submodule R (span B) M" by (rule span_is_submodule)
  from s0 have s0_1: "(span A)\<subseteq>carrier M" by (unfold submodule_def, auto)
  from s1 have s1_1: "(span B)\<subseteq>carrier M" by (unfold submodule_def, auto)
  from h2 h3 have 1: "A\<union>B\<subseteq>carrier M" by auto
  from  1 have 2: "submodule R (span (A\<union>B)) M" by (rule span_is_submodule)
  from s0 s1 have 3: "submodule R ?AplusB M" by (rule sum_is_submodule)
  have c1: "span (A\<union>B) \<subseteq> ?AplusB"
(*span(A\<union>B) \<subseteq> span(A) + span(B) *)
  proof -
    from  h2 have a1: "A\<subseteq>span A" by (rule in_own_span)
    from s0 s1 have a2: "span A \<subseteq> ?AplusB" by (rule in_sum) (*M\<subseteq>M+N*)
    from a1 a2 have a3: "A\<subseteq> ?AplusB" by auto
    (*similarly*)
    from  h3 have b1: "B\<subseteq>span B" by (rule in_own_span)
    from s1 s0 have b2: "span B \<subseteq> ?AplusB" by (metis in_sum msum_comm) (*M\<subseteq>M+N*)
    from b1 b2 have b3: "B\<subseteq> ?AplusB" by auto
    from a3 b3 have 5: "A\<union>B\<subseteq> ?AplusB" by auto
      (*by default simp *)
    from 5 3 show ?thesis by (rule span_is_subset)
  qed
  have c2: "?AplusB \<subseteq> span (A\<union>B)"
  proof -
    have 11: "A\<subseteq>A\<union>B" by auto
    have 12: "B\<subseteq>A\<union>B" by auto
    from  11 have 21:"span A \<subseteq>span (A\<union>B)" by (rule span_is_monotone)
    from  12 have 22:"span B \<subseteq>span (A\<union>B)" by (rule span_is_monotone)
    from s0 s1 2 21 22 show ?thesis by (auto simp add: sum_is_minimal)
  qed
  from c1 c2 show ?thesis by auto
qed

end


(*  Title       : NSPrimes.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 2002 University of Edinburgh
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section \<open>The Nonstandard Primes as an Extension of the Prime Numbers\<close>

theory NSPrimes
  imports "HOL-Computational_Algebra.Primes" "HOL-Nonstandard_Analysis.Hyperreal"
begin

text \<open>These can be used to derive an alternative proof of the infinitude of
primes by considering a property of nonstandard sets.\<close>

definition starprime :: "hypnat set"
  where [transfer_unfold]: "starprime = *s* {p. prime p}"

definition choicefun :: "'a set \<Rightarrow> 'a"
  where "choicefun E = (SOME x. \<exists>X \<in> Pow E - {{}}. x \<in> X)"

primrec injf_max :: "nat \<Rightarrow> 'a::order set \<Rightarrow> 'a"
where
  injf_max_zero: "injf_max 0 E = choicefun E"
| injf_max_Suc: "injf_max (Suc n) E = choicefun ({e. e \<in> E \<and> injf_max n E < e})"

lemma dvd_by_all2: "\<exists>N>0. \<forall>m. 0 < m \<and> m \<le> M \<longrightarrow> m dvd N"
  for M :: nat
proof (induct M)
  case 0
  then show ?case
    by auto
next
  case (Suc M)
  then obtain N where "N>0" and "\<And>m. 0 < m \<and> m \<le> M \<Longrightarrow> m dvd N"
    by metis
  then show ?case
    by (metis nat_0_less_mult_iff zero_less_Suc dvd_mult dvd_mult2 dvd_refl le_Suc_eq)
qed

lemma dvd_by_all: "\<forall>M::nat. \<exists>N>0. \<forall>m. 0 < m \<and> m \<le> M \<longrightarrow> m dvd N"
  using dvd_by_all2 by blast

lemma hypnat_of_nat_le_zero_iff [simp]: "hypnat_of_nat n \<le> 0 \<longleftrightarrow> n = 0"
  by transfer simp

text \<open>Goldblatt: Exercise 5.11(2) -- p. 57.\<close>
lemma hdvd_by_all [rule_format]: "\<forall>M. \<exists>N. 0 < N \<and> (\<forall>m::hypnat. 0 < m \<and> m \<le> M \<longrightarrow> m dvd N)"
  by transfer (rule dvd_by_all)

text \<open>Goldblatt: Exercise 5.11(2) -- p. 57.\<close>
lemma hypnat_dvd_all_hypnat_of_nat:
  "\<exists>N::hypnat. 0 < N \<and> (\<forall>n \<in> - {0::nat}. hypnat_of_nat n dvd N)"
  by (metis Compl_iff gr0I hdvd_by_all hypnat_of_nat_le_whn singletonI star_of_0_less)

text \<open>The nonstandard extension of the set prime numbers consists of precisely
  those hypernaturals exceeding 1 that have no nontrivial factors.\<close>

text \<open>Goldblatt: Exercise 5.11(3a) -- p 57.\<close>
lemma starprime: "starprime = {p. 1 < p \<and> (\<forall>m. m dvd p \<longrightarrow> m = 1 \<or> m = p)}"
  by transfer (auto simp add: prime_nat_iff)

text \<open>Goldblatt Exercise 5.11(3b) -- p 57.\<close>
lemma hyperprime_factor_exists: "\<And>n. 1 < n \<Longrightarrow> \<exists>k \<in> starprime. k dvd n"
  by transfer (simp add: prime_factor_nat)

text \<open>Goldblatt Exercise 3.10(1) -- p. 29.\<close>
lemma NatStar_hypnat_of_nat: "finite A \<Longrightarrow> *s* A = hypnat_of_nat ` A"
  by (rule starset_finite)

subsection \<open>An injective function cannot define an embedded natural number\<close>

lemma lemma_infinite_set_singleton:
  "\<forall>m n. m \<noteq> n \<longrightarrow> f n \<noteq> f m \<Longrightarrow> {n. f n = N} = {} \<or> (\<exists>m. {n. f n = N} = {m})"
  by (metis (mono_tags) is_singletonI' is_singleton_the_elem mem_Collect_eq)

lemma inj_fun_not_hypnat_in_SHNat:
  fixes f :: "nat \<Rightarrow> nat"
  assumes inj_f: "inj f"
  shows "starfun f whn \<notin> Nats"
proof
  from inj_f have inj_f': "inj (starfun f)"
    by (transfer inj_on_def Ball_def UNIV_def)
  assume "starfun f whn \<in> Nats"
  then obtain N where N: "starfun f whn = hypnat_of_nat N"
    by (auto simp: Nats_def)
  then have "\<exists>n. starfun f n = hypnat_of_nat N" ..
  then have "\<exists>n. f n = N" by transfer
  then obtain n where "f n = N" ..
  then have "starfun f (hypnat_of_nat n) = hypnat_of_nat N"
    by transfer
  with N have "starfun f whn = starfun f (hypnat_of_nat n)"
    by simp
  with inj_f' have "whn = hypnat_of_nat n"
    by (rule injD)
  then show False
    by (simp add: whn_neq_hypnat_of_nat)
qed

lemma range_subset_mem_starsetNat: "range f \<subseteq> A \<Longrightarrow> starfun f whn \<in> *s* A"
  by (metis STAR_subset_closed UNIV_I image_eqI starset_UNIV starset_image)

text \<open>
  Gleason Proposition 11-5.5. pg 149, pg 155 (ex. 3) and pg. 360.

  Let \<open>E\<close> be a nonvoid ordered set with no maximal elements (note: effectively an
  infinite set if we take \<open>E = N\<close> (Nats)). Then there exists an order-preserving
  injection from \<open>N\<close> to \<open>E\<close>. Of course, (as some doofus will undoubtedly point out!
  :-)) can use notion of least element in proof (i.e. no need for choice) if
  dealing with nats as we have well-ordering property.
\<close>

lemma lemmaPow3: "E \<noteq> {} \<Longrightarrow> \<exists>x. \<exists>X \<in> Pow E - {{}}. x \<in> X"
  by auto

lemma choicefun_mem_set [simp]: "E \<noteq> {} \<Longrightarrow> choicefun E \<in> E"
  unfolding choicefun_def
  by (force intro: lemmaPow3 [THEN someI2_ex])

lemma injf_max_mem_set: "E \<noteq>{} \<Longrightarrow> \<forall>x. \<exists>y \<in> E. x < y \<Longrightarrow> injf_max n E \<in> E"
proof (induct n)
  case 0
  then show ?case by force
next
  case (Suc n)
  then show ?case
    apply (simp add: choicefun_def)
    apply (rule lemmaPow3 [THEN someI2_ex], auto)
    done
qed

lemma injf_max_order_preserving: "\<forall>x. \<exists>y \<in> E. x < y \<Longrightarrow> injf_max n E < injf_max (Suc n) E"
  by (metis (no_types, lifting) choicefun_mem_set empty_iff injf_max.simps(2) mem_Collect_eq)

lemma injf_max_order_preserving2:
  assumes "m < n" and E: "\<forall>x. \<exists>y \<in> E. x < y"
  shows  "injf_max m E < injf_max n E"
  using \<open>m < n\<close>
proof (induction n arbitrary: m)
  case 0 then show ?case by auto
next
  case (Suc n)
  then show ?case
    by (metis E injf_max_order_preserving less_Suc_eq order_less_trans)
qed

lemma inj_injf_max: "\<forall>x. \<exists>y \<in> E. x < y \<Longrightarrow> inj (\<lambda>n. injf_max n E)"
  by (metis injf_max_order_preserving2 linorder_injI order_less_irrefl)

lemma infinite_set_has_order_preserving_inj:
  "E \<noteq> {} \<Longrightarrow> \<forall>x. \<exists>y \<in> E. x < y \<Longrightarrow> \<exists>f. range f \<subseteq> E \<and> inj f \<and> (\<forall>m. f m < f (Suc m))"
  for E :: "'a::order set" and f :: "nat \<Rightarrow> 'a"
  by (metis image_subsetI inj_injf_max injf_max_mem_set injf_max_order_preserving)

text \<open>Only need the existence of an injective function from \<open>N\<close> to \<open>A\<close> for proof.\<close>

lemma hypnat_infinite_has_nonstandard:
  assumes "infinite A"
  shows "hypnat_of_nat ` A < ( *s* A)"
  by (metis assms IntE NatStar_hypreal_of_real_Int STAR_star_of_image_subset psubsetI
      infinite_iff_countable_subset inj_fun_not_hypnat_in_SHNat range_subset_mem_starsetNat)

lemma starsetNat_eq_hypnat_of_nat_image_finite: "*s* A =  hypnat_of_nat ` A \<Longrightarrow> finite A"
  by (metis hypnat_infinite_has_nonstandard less_irrefl)

lemma finite_starsetNat_iff: "*s* A = hypnat_of_nat ` A \<longleftrightarrow> finite A"
  by (blast intro!: starsetNat_eq_hypnat_of_nat_image_finite NatStar_hypnat_of_nat)

lemma hypnat_infinite_has_nonstandard_iff: "infinite A \<longleftrightarrow> hypnat_of_nat ` A < *s* A"
  by (metis finite_starsetNat_iff hypnat_infinite_has_nonstandard nless_le)

subsection \<open>Existence of Infinitely Many Primes: a Nonstandard Proof\<close>

lemma lemma_not_dvd_hypnat_one [simp]: "\<exists>n \<in> - {0}. \<not> hypnat_of_nat n dvd 1"
proof -
  have "\<not> hypnat_of_nat 2 dvd 1"
    by transfer auto
  then show ?thesis
    by (metis ComplI singletonD zero_neq_numeral)
qed

lemma hypnat_add_one_gt_one: "\<And>N::hypnat. 0 < N \<Longrightarrow> 1 < N + 1"
  by transfer simp

lemma hypnat_of_nat_zero_not_prime [simp]: "hypnat_of_nat 0 \<notin> starprime"
  by transfer simp

lemma hypnat_zero_not_prime [simp]: "0 \<notin> starprime"
  using hypnat_of_nat_zero_not_prime by simp

lemma hypnat_of_nat_one_not_prime [simp]: "hypnat_of_nat 1 \<notin> starprime"
  by transfer simp

lemma hypnat_one_not_prime [simp]: "1 \<notin> starprime"
  using hypnat_of_nat_one_not_prime by simp

lemma hdvd_diff: "\<And>k m n :: hypnat. k dvd m \<Longrightarrow> k dvd n \<Longrightarrow> k dvd (m - n)"
  by transfer (rule dvd_diff_nat)

lemma hdvd_one_eq_one: "\<And>x::hypnat. is_unit x \<Longrightarrow> x = 1"
  by transfer simp

text \<open>Already proved as \<open>primes_infinite\<close>, but now using non-standard naturals.\<close>
theorem not_finite_prime: "infinite {p::nat. prime p}"
proof -
  obtain N k where N: "\<forall>n\<in>- {0}. hypnat_of_nat n dvd N" "k\<in>starprime" "k dvd N + 1"
    by (meson hyperprime_factor_exists hypnat_add_one_gt_one hypnat_dvd_all_hypnat_of_nat)
  then have "k \<noteq> 1"
    using \<open>k \<in> starprime\<close> by force
  then have "k \<notin> hypnat_of_nat ` {p. prime p}"
    using N dvd_add_right_iff hdvd_one_eq_one not_prime_0 by blast
  then show ?thesis
    by (metis \<open>k \<in> starprime\<close> finite_starsetNat_iff starprime_def)
qed

end