(*  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_Inv2 imports DiskPaxos_Inv1 begin

subsection \<open>Invariant 2\<close>

text \<open>
  The second invariant is split into three main conjuncts called
  $Inv2a$, $Inv2b$, and $Inv2c$. The main difficulty is in proving
  the preservation of the first conjunct.
\<close>

definition rdBy :: "state \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> BlockProc set"
where
  "rdBy s p q d =
    {br . br \<in> blocksRead s q d \<and> proc br = p}"

definition blocksOf :: "state \<Rightarrow> Proc \<Rightarrow> DiskBlock set"
where
  "blocksOf s p =
      {dblock s p}
   \<union> {disk s d p | d . d \<in> UNIV}
   \<union> {block br | br . br \<in> (UN q d. rdBy s p q d) }"

definition allBlocks :: "state \<Rightarrow> DiskBlock set"
  where "allBlocks s = (UN p. blocksOf s p)"

definition Inv2a_innermost :: "state \<Rightarrow> Proc \<Rightarrow> DiskBlock \<Rightarrow> bool"
where
  "Inv2a_innermost s p bk =
    (mbal bk \<in> (Ballot p) \<union> {0}
   \<and> bal bk \<in> (Ballot p) \<union> {0}
   \<and> (bal bk = 0) = (inp bk = NotAnInput)
   \<and> bal bk \<le> mbal bk
   \<and> inp bk \<in> (allInput s) \<union> {NotAnInput})"

definition Inv2a_inner :: "state \<Rightarrow> Proc \<Rightarrow> bool"
  where "Inv2a_inner s p = (\<forall>bk \<in> blocksOf s p. Inv2a_innermost  s p bk)"

definition Inv2a :: "state \<Rightarrow> bool"
  where "Inv2a s = (\<forall>p. Inv2a_inner s p)"

definition Inv2b_inner :: "state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
where
  "Inv2b_inner s p d =
     ((d \<in> disksWritten s p \<longrightarrow>
        (phase s p \<in> {1,2} \<and> disk s d p = dblock s p))
   \<and> (phase s p \<in> {1,2} \<longrightarrow>
        (  (blocksRead s p d \<noteq> {} \<longrightarrow> d \<in> disksWritten s p)
         \<and> \<not> hasRead s p d p)))"

definition Inv2b :: "state \<Rightarrow> bool"
  where "Inv2b s = (\<forall>p d. Inv2b_inner s p d)"

definition Inv2c_inner :: "state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "Inv2c_inner s p =
    ((phase s p = 0 \<longrightarrow>
       (  dblock s p = InitDB
        \<and> disksWritten s p = {}
        \<and> (\<forall> d. \<forall> br \<in> blocksRead s p d.
              proc br = p \<and> block br = disk s d p)))
   \<and> (phase s p \<noteq> 0 \<longrightarrow>
        (  mbal(dblock s p) \<in> Ballot p
         \<and> bal(dblock s p) \<in> Ballot p \<union> {0}
         \<and> (\<forall> d. \<forall> br \<in> blocksRead s p d.
               mbal(block br) < mbal(dblock s p))))
   \<and> (phase s p \<in> {2,3} \<longrightarrow> bal(dblock s p) = mbal(dblock s p))
   \<and> outpt s p = (if phase s p = 3 then inp(dblock s p) else NotAnInput)
   \<and> chosen s \<in> allInput s \<union> {NotAnInput}
   \<and> (\<forall>p.   inpt s p \<in> allInput s
          \<and> (chosen s = NotAnInput \<longrightarrow> outpt s p = NotAnInput)))"

definition Inv2c :: "state \<Rightarrow> bool"
  where "Inv2c s = (\<forall>p. Inv2c_inner s p)"

definition HInv2 :: "state \<Rightarrow> bool"
  where "HInv2 s = (Inv2a s \<and> Inv2b s \<and> Inv2c s)"

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

theorem HInit_Inv2a: "HInit s \<longrightarrow> Inv2a s"
by (auto simp add: HInit_def Init_def Inv2a_def Inv2a_inner_def
                   Inv2a_innermost_def rdBy_def blocksOf_def
                   InitDB_def)

text\<open>
  For every action we define a action-$blocksOf$ lemma. We have two cases: either
the new $blocksOf$ is included in the old $blocksOf$, or the new $blocksOf$ is included
in the old $blocksOf$ union the new $dblock$. In the former case the assumption $inv$ will
imply the thesis. In the latter, we just have to prove the innermost predicate for
the particular case of the new $dblock$.
This particular case is proved in lemma action-$Inv2a$-$dblock$.
\<close>

lemma HPhase1or2ReadThen_blocksOf:
  "\<lbrakk> HPhase1or2ReadThen s s' p d q \<rbrakk> \<Longrightarrow> blocksOf s' r \<subseteq> blocksOf s r"
  by(auto simp add: Phase1or2ReadThen_def blocksOf_def rdBy_def)

theorem HPhase1or2ReadThen_Inv2a:
  assumes inv: "Inv2a s"
  and act: "HPhase1or2ReadThen s s' p d q"
  shows "Inv2a s'"
proof (clarsimp simp add: Inv2a_def Inv2a_inner_def)
  fix pp bk
  assume bk: "bk \<in> blocksOf s' pp"
  with inv HPhase1or2ReadThen_blocksOf[OF act]
  have "Inv2a_innermost s pp bk"
    by(auto simp add: Inv2a_def Inv2a_inner_def)
  with act
  show "Inv2a_innermost s' pp bk"
    by(auto simp add: Inv2a_innermost_def HNextPart_def)
qed

lemma InitializePhase_rdBy:
  "InitializePhase s s' p \<Longrightarrow> rdBy s' pp qq dd \<subseteq> rdBy s pp qq dd"
by(auto simp add: InitializePhase_def rdBy_def)

lemma HStartBallot_blocksOf:
  "HStartBallot s s' p \<Longrightarrow> blocksOf s' q \<subseteq> blocksOf s q \<union> {dblock s' q}"
by(auto simp add: StartBallot_def blocksOf_def
         dest: subsetD[OF InitializePhase_rdBy])

lemma HStartBallot_Inv2a_dblock:
  assumes act: "HStartBallot s s' p"
  and inv2a: "Inv2a_innermost s p (dblock s p)"
  shows "Inv2a_innermost s' p (dblock s' p)"
proof -
  from act
  have mbal': "mbal (dblock s' p) \<in> Ballot p"
    by(auto simp add: StartBallot_def)
  from act
  have bal': "bal (dblock s' p) = bal (dblock s p)"
    by(auto simp add: StartBallot_def)
  with act
  have inp': "inp (dblock s' p) = inp (dblock s p)"
    by(auto simp add: StartBallot_def)
  from act
  have "mbal (dblock s p) \<le> mbal (dblock s' p)"
     by(auto simp add: StartBallot_def)
  with bal' inv2a
  have bal_mbal: "bal (dblock s' p) \<le> mbal (dblock s' p)"
    by(auto simp add: Inv2a_innermost_def)
  from act
  have "allInput s \<subseteq> allInput s'"
    by(auto simp add: HNextPart_def)
  with mbal' bal' inp' bal_mbal act inv2a
  show ?thesis
  by(auto simp add: Inv2a_innermost_def)
qed

lemma HStartBallot_Inv2a_dblock_q:
  assumes act: "HStartBallot s s' p"
  and inv2a: "Inv2a_innermost s q (dblock s q)"
  shows "Inv2a_innermost s' q (dblock s' q)"
proof(cases "p=q")
  case True
  with act inv2a
  show ?thesis
    by(blast dest: HStartBallot_Inv2a_dblock)
next
  case False
  with act inv2a
  show ?thesis
    by(clarsimp simp add: StartBallot_def HNextPart_def
      InitializePhase_def Inv2a_innermost_def)
qed

theorem HStartBallot_Inv2a:
  assumes inv: "Inv2a s"
  and act: "HStartBallot s s' p"
  shows "Inv2a s'"
proof (clarsimp simp add: Inv2a_def Inv2a_inner_def)
  fix q bk
  assume bk: "bk \<in> blocksOf s' q"
  with inv
  have oldBlks: "bk \<in> blocksOf s q \<longrightarrow> Inv2a_innermost s q bk"
    by(auto simp add: Inv2a_def Inv2a_inner_def)
  from bk HStartBallot_blocksOf[OF act]
  have "bk \<in> {dblock s' q} \<union> blocksOf s q"
    by blast
  thus "Inv2a_innermost s' q bk"
  proof
    assume bk_dblock: "bk \<in> {dblock s' q}"
    from inv
    have inv_q_dblock: "Inv2a_innermost s q (dblock s q)"
      by(auto simp add: Inv2a_def Inv2a_inner_def Inv2a_innermost_def blocksOf_def)
    with act inv bk_dblock
    show ?thesis
      by(blast dest: HStartBallot_Inv2a_dblock_q)
  next
    assume bk_in_blocks: "bk \<in> blocksOf s q"
    with oldBlks
    have "Inv2a_innermost s q bk" ..
    with act
    show ?thesis
      by(auto simp add: StartBallot_def HNextPart_def
                        InitializePhase_def Inv2a_innermost_def)
  qed
qed

lemma HPhase1or2Write_blocksOf:
  "\<lbrakk> HPhase1or2Write s s' p d \<rbrakk> \<Longrightarrow> blocksOf s' r \<subseteq> blocksOf s r"
  by(auto simp add: Phase1or2Write_def blocksOf_def rdBy_def)

theorem HPhase1or2Write_Inv2a:
  assumes inv: "Inv2a s"
  and     act: "HPhase1or2Write s s' p d"
  shows "Inv2a s'"
proof(clarsimp simp add: Inv2a_def Inv2a_inner_def)
  fix q bk
  assume bk: "bk \<in> blocksOf s' q"
  from inv bk HPhase1or2Write_blocksOf[OF act]
  have inp_q_bk: "Inv2a_innermost s q bk"
    by(auto simp add: Inv2a_def Inv2a_inner_def)
  with act
  show "Inv2a_innermost s' q bk"
    by(auto simp add: Inv2a_innermost_def HNextPart_def)
qed

theorem HPhase1or2ReadElse_Inv2a:
  assumes inv: "Inv2a s"
  and act:     "HPhase1or2ReadElse s s' p d q"
  shows "Inv2a s'"
proof -
  from act
  have "HStartBallot s s' p"
    by(simp add: Phase1or2ReadElse_def)
  with inv
  show ?thesis
    by(auto elim: HStartBallot_Inv2a)
qed

lemma HEndPhase2_blocksOf:
  "\<lbrakk> HEndPhase2 s s' p \<rbrakk> \<Longrightarrow> blocksOf s' q \<subseteq> blocksOf s q"
  by(auto simp add: EndPhase2_def blocksOf_def
               dest: subsetD[OF InitializePhase_rdBy])

theorem HEndPhase2_Inv2a:
  assumes inv: "Inv2a s"
  and     act: "HEndPhase2 s s' p"
  shows        "Inv2a s'"
proof(clarsimp simp add: Inv2a_def Inv2a_inner_def)
  fix q bk
  assume bk: "bk \<in> blocksOf s' q"
  from inv bk HEndPhase2_blocksOf[OF act]
  have inp_q_bk: "Inv2a_innermost s q bk"
    by(auto simp add: Inv2a_def Inv2a_inner_def)
  with act
  show "Inv2a_innermost s' q bk"
    by(auto simp add: Inv2a_innermost_def HNextPart_def)
qed

lemma HFail_blocksOf:
   "HFail s s' p  \<Longrightarrow> blocksOf s' q \<subseteq> blocksOf s q \<union> {dblock s' q}"
by(auto simp add: Fail_def blocksOf_def
        dest: subsetD[OF InitializePhase_rdBy])

lemma HFail_Inv2a_dblock_q:
  assumes act: "HFail s s' p"
  and     inv: "Inv2a_innermost s q (dblock s q)"
  shows "Inv2a_innermost s' q (dblock s' q)"
proof(cases "p=q")
  case True
  with act
  have "dblock s' q = InitDB"
    by (simp add: Fail_def)
  with True
  show ?thesis
    by(auto simp add: InitDB_def Inv2a_innermost_def)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: Fail_def HNextPart_def
      InitializePhase_def Inv2a_innermost_def)
qed

theorem HFail_Inv2a:
 assumes inv: "Inv2a s"
  and     act: "HFail s s' p"
  shows        "Inv2a s'"
proof(clarsimp simp add: Inv2a_def Inv2a_inner_def)
  fix q bk
  assume bk: "bk \<in> blocksOf s' q"
  with HFail_blocksOf[OF act]
  have dblock_blocks: "bk \<in> {dblock s' q} \<union> blocksOf s q"
    by blast
  thus "Inv2a_innermost s' q bk"
  proof
    assume bk_dblock: "bk \<in> {dblock s' q}"
    from inv
    have inv_q_dblock: "Inv2a_innermost s q (dblock s q)"
      by(auto simp add: Inv2a_def Inv2a_inner_def Inv2a_innermost_def blocksOf_def)
    with act bk_dblock
    show ?thesis
      by(blast dest: HFail_Inv2a_dblock_q)
  next
    assume bk_in_blocks: "bk \<in> blocksOf s q"
    with inv
    have "Inv2a_innermost s q bk"
      by (auto simp add: Inv2a_def Inv2a_inner_def)
    with act
    show ?thesis
      by(auto simp add: Fail_def HNextPart_def
        InitializePhase_def Inv2a_innermost_def)
  qed
qed

lemma HPhase0Read_blocksOf:
  "HPhase0Read s s' p d \<Longrightarrow> blocksOf s' q \<subseteq> blocksOf s q"
  by(auto simp add: Phase0Read_def InitializePhase_def
                       blocksOf_def rdBy_def)

theorem HPhase0Read_Inv2a:
  assumes inv: "Inv2a s"
  and     act: "HPhase0Read s s' p d"
  shows        "Inv2a s'"
proof(clarsimp simp add: Inv2a_def Inv2a_inner_def)
  fix q bk
  assume bk: "bk \<in> blocksOf s' q"
  from inv bk HPhase0Read_blocksOf[OF act]
  have inp_q_bk: "Inv2a_innermost s q bk"
    by(auto simp add: Inv2a_def Inv2a_inner_def)
  with act
  show "Inv2a_innermost s' q bk"
    by(auto simp add: Inv2a_innermost_def HNextPart_def)
qed

lemma HEndPhase0_blocksOf:
  " HEndPhase0 s s' p \<Longrightarrow> blocksOf s' q \<subseteq> blocksOf s q \<union> {dblock s' q}"
  by(auto simp add: EndPhase0_def blocksOf_def
                  dest: subsetD[OF InitializePhase_rdBy])

lemma HEndPhase0_blocksRead:
  assumes act: "HEndPhase0 s s' p"
  shows "\<exists>d. blocksRead s p d \<noteq> {}"
proof -
  from act
  have "IsMajority({d. hasRead s p d p})" by(simp add: EndPhase0_def)
  hence "{d. hasRead s p d p} \<noteq> {}" by (rule majority_nonempty)
  thus ?thesis
    by(auto simp add: hasRead_def)
qed

text \<open>$EndPhase0$ has the additional difficulty of having a choose expression. We
prove that there exists an $x$ such that the predicate of the choose expression holds,
and then apply $someI$: @{thm someI}.
\<close>

lemma HEndPhase0_some:
  assumes act:  "HEndPhase0 s s' p"
  and    inv1:  "Inv1 s"
  shows  "(SOME b.    b \<in> allBlocksRead s p
                   \<and> (\<forall>t\<in>allBlocksRead s p. bal t \<le> bal b)
          ) \<in> allBlocksRead s p
        \<and> (\<forall>t\<in>allBlocksRead s p.
             bal t \<le> bal (SOME b.    b \<in> allBlocksRead s p
                                  \<and> (\<forall>t\<in>allBlocksRead s p. bal t \<le> bal b)))"
proof -
  from inv1 have "finite (bal ` allBlocksRead s p)" (is "finite ?S")
    by(simp add: Inv1_def allBlocksRead_def)
  moreover
  from HEndPhase0_blocksRead[OF act]
  have "?S \<noteq> {}"
    by(auto simp add: allBlocksRead_def allRdBlks_def)
  ultimately
  have "Max ?S \<in> ?S" and "\<forall>t \<in> ?S. t \<le> Max ?S" by auto
  hence "\<exists>r \<in> ?S. \<forall>t \<in> ?S. t \<le> r" ..
  then obtain mblk
    where "   mblk \<in> allBlocksRead s p
           \<and> (\<forall>t \<in> allBlocksRead s p. bal t \<le> bal mblk)" (is "?P mblk")
    by auto
  thus ?thesis
    by (rule someI)
qed

lemma HEndPhase0_dblock_allBlocksRead:
  assumes act:  "HEndPhase0 s s' p"
  and    inv1:  "Inv1 s"
  shows   "dblock s' p \<in> (\<lambda>x. x \<lparr>mbal:= mbal(dblock s' p)\<rparr>) ` allBlocksRead s p"
using act HEndPhase0_some[OF act inv1]
    by(auto simp add: EndPhase0_def)

lemma HNextPart_allInput_or_NotAnInput:
  assumes act: "HNextPart s s'"
  and inv2a: "Inv2a_innermost s p (dblock s' p)"
  shows "inp (dblock s' p) \<in> allInput s' \<union> {NotAnInput}"
 proof -
   from act
   have "allInput s' = allInput s \<union> (range (inpt s'))"
     by(simp add: HNextPart_def)
   moreover
   from inv2a
   have "inp (dblock s' p) \<in> allInput s \<union> {NotAnInput}"
     by(simp add: Inv2a_innermost_def)
   ultimately show ?thesis
     by blast
qed

lemma HEndPhase0_Inv2a_allBlocksRead:
  assumes act: "HEndPhase0 s s' p"
  and inv2a: "Inv2a_inner s p"
  and inv2c: "Inv2c_inner s p"
  shows "\<forall>t \<in> (\<lambda>x. x \<lparr>mbal:= mbal (dblock s' p)\<rparr>) ` allBlocksRead s p.
          Inv2a_innermost s p t"
proof -
  from act
  have mbal': "mbal (dblock s' p) \<in> Ballot p"
    by(auto simp add: EndPhase0_def)
  from inv2c act
  have allproc_p: "\<forall>d. \<forall>br \<in> blocksRead s p d. proc br = p"
    by(simp add: Inv2c_inner_def EndPhase0_def)
  with inv2a
  have allBlocks_inv2a: "\<forall>t \<in> allBlocksRead s p. Inv2a_innermost s p t"
  proof(auto simp add: Inv2a_inner_def allBlocksRead_def
                       allRdBlks_def blocksOf_def rdBy_def)
    fix d bk
    assume bk_in_blocksRead: "bk \<in> blocksRead s p d"
      and inv2a_bk: "\<forall>x\<in>     {u. \<exists>d. u = disk s d p}
                           \<union> {block br |br. (\<exists>q d. br \<in> blocksRead s q d)
                         \<and> proc br = p}. Inv2a_innermost s p x"
    with allproc_p have "proc bk = p"  by auto
    with bk_in_blocksRead inv2a_bk
    show "Inv2a_innermost s p (block bk)" by blast
  qed
  from act
  have mbal'_gt: "\<forall>bk \<in> allBlocksRead s p. mbal bk \<le> mbal (dblock s' p)"
    by(auto simp add: EndPhase0_def)
  with  mbal' allBlocks_inv2a
  show ?thesis
  proof (auto simp add: Inv2a_innermost_def)
    fix t
    assume t_blocksRead: "t \<in> allBlocksRead s p"
    with allBlocks_inv2a
    have "bal t \<le> mbal t" by (auto simp add: Inv2a_innermost_def)
    moreover
    from t_blocksRead mbal'_gt
    have "mbal t \<le> mbal (dblock s' p)" by blast
    ultimately show "bal t \<le> mbal (dblock s' p)"
      by auto
  qed
qed

lemma HEndPhase0_Inv2a_dblock:
  assumes act: "HEndPhase0 s s' p"
  and inv1: "Inv1 s"
  and inv2a: "Inv2a_inner s p"
  and inv2c: "Inv2c_inner s p"
  shows "Inv2a_innermost s' p (dblock s' p)"
proof -
  from act inv2a inv2c
  have t1: "\<forall>t \<in> (\<lambda>x. x \<lparr>mbal:= mbal (dblock s' p)\<rparr>) ` allBlocksRead s p.
                  Inv2a_innermost s p t"
    by(blast dest: HEndPhase0_Inv2a_allBlocksRead)
  from act inv1
  have "dblock s' p \<in> (\<lambda>x. x \<lparr>mbal:= mbal(dblock s' p)\<rparr>) ` allBlocksRead s p"
    by(simp, blast dest: HEndPhase0_dblock_allBlocksRead)
  with t1
  have inv2_dblock: "Inv2a_innermost s p (dblock s' p)" by auto
  with act
  have "inp (dblock s' p) \<in> allInput s' \<union> {NotAnInput}"
    by(auto dest: HNextPart_allInput_or_NotAnInput)
  with inv2_dblock
  show ?thesis
    by(auto simp add: Inv2a_innermost_def)
qed

lemma HEndPhase0_Inv2a_dblock_q:
  assumes act: "HEndPhase0 s s' p"
  and inv1: "Inv1 s"
  and inv2a: "Inv2a_inner s q"
  and inv2c: "Inv2c_inner s p"
  shows "Inv2a_innermost s' q (dblock s' q)"
proof(cases "p=q")
  case True
  with act inv2a inv2c inv1
  show ?thesis
    by(blast dest: HEndPhase0_Inv2a_dblock)
next
  case False
  from inv2a
  have inv_q_dblock: "Inv2a_innermost s q (dblock s q)"
    by(auto simp add: Inv2a_inner_def blocksOf_def)
  with False act
  show ?thesis
    by(clarsimp simp add: EndPhase0_def HNextPart_def
      InitializePhase_def Inv2a_innermost_def)
qed

theorem HEndPhase0_Inv2a:
  assumes inv: "Inv2a s"
  and     act: "HEndPhase0 s s' p"
  and    inv1: "Inv1 s"
  and   inv2c: "Inv2c_inner s p"
  shows        "Inv2a s'"
proof(clarsimp simp add: Inv2a_def Inv2a_inner_def)
  fix q bk
  assume bk: "bk \<in> blocksOf s' q"
  with HEndPhase0_blocksOf[OF act]
  have dblock_blocks: "bk \<in> {dblock s' q} \<union> blocksOf s q"
    by blast
  thus "Inv2a_innermost s' q bk"
  proof
    from inv
    have inv_q: "Inv2a_inner s q"
      by(auto simp add: Inv2a_def)
    assume "bk \<in> {dblock s' q}"
    with act inv1 inv2c inv_q
    show ?thesis
      by(blast dest:HEndPhase0_Inv2a_dblock_q)
  next
    assume bk_in_blocks: "bk \<in> blocksOf s q"
    with inv
    have "Inv2a_innermost s q bk"
      by(auto simp add: Inv2a_def Inv2a_inner_def)
    with act show ?thesis
      by(auto simp add: EndPhase0_def HNextPart_def
          InitializePhase_def Inv2a_innermost_def)
  qed
qed

lemma HEndPhase1_blocksOf:
  "HEndPhase1 s s' p \<Longrightarrow> blocksOf s' q \<subseteq> blocksOf s q \<union> {dblock s' q}"
by (auto simp add: EndPhase1_def blocksOf_def
         dest: subsetD[OF InitializePhase_rdBy])

lemma maxBlk_in_nonInitBlks:
  assumes b: "b \<in> nonInitBlks s p"
  and inv1: "Inv1 s"
  shows "   maxBlk s p \<in> nonInitBlks s p
         \<and> (\<forall>c\<in> nonInitBlks s p. bal c \<le> bal (maxBlk s p))"
proof -
  have nibals_finite: "finite (bal ` (nonInitBlks s p))" (is "finite ?S")
  proof (rule finite_imageI)
    from inv1
    have "finite (allRdBlks s p)"
      by (auto simp add: Inv1_def)
    hence "finite (allBlocksRead s p)"
      by (auto simp add: allBlocksRead_def)
    hence "finite (blocksSeen s p)"
      by (simp add: blocksSeen_def)
    thus "finite (nonInitBlks s p)"
      by(auto simp add: nonInitBlks_def intro: finite_subset)
  qed
  from b have "bal ` nonInitBlks s p \<noteq> {}"
    by auto
  with nibals_finite
  have "Max ?S \<in> ?S" and "\<forall>bb \<in> ?S. bb \<le> Max ?S" by auto
  hence "\<exists>mb \<in> ?S. \<forall>bb \<in> ?S. bb \<le> mb" ..
  then obtain mblk
    where "   mblk \<in> nonInitBlks s p
           \<and> (\<forall>c \<in> nonInitBlks s p. bal c \<le> bal mblk)"
          (is "?P mblk")
    by auto
  hence "?P (SOME b. ?P b)"
    by (rule someI)
  thus ?thesis
    by (simp add: maxBlk_def)
qed

lemma blocksOf_nonInitBlks:
  "(\<forall>p bk. bk \<in> blocksOf s p \<longrightarrow> P bk)
       \<Longrightarrow> bk \<in> nonInitBlks s p \<longrightarrow> P bk"
  by(auto simp add: allRdBlks_def blocksOf_def nonInitBlks_def
                    blocksSeen_def allBlocksRead_def rdBy_def,
    blast)

lemma maxBlk_allInput:
  assumes inv: "Inv2a s"
  and mblk: "maxBlk s p \<in> nonInitBlks s p"
  shows "inp (maxBlk s p) \<in> allInput s"
proof -
  from inv
  have blocks: "\<forall>p bk. bk \<in> blocksOf s p
                       \<longrightarrow> inp bk \<in> (allInput s) \<union> {NotAnInput}"
    by(auto simp add: Inv2a_def Inv2a_inner_def Inv2a_innermost_def)
  from mblk NotAnInput
  have "inp (maxBlk s p) \<noteq> NotAnInput"
    by(auto simp add: nonInitBlks_def)
  with mblk blocksOf_nonInitBlks[OF blocks]
  show ?thesis
    by auto
qed

lemma HEndPhase1_dblock_allInput:
  assumes act: "HEndPhase1 s s' p"
  and inv1: "HInv1 s"
  and inv2: "Inv2a s"
  shows inp': "inp (dblock s' p) \<in> allInput s'"
proof -
  from act
  have inpt: "inpt s p \<in> allInput s'"
    by(auto simp add: HNextPart_def EndPhase1_def)
  have "nonInitBlks s p \<noteq> {} \<longrightarrow> inp (maxBlk s p) \<in> allInput s"
  proof
    assume ni: "nonInitBlks s p \<noteq> {}"
    with inv1
    have "maxBlk s p \<in> nonInitBlks s p"
      by (auto simp add: HInv1_def maxBlk_in_nonInitBlks)
    with inv2
    show "inp (maxBlk s p) \<in> allInput s"
      by(blast dest: maxBlk_allInput)
  qed
  with act inpt
  show ?thesis
    by(auto simp add: EndPhase1_def HNextPart_def)
qed

lemma HEndPhase1_Inv2a_dblock:
  assumes act: "HEndPhase1 s s' p"
  and inv1: "HInv1 s"
  and inv2: "Inv2a s"
  and inv2c: "Inv2c_inner s p"
  shows "Inv2a_innermost s' p (dblock s' p)"
proof -
  from inv1 act have inv1': "HInv1 s'"
    by(blast dest: HEndPhase1_HInv1)
  from inv2
  have inv2a: "Inv2a_innermost s p (dblock s p)"
    by(auto simp add: Inv2a_def Inv2a_inner_def blocksOf_def)
  from act inv2c
  have mbal': "mbal (dblock s' p) \<in> Ballot p"
    by (auto simp add: EndPhase1_def Inv2c_def Inv2c_inner_def)
  moreover
  from act
  have bal': "bal (dblock s' p) = mbal (dblock s p)"
    by (auto simp add: EndPhase1_def)
  moreover
  from act inv1 inv2
  have inp': "inp (dblock s' p) \<in> allInput s'"
    by(blast dest: HEndPhase1_dblock_allInput)
  moreover
  with inv1' NotAnInput
  have "inp (dblock s' p) \<noteq> NotAnInput"
    by(auto simp add: HInv1_def)
  ultimately show ?thesis
    using act inv2a
    by(auto simp add: Inv2a_innermost_def EndPhase1_def)
qed

lemma HEndPhase1_Inv2a_dblock_q:
  assumes act: "HEndPhase1 s s' p"
  and inv1: "HInv1 s"
  and inv: "Inv2a s"
  and inv2c: "Inv2c_inner s p"
  shows "Inv2a_innermost s' q (dblock s' q)"
proof(cases "p=q")
  case True
  with act inv inv2c inv1
  show ?thesis
    by(blast dest: HEndPhase1_Inv2a_dblock)
next
  case False
  from inv
  have inv_q_dblock: "Inv2a_innermost s q (dblock s q)"
    by(auto simp add: Inv2a_def Inv2a_inner_def blocksOf_def)
  with False act
  show ?thesis
    by(clarsimp simp add: EndPhase1_def HNextPart_def
      InitializePhase_def Inv2a_innermost_def)
qed

theorem HEndPhase1_Inv2a:
  assumes act: "HEndPhase1 s s' p"
  and inv1: "HInv1 s"
  and inv: "Inv2a s"
  and inv2c: "Inv2c_inner s p"
  shows "Inv2a s'"
proof (clarsimp simp add: Inv2a_def Inv2a_inner_def)
  fix q bk
  assume bk_in_bks: "bk \<in> blocksOf s' q"
  with HEndPhase1_blocksOf[OF act]
  have dblock_blocks: "bk \<in> {dblock s' q} \<union> blocksOf s q"
    by blast
  thus "Inv2a_innermost s' q bk"
  proof
    assume "bk \<in> {dblock s' q}"
    with act inv1 inv2c inv
    show ?thesis
      by(blast dest: HEndPhase1_Inv2a_dblock_q)
  next
    assume bk_in_blocks: "bk \<in> blocksOf s q"
    with inv
    have "Inv2a_innermost s q bk"
      by(auto simp add: Inv2a_def Inv2a_inner_def)
    with act show ?thesis
      by(auto simp add: EndPhase1_def HNextPart_def
          InitializePhase_def Inv2a_innermost_def)
  qed
qed

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

text\<open>
Invariant 2b is proved automatically, given that
we expand the definitions involved.
\<close>

theorem HInit_Inv2b: "HInit s \<longrightarrow> Inv2b s"
by (auto simp add: HInit_def Init_def Inv2b_def
                   Inv2b_inner_def InitDB_def)

theorem HPhase1or2ReadThen_Inv2b:
  "\<lbrakk> Inv2b s; HPhase1or2ReadThen s s' p d q \<rbrakk>
   \<Longrightarrow> Inv2b s'"
by (auto simp add: Phase1or2ReadThen_def Inv2b_def
                   Inv2b_inner_def hasRead_def)

theorem HStartBallot_Inv2b:
  "\<lbrakk> Inv2b s; HStartBallot s s' p \<rbrakk>
   \<Longrightarrow> Inv2b s'"
  by(auto simp add:StartBallot_def InitializePhase_def
                   Inv2b_def Inv2b_inner_def hasRead_def)

theorem HPhase1or2Write_Inv2b:
  "\<lbrakk> Inv2b s; HPhase1or2Write s s' p d \<rbrakk>
   \<Longrightarrow> Inv2b s'"
  by(auto simp add: Phase1or2Write_def Inv2b_def
                    Inv2b_inner_def hasRead_def)

theorem HPhase1or2ReadElse_Inv2b:
  "\<lbrakk> Inv2b s; HPhase1or2ReadElse s s' p d q \<rbrakk>
   \<Longrightarrow> Inv2b s'"
by (auto simp add: Phase1or2ReadElse_def StartBallot_def hasRead_def
                   InitializePhase_def Inv2b_def Inv2b_inner_def)

theorem HEndPhase1_Inv2b:
  "\<lbrakk> Inv2b s; HEndPhase1 s s' p \<rbrakk> \<Longrightarrow> Inv2b s'"
by (auto simp add: EndPhase1_def InitializePhase_def
                   Inv2b_def Inv2b_inner_def hasRead_def)

theorem HFail_Inv2b:
  "\<lbrakk> Inv2b s; HFail s s' p \<rbrakk>
   \<Longrightarrow> Inv2b s'"
by (auto simp add: Fail_def InitializePhase_def
                   Inv2b_def Inv2b_inner_def hasRead_def)

theorem HEndPhase2_Inv2b:
  "\<lbrakk> Inv2b s; HEndPhase2 s s' p \<rbrakk> \<Longrightarrow> Inv2b s'"
by (auto simp add: EndPhase2_def InitializePhase_def
                   Inv2b_def Inv2b_inner_def hasRead_def)

theorem HPhase0Read_Inv2b:
  "\<lbrakk> Inv2b s; HPhase0Read s s' p d \<rbrakk> \<Longrightarrow> Inv2b s'"
by (auto simp add: Phase0Read_def Inv2b_def
                   Inv2b_inner_def hasRead_def)

theorem HEndPhase0_Inv2b:
  "\<lbrakk> Inv2b s; HEndPhase0 s s' p \<rbrakk> \<Longrightarrow> Inv2b s'"
by (auto simp add: EndPhase0_def InitializePhase_def
                   Inv2b_def Inv2b_inner_def hasRead_def)

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

theorem HInit_Inv2c: "HInit s \<longrightarrow> Inv2c s"
by (auto simp add: HInit_def Init_def Inv2c_def Inv2c_inner_def)

lemma HNextPart_Inv2c_chosen:
  assumes  hnp: "HNextPart s s'"
  and    inv2c: "Inv2c s"
  and   outpt': "\<forall>p. outpt s' p = (if phase s' p = 3
                                      then inp(dblock s' p)
                                      else NotAnInput)"
  and inp_dblk: "\<forall>p. inp (dblock s' p) \<in> allInput s' \<union> {NotAnInput}"
  shows  "chosen s' \<in> allInput s' \<union> {NotAnInput}"
using hnp outpt' inp_dblk inv2c
proof(auto simp add: HNextPart_def Inv2c_def Inv2c_inner_def
           split: if_split_asm)
qed

lemma HNextPart_chosen:
  assumes hnp: "HNextPart s s'"
  shows  "chosen s' = NotAnInput \<longrightarrow> (\<forall>p. outpt s' p = NotAnInput)"
using hnp
proof(auto simp add: HNextPart_def split: if_split_asm)
  fix p pa
  assume o1: "outpt s' p \<noteq> NotAnInput"
  and    o2: "outpt s' (SOME p. outpt s' p \<noteq> NotAnInput) = NotAnInput"
  from o1
  have "\<exists>p. outpt s' p \<noteq> NotAnInput"
    by auto
  hence "outpt s' (SOME p. outpt s' p \<noteq> NotAnInput) \<noteq> NotAnInput"
    by(rule someI_ex)
  with o2
  show "outpt s' pa = NotAnInput"
   by simp
qed

lemma HNextPart_allInput:
  "\<lbrakk> HNextPart s s'; Inv2c s \<rbrakk> \<Longrightarrow> \<forall>p. inpt s' p \<in> allInput s'"
    by(auto simp add: HNextPart_def Inv2c_def Inv2c_inner_def)

theorem HPhase1or2ReadThen_Inv2c:
  assumes inv: "Inv2c s"
  and act: "HPhase1or2ReadThen s s' p d q"
  and inv2a: "Inv2a s"
  shows "Inv2c s'"
proof -
  from inv2a act
  have inv2a': "Inv2a s'"
    by(blast dest: HPhase1or2ReadThen_Inv2a)
  from act inv
  have outpt': "\<forall>p. outpt s' p = (if phase s' p = 3
                                     then inp(dblock s' p)
                                     else NotAnInput)"
    by(auto simp add: Phase1or2ReadThen_def Inv2c_def Inv2c_inner_def)
  from inv2a'
  have dblk: "\<forall>p. inp (dblock s' p) \<in> allInput s' \<union> {NotAnInput}"
    by(auto simp add: Inv2a_def Inv2a_inner_def
                      Inv2a_innermost_def blocksOf_def)
  with act inv outpt'
  have chosen': "chosen s' \<in> allInput s' \<union> {NotAnInput}"
    by(auto dest: HNextPart_Inv2c_chosen)
  from act inv
  have "\<forall>p.   inpt s' p \<in> allInput s'
            \<and> (chosen s' = NotAnInput \<longrightarrow> outpt s' p = NotAnInput)"
    by(auto dest: HNextPart_chosen HNextPart_allInput)
  with outpt' chosen' act inv
  show ?thesis
    by(auto simp add: Phase1or2ReadThen_def Inv2c_def Inv2c_inner_def)
qed

theorem HStartBallot_Inv2c:
  assumes inv: "Inv2c s"
  and act: "HStartBallot s s' p"
  and inv2a: "Inv2a s"
  shows "Inv2c s'"
proof -
  from act
  have phase': "phase s' p = 1"
    by(simp add: StartBallot_def)
  from act
  have phase: "phase s p \<in> {1,2}"
    by(simp add: StartBallot_def)
  from act inv
  have mbal': "mbal(dblock s' p) \<in> Ballot p"
    by(auto simp add: StartBallot_def Inv2c_def Inv2c_inner_def)
  from inv phase
  have "bal(dblock s p) \<in> Ballot p \<union> {0}"
    by(auto simp add: Inv2c_def Inv2c_inner_def)
  with act
  have bal': "bal(dblock s' p) \<in> Ballot p \<union> {0}"
    by(auto simp add: StartBallot_def)
  from act inv phase phase'
  have blks': "(\<forall>d. \<forall>br \<in> blocksRead s' p d.
                     mbal(block br) < mbal(dblock s' p))"
    by(auto simp add: StartBallot_def InitializePhase_def
                      Inv2c_def Inv2c_inner_def)
  from inv2a act
  have inv2a': "Inv2a s'"
    by(blast dest: HStartBallot_Inv2a)
  from act inv
  have outpt': "\<forall>p. outpt s' p = (if phase s' p = 3
                                     then inp(dblock s' p)
                                     else NotAnInput)"
    by(auto simp add: StartBallot_def Inv2c_def Inv2c_inner_def)
  from inv2a'
  have dblk: "\<forall>p. inp (dblock s' p) \<in> allInput s' \<union> {NotAnInput}"
    by(auto simp add: Inv2a_def Inv2a_inner_def
                      Inv2a_innermost_def blocksOf_def)
  with act inv outpt'
  have chosen': "chosen s' \<in> allInput s' \<union> {NotAnInput}"
    by(auto dest: HNextPart_Inv2c_chosen)
  from act inv
  have allinp: "\<forall>p.   inpt s' p \<in> allInput s'
                    \<and> (chosen s' = NotAnInput
                              \<longrightarrow> outpt s' p = NotAnInput)"
    by(auto dest: HNextPart_chosen HNextPart_allInput)
  with phase' mbal' bal' outpt' chosen' act inv blks'
  show ?thesis
  by(auto simp add: StartBallot_def InitializePhase_def
                    Inv2c_def Inv2c_inner_def)
qed

theorem HPhase1or2ReadElse_Inv2c:
  " \<lbrakk> Inv2c s; HPhase1or2ReadElse s s' p d q; Inv2a s \<rbrakk> \<Longrightarrow> Inv2c s'"
  by(auto simp add: Phase1or2ReadElse_def dest: HStartBallot_Inv2c)

theorem HEndPhase1_Inv2c:
  assumes inv: "Inv2c s"
  and act: "HEndPhase1 s s' p"
  and inv2a: "Inv2a s"
  and inv1: "HInv1 s"
  shows "Inv2c s'"
proof -
  from inv
  have "Inv2c_inner s p" by (auto simp add: Inv2c_def)
  with inv2a act inv1
  have inv2a': "Inv2a s'"
    by(blast dest: HEndPhase1_Inv2a)
  from act inv
  have mbal': "mbal(dblock s' p) \<in> Ballot p"
    by(auto simp add: EndPhase1_def Inv2c_def Inv2c_inner_def)
  from act
  have bal': "bal(dblock s' p) = mbal (dblock s' p)"
    by(auto simp add: EndPhase1_def)
  from act inv
  have blks': "(\<forall>d. \<forall>br \<in> blocksRead s' p d.
                        mbal(block br) < mbal(dblock s' p))"
    by(auto simp add: EndPhase1_def InitializePhase_def
                      Inv2c_def Inv2c_inner_def)
  from act inv
  have outpt': "\<forall>p. outpt s' p = (if phase s' p = 3
                                     then inp(dblock s' p)
                                     else NotAnInput)"
    by(auto simp add: EndPhase1_def Inv2c_def Inv2c_inner_def)
  from inv2a'
  have dblk: "\<forall>p. inp (dblock s' p) \<in> allInput s' \<union> {NotAnInput}"
    by(auto simp add: Inv2a_def Inv2a_inner_def
                      Inv2a_innermost_def blocksOf_def)
  with act inv outpt'
  have chosen': "chosen s' \<in> allInput s' \<union> {NotAnInput}"
    by(auto dest: HNextPart_Inv2c_chosen)
  from act inv
  have allinp: "\<forall>p.    inpt s' p \<in> allInput s'
                    \<and> (chosen s' = NotAnInput
                            \<longrightarrow> outpt s' p = NotAnInput)"
    by(auto dest: HNextPart_chosen HNextPart_allInput)
  with mbal' bal' blks' outpt' chosen' act inv
  show ?thesis
    by(auto simp add: EndPhase1_def InitializePhase_def
                      Inv2c_def Inv2c_inner_def)
qed

theorem HEndPhase2_Inv2c:
  assumes inv: "Inv2c s"
  and act: "HEndPhase2 s s' p"
  and inv2a: "Inv2a s"
  shows "Inv2c s'"
proof -
  from inv2a act
  have inv2a': "Inv2a s'"
    by(blast dest: HEndPhase2_Inv2a)
  from act inv
  have outpt': "\<forall>p. outpt s' p = (if phase s' p = 3
                                     then inp(dblock s' p)
                                     else NotAnInput)"
    by(auto simp add: EndPhase2_def Inv2c_def Inv2c_inner_def)
  from inv2a'
  have dblk: "\<forall>p. inp (dblock s' p) \<in> allInput s' \<union> {NotAnInput}"
    by(auto simp add: Inv2a_def Inv2a_inner_def
                      Inv2a_innermost_def blocksOf_def)
  with act inv outpt'
  have chosen': "chosen s' \<in> allInput s' \<union> {NotAnInput}"
    by(auto dest: HNextPart_Inv2c_chosen)
  from act inv
  have allinp: "\<forall>p.    inpt s' p \<in> allInput s'
                    \<and> (chosen s' = NotAnInput
                            \<longrightarrow> outpt s' p = NotAnInput)"
    by(auto dest: HNextPart_chosen HNextPart_allInput)
  with outpt' chosen' act inv
  show ?thesis
    by(auto simp add: EndPhase2_def InitializePhase_def
                      Inv2c_def Inv2c_inner_def)
qed

theorem HFail_Inv2c:
  assumes inv: "Inv2c s"
  and act: "HFail s s' p"
  and inv2a: "Inv2a s"
  shows "Inv2c s'"
proof -
  from inv2a act
  have inv2a': "Inv2a s'"
    by(blast dest: HFail_Inv2a)
  from act inv
  have outpt': "\<forall>p. outpt s' p = (if phase s' p = 3
                                     then inp(dblock s' p)
                                     else NotAnInput)"
    by(auto simp add: Fail_def Inv2c_def Inv2c_inner_def)
  from inv2a'
  have dblk: "\<forall>p. inp (dblock s' p) \<in> allInput s' \<union> {NotAnInput}"
    by(auto simp add: Inv2a_def Inv2a_inner_def
                      Inv2a_innermost_def blocksOf_def)
  with act inv outpt'
  have chosen': "chosen s' \<in> allInput s' \<union> {NotAnInput}"
    by(auto dest: HNextPart_Inv2c_chosen)
  from act inv
  have allinp: "\<forall>p. inpt s' p \<in> allInput s' \<and> (chosen s' = NotAnInput
                     \<longrightarrow> outpt s' p = NotAnInput)"
    by(auto dest: HNextPart_chosen HNextPart_allInput)
  with outpt' chosen' act inv
  show ?thesis
    by(auto simp add: Fail_def InitializePhase_def
                      Inv2c_def Inv2c_inner_def)
qed

theorem HPhase0Read_Inv2c:
  assumes inv: "Inv2c s"
  and act: "HPhase0Read s s' p d"
  and inv2a: "Inv2a s"
  shows "Inv2c s'"
proof -
  from inv2a act
  have inv2a': "Inv2a s'"
    by(blast dest: HPhase0Read_Inv2a)
  from act inv
  have outpt': "\<forall>p. outpt s' p = (if phase s' p = 3
                                     then inp(dblock s' p)
                                     else NotAnInput)"
    by(auto simp add: Phase0Read_def Inv2c_def Inv2c_inner_def)
  from inv2a'
  have dblk: "\<forall>p. inp (dblock s' p) \<in> allInput s' \<union> {NotAnInput}"
    by(auto simp add: Inv2a_def Inv2a_inner_def
                      Inv2a_innermost_def blocksOf_def)
  with act inv outpt'
  have chosen': "chosen s' \<in> allInput s' \<union> {NotAnInput}"
    by(auto dest: HNextPart_Inv2c_chosen)
  from act inv
  have allinp: "\<forall>p.   inpt s' p \<in> allInput s'
                    \<and> (chosen s' = NotAnInput
                             \<longrightarrow> outpt s' p = NotAnInput)"
    by(auto dest: HNextPart_chosen HNextPart_allInput)
  with outpt' chosen' act inv
  show ?thesis
    by(auto simp add: Phase0Read_def
                      Inv2c_def Inv2c_inner_def)
qed

theorem HEndPhase0_Inv2c:
  assumes inv: "Inv2c s"
  and act: "HEndPhase0 s s' p"
  and inv2a: "Inv2a s"
  and inv1: "Inv1 s"
  shows "Inv2c s'"
proof -
  from inv
  have "Inv2c_inner s p" by (auto simp add: Inv2c_def)
  with inv2a act inv1
  have inv2a': "Inv2a s'"
    by(blast dest: HEndPhase0_Inv2a)
  hence bal': "bal(dblock s' p) \<in> Ballot p \<union> {0}"
    by(auto simp add: Inv2a_def Inv2a_inner_def
                      Inv2a_innermost_def blocksOf_def)
  from act inv
  have mbal': "mbal(dblock s' p) \<in> Ballot p"
    by(auto simp add: EndPhase0_def Inv2c_def Inv2c_inner_def)
  from act inv
  have blks': "(\<forall>d. \<forall>br \<in> blocksRead s' p d.
                         mbal(block br) < mbal(dblock s' p))"
    by(auto simp add: EndPhase0_def InitializePhase_def
                      Inv2c_def Inv2c_inner_def)
  from act inv
  have outpt': "\<forall>p. outpt s' p = (if phase s' p = 3
                                     then inp(dblock s' p)
                                     else NotAnInput)"
    by(auto simp add: EndPhase0_def Inv2c_def Inv2c_inner_def)
  from inv2a'
  have dblk: "\<forall>p. inp (dblock s' p) \<in> allInput s' \<union> {NotAnInput}"
    by(auto simp add: Inv2a_def Inv2a_inner_def
                      Inv2a_innermost_def blocksOf_def)
  with act inv outpt'
  have chosen': "chosen s' \<in> allInput s' \<union> {NotAnInput}"
    by(auto dest: HNextPart_Inv2c_chosen)
  from act inv
  have allinp: "\<forall>p. inpt s' p \<in> allInput s' \<and> (chosen s' = NotAnInput
                     \<longrightarrow> outpt s' p = NotAnInput)"
    by(auto dest: HNextPart_chosen HNextPart_allInput )
  with mbal' bal' blks' outpt' chosen' act inv
  show ?thesis
    by(auto simp add: EndPhase0_def InitializePhase_def
                      Inv2c_def Inv2c_inner_def)
qed

theorem HInit_HInv2:
  "HInit s \<Longrightarrow> HInv2 s"
using HInit_Inv2a HInit_Inv2b HInit_Inv2c
by(auto simp add: HInv2_def)

text\<open>$HInv1 \wedge HInv2$ is an invariant of $HNext$.\<close>

lemma I2b:
  assumes nxt: "HNext s s'"
  and inv: "HInv1 s \<and> HInv2 s"
  shows "HInv2 s'"
proof(auto simp add: HInv2_def)
  show "Inv2a s'" using assms
    by  (auto simp add: HInv2_def HNext_def Next_def,
         auto intro: HStartBallot_Inv2a,
         auto intro: HPhase1or2Write_Inv2a,
         auto simp add: Phase1or2Read_def
              intro: HPhase1or2ReadThen_Inv2a
                     HPhase1or2ReadElse_Inv2a,
         auto intro: HPhase0Read_Inv2a,
         auto simp add: EndPhase1or2_def Inv2c_def
              intro: HEndPhase1_Inv2a
                     HEndPhase2_Inv2a,
         auto intro: HFail_Inv2a,
         auto simp add: HInv1_def
              intro: HEndPhase0_Inv2a)
  show "Inv2b s'" using assms
    by(auto simp add: HInv2_def HNext_def Next_def,
       auto intro: HStartBallot_Inv2b,
       auto intro: HPhase0Read_Inv2b,
       auto intro: HPhase1or2Write_Inv2b,
       auto simp add: Phase1or2Read_def
            intro: HPhase1or2ReadThen_Inv2b
                   HPhase1or2ReadElse_Inv2b,
       auto simp add: EndPhase1or2_def
            intro: HEndPhase1_Inv2b HEndPhase2_Inv2b,
       auto intro:  HFail_Inv2b HEndPhase0_Inv2b)
  show "Inv2c s'" using assms
    by(auto simp add: HInv2_def HNext_def Next_def,
       auto intro: HStartBallot_Inv2c,
       auto intro: HPhase0Read_Inv2c,
       auto intro: HPhase1or2Write_Inv2c,
       auto simp add: Phase1or2Read_def
            intro: HPhase1or2ReadThen_Inv2c
                   HPhase1or2ReadElse_Inv2c,
       auto simp add: EndPhase1or2_def
            intro: HEndPhase1_Inv2c
                   HEndPhase2_Inv2c,
       auto intro: HFail_Inv2c,
       auto simp add: HInv1_def intro: HEndPhase0_Inv2c)
qed

end


section \<open>Strong Eventual Consistency \label{sec:strong_eventual_consistency}\<close>

theory SEC
  imports StrongConvergence
begin

text \<open>In the following theorem we establish that all reached states are successful. This
implies with the unconditional termination property (Section \ref{sec:integrate_term}) of it that
the integration algorithm never fails.\<close>

theorem (in dist_execution) no_failure:
  fixes i
  assumes "is_valid_state_id i"
  shows "isOK (state i)"
  apply (cases "state i")
  by (metis assms state_is_associated_string is_certified_associated_string.simps(2), simp)

text \<open>The following theorem establishes that any pair of peers having received the same
set of updates, will be in the same state.\<close>

theorem (in dist_execution) strong_convergence:
  assumes "is_valid_state_id i"
  assumes "is_valid_state_id j"
  assumes "set (received_messages i) = set (received_messages j)"
  shows "state i = state j"
  using state_is_associated_string is_certified_associated_string_unique by (metis assms)

text \<open>As we noted in Section~\ref{sec:networkModel}, we have not assumed eventual delivery, but
  a corollary of this theorem with the eventual delivery assumption implies eventual consistency.
  Since finally all peer would have received all messages, i.e., an equal set.\<close>

section \<open>Code generation\<close>

export_code integrate create_insert create_delete in Haskell
  module_name WOOT file_prefix "code"

section \<open>Proof Outline\label{sec:proof_outline}\<close>

text \<open>
  In this section we outline and motivate the approach we took to prove the strong eventual
  consistency of WOOT.

  While introducing operation-based CRDTs Shapiro et al. also establish
  \cite{shapiro2011conflict}[Theorem 2.2]. If the following two conditions are met:
  \begin{itemize}
    \item
      Concurrent operations commute, i.e., if a pair of operations @{text "m\<^sub>1"},
      @{text "m\<^sub>2"} is concurrent with respect to the order induced by the happened-before
      relation, and they are both applicable to a state @{text "s"}, then the message
      @{text "m\<^sub>1"} (resp. @{text "m\<^sub>2"}) is still applicable on the state reached by
      applying  @{text "m\<^sub>2"} (resp. @{text "m\<^sub>1"}) on @{text "s"} and the resulting
      states are equal.
    \item Assuming causal delivery, the messages are applicable.
  \end{itemize}
  Then the CRDT has strong convergence.
  The same authors extend the above result in \cite[Proposition 2.2]{shapiro:inria-00555588}
  to more general delivery orders $\xrightarrow{d}$ (weaker than the one induced by the
  happened-before relation), i.e., two messages may be causally dependent but concurrent with
  respect to $\xrightarrow{d}$. Assuming operations that are concurrent with respect to
  $\xrightarrow{d}$ commute, and messages are applicable, when the
  delivery order respects $\xrightarrow{d}$ then again the CRDT has strong convergence.

  A key difficulty of the consistency proof of the WOOT framework is that the applicability
  condition for the WOOT framework has three constraints:
  \begin{enumerate}
    \item \label{en:proof:deps_are_met} Dependencies must be met.
    \item \label{en:proof:id_distinct} Identifiers must be distinct.
    \item The order must be consistent, i.e. the predecessor W-character must appear before the
      successor W-character in the state an insert message is being integrated.
  \end{enumerate}

  The first constraint is a direct consequence of the semantic causal delivery order. The uniqueness
  of identifiers can be directly established by analyzing the implementation of the message creation
  algorithms. Alternatively, Gomes et al.~\cite{gomes2017verifying} use an axiomatic approach, where
  they require the underlying network protocol to deliver messages with unique identifiers. They
  provide a formal framework in Isabelle/HOL that can be used to show consistency of arbitrary
  CRDTs. Their results could be used to establish constraints \ref{en:proof:deps_are_met} and
  \ref{en:proof:id_distinct}.

  The last constraint is the most intricate one, and forces us to use a different method to
  establish the strong eventual consistency. The fact that the order constraint is fulfilled is a
  consequence of the consistency property. But the current fundamental lemmas require applicability
  of the operations in the first place to establish consistency, which would result in a circular
  argument.

  Zeller et. al. actually predict the above circumstance in the context of state-based CRDTs
  \cite{DBLP:conf/forte/ZellerBP14}:
  \begin{displayquote}
  In theory it could even be the case that there are two reachable states for which the merge
  operation does not yield the correct result, but where the two states can never be reached in the
  same execution.
  \end{displayquote}

  Because of the above, we treat WOOT as a distributed message passing algorithm and show
  convergence by establishing a global invariant, which is maintained during the execution of the
  framework. The invariant captures that the W-characters appear in the same order on all peers.
  It has strong convergence as a consequence, in the special case, when peers have received
  the same set of updates. It also implies that the generated messages will be applicable.

  \begin{figure}
    \centering
    \begin{tikzpicture}[
      statenode/.style={circle, draw=black, fill=black!20, thick, minimum size=5mm},
      curstatenode/.style={circle, draw=black, fill=black!60, thick, minimum size=5mm},
      peernode/.style={rectangle, draw=black, thick, minimum size=5mm},
    ]
    %Nodes
    \node[peernode] (peerA) at (1.5cm, 3cm) {Peer A};
    \node[peernode] (peerB) at (1.5cm, 2cm) {Peer B};
    \node[peernode] (peerC) at (1.5cm, 1cm) {Peer C};
    \node[statenode] (stateA2) at (4cm, 3cm) {};
    \node[curstatenode] (stateB2) at (5cm, 2cm) {};
    \node[statenode] (stateC2) at (3.5cm, 1cm) {};
    \node[statenode] (stateA3) at (5.5cm, 3cm) {};
    \node[statenode] (stateB3) at (7cm, 2cm) {};
    \node[statenode] (stateC3) at (6.5cm, 1cm) {};
    \node[statenode] (stateA4) at (7.5cm, 3cm) {};
    \draw[->] (peerA.east) -- (stateA2.west);
    \draw[->] (peerB.east) -- (stateB2.west);
    \draw[->] (peerC.east) -- (stateC2.west);
    \draw[->] (stateA2.east) -- (stateA3.west);
    \draw[->] (stateB2.east) -- (stateB3.west);
    \draw[->] (stateC2.east) -- (stateC3.west);
    \draw[->] (stateC2) -- (stateA2);
    \draw[->] (stateC2) -- (stateB2);
    \draw[->] (stateA3) -- (stateC3);
    \draw[->] (stateA3) -- (stateB3);
    \draw[->] (stateA3) -- (stateA4);
    \draw (5cm,3.5cm) to[bend right] (4.8cm,0.5cm);
    \end{tikzpicture}
    \caption{Example state graph, where the consistency is established left of the bend curve.}
    \label{fig:state_graph}
  \end{figure}

  In Figure~\ref{fig:state_graph}, we exemplify an induction step in a proof over the execution
  of the framework. The invariant is established for all states left of the dashed lines, and we
  show that it remains true if we include the state, drawn in dark gray. Note that induction
  proceeds in an order consistent with the happened-before relation.

  The technique we are using is to define a relation @{term is_associated_string} from a set of
  messages to the final state their application leads to. Crucially, that relation can be defined
  in a message-order independent way. We show that it correctly models the behaviour of Algorithm
  @{term "integrate"} by establishing that applying the integration algorithm to the associated
  string of a set @{term "M"} leads to the associated string of the set @{term "M \<union> {m}"}
  in Proposition @{thm [source] integrate_insert_commute}.

  We also show that at most one @{text s} fulfills @{term "is_associated_string M s"},
  which automatically implies commutativity (cf. Lemma @{thm [source] "associated_string_unique"}).

  Note that the domain of the relation @{term "is_associated_string"} consists of the sets of
  messages that we call @{term "consistent"}. We show that, in every state of a peer, the set of
  received messages will be consistent.
  The main ingredient required for the definition of a consistent set of messages as the relation
  @{term "is_associated_string"} are \emph{sort keys} associated to the W-characters, which we will
  explain in the following Section.
\<close>

subsection \<open> Sort Keys \<close>

text \<open>
  There is an implicit sort key, which is deterministically computable, using the immutable data
  associated to a W-character and the data of the W-characters it (transitively) depends on.

  We show that Algorithm @{term "integrate"} effectively maintains the W-characters ordered with
  respect to that sort key, which is the reason we can construct the mapping
  @{term "is_associated_string"} in a message-order
  independent way. An alternative viewpoint would be to see Algorithm @{term "integrate_insert"} as
  an optimized version of a more mundane algorithm, that just inserts the W-characters using this
  implicit sort key.

  Since the sort key is deterministically computable using the immutable data associated to a
  W-character and the data of the W-characters it (transitively) depends on, all peers could
  perform this computation independently, which leads to the conclusion that the W-characters
  will be ordered consistently across all peers.

  The construction relies on a combinator @{term "\<Psi>"} that computes the sort key for a
  W-character, and which requires as input:
  \begin{itemize}
    \item The unique identifier associated to a W-character.
    \item The sort keys of the predecessor/successor W-characters.
  \end{itemize}
  Its values are elements of a totally ordered space.

  Note that the predecessor (resp. successor) W-character of a W-character is the W-character that
  was immediately before (resp. after) it at the time it was inserted. Like its unique identifier,
  it is immutable data associated with that W-character. Sometimes a W-character is inserted at the
  beginning (resp. end) of the string. For those W-characters, we use the special smallest
  (resp. largest) sort keys, denoted by @{term "\<turnstile>"} (resp. @{term "\<stileturn>"}) as predecessor
  (resp. successor). These keys themselves are never associated to a W-character.

  We will write @{term "\<Psi> (l,u) i"} for the value computed by the combinator for a W-character
  with identifier @{term "i"}, assuming the sort key of its predecessor (resp. successor) is
  @{term "l"} (resp. @{term "u"}).

  For example, the sort key for a W-character with identifier @{term "i"} inserted in an empty
  string (hence its predecessor is @{term "\<turnstile>"} and its successor is @{term "\<stileturn>"})
  will be  @{term "\<Psi> (\<turnstile>,\<stileturn>) i"}. A W-character
  inserted between that character and the end of the string, with identifier j, would be assigned
  the sort key @{term "\<Psi> (\<lbrakk>\<Psi> (\<turnstile>,\<stileturn>) i\<rbrakk>,\<stileturn>) j"}.

  The sort key needs to fulfill a couple of properties, to be useful:

  There should never be a pair of W-characters with the same sort key. Note, if this happens, even
  if those W-characters were equal or ordered consistently, we would not be able to insert a new
  W-character between those W-characters.

  Since the W-characters have themselves unique identifiers, a method to insure the above property
  is to require that @{term "\<Psi>"} be injective with respect to the identifier of the W-character
  it computes a sort key for, i.e.,
  @{term "\<Psi> (l,u) i = \<Psi> (l',u') i' \<Longrightarrow> i = i'"}.

  Another essential property is that the W-characters with predecessor having the sort key
  @{term "l"} and successor having the sort key @{term "u"}  should have a sort key that is between
  @{term "l"} and @{term "u"}, such that the W-character is inserted between the preceding and
  succeeding W-character, i.e., @{text "l < \<Psi> (l,u) i < u"}.

  This latter property ensures intention preservation, i.e. the inserted W-character will be placed
  at the place the user intended.

  If we review function @{term "concurrent"}, then we see that the algorithm compares W-characters
  by identifier, in the special case, when the inserted W-character is compared to a W-character
  whose predecessor and successor are outside of the range it is to be inserted in. A careful
  investigation, leads to the conclusion that:

  If @{text "l \<le> l' < \<Psi> (l,u) i < u' \<le> u"} then @{text "\<Psi>(l,u) i"} can be compared
  with @{text "\<Psi>(l',u') i'"} by comparing @{text "i"} with @{text "i'"}, i.e.:
  \begin{itemize}
    \item @{text "i < i' \<Longrightarrow> \<Psi> (l,u) i < \<Psi>(l',u') i'"}
  \end{itemize}

  In Section \ref{sec:psi} we show that a combinator @{term "\<Psi>"} with the above properties can
  be constructed (cf. Propositions @{thm [source] psi_narrow psi_mono psi_elem}).
  Using the sort keys we can define the notion of a consistent set of messages as well as the
  relation @{term "is_associated_string"} in a message-order independent way.\<close>

subsection \<open> Induction \<close>

text \<open>
  We have a couple of criteria that define a consistent set of messages:

  \begin{itemize}
    \item Each insert message in the set has a unique identifier.
    \item If a message depends on another message identifier, a message with that identifier will
      be present. Note that for insert messages, these are the predecessor/successor W-characters
      if present. For delete messages it is the corresponding insert message.
    \item The dependencies form a well-order, i.e., there is no dependency cycle.
    \item It is possible to assign sort keys to each insert message, such that
      the assigned sort key for each insert message is equal to the value returned by the
      @{term "\<Psi>"} for it, using the associated sort keys of its predecessor and successors,
      i.e.,
      @{term "a (P m) < a (S m) \<and>
              a \<lbrakk>I m\<rbrakk> = \<lbrakk>\<Psi> (a (P m), a (S m)) (I m)\<rbrakk>"}.
      Note that we also require that sort key of the predecessor is smaller than the sort key of the
      successor.
  \end{itemize}

  The relation @{term "is_associated_string"} is then defined by ordering the insert messages
  according to the assigned sort keys above and marking W-characters, for which there are delete
  messages as deleted.

  The induction proof (Lemma @{thm [source] dist_execution.sent_messages_consistent}) over the
  states of the framework is straight forward: Using Lemma @{thm [source] top_sort} we find a
  possible order of the states consistent with the happened before relation. The induction invariant
  is that the set of generated messages by all peers is
  consistent (independent of whether they have been received by all peers (yet)). The latter also
  implies that the subset a peer has received in any of those states is consistent, using the
  additional fact that each messages dependencies will be delivered before the message itself
  (see also Lemma @{thm [source] consistent_subset} and
  Proposition @{thm [source] integrate_insert_commute'}).
  For the induction step, we rely on the results from Section \ref{sec:create_consistent} that any
  additional created messages will keep the set of messages consistent and that the peers' states
  will be consistent with the (consistent subset of) messages they received (Lemma @{thm [source]
  dist_execution.state_is_associated_string'}).\<close>
end


(*  Title:       Jive Data and Store Model
    Author:      Norbert Schirmer <schirmer at informatik.tu-muenchen.de>, 2003
    Maintainer:  Nicole Rauch <rauch at informatik.uni-kl.de>
    License:     LGPL
*)

header {* Store *}

theory Store
imports Location
begin

subsection {* New *}
text {* The store provides a uniform interface to allocate new objects and
new arrays. The constructors of this datatype distinguish both cases.
 *}
datatype New = new_instance CTypeId    --{* New object, can only be of a concrete class type *}
             | new_array Arraytype nat --{* New array with given size*}

text {* The discriminator @{text "isNewArr"} can be used to distinguish both
kinds of newly created elements.
*}

definition isNewArr :: "New \<Rightarrow> bool" where
"isNewArr t = (case t of
                 new_instance C \<Rightarrow> False
               | new_array T l \<Rightarrow> True)"

lemma isNewArr_simps [simp]:
"isNewArr (new_instance C) = False"
"isNewArr (new_array T l)  = True"
  by (simp_all add: isNewArr_def)

text {* The function @{text "typeofNew"} yields the type of the newly created
element. *}

definition typeofNew :: "New \<Rightarrow> Javatype" where
"typeofNew n = (case n of
                  new_instance C \<Rightarrow> CClassT C
                | new_array T l  \<Rightarrow> ArrT T)"

lemma typeofNew_simps:
"typeofNew (new_instance C) = CClassT C"
"typeofNew (new_array T l)  = ArrT T"
  by (simp_all add: typeofNew_def)

subsection {* The Definition of the Store *}

text {* In our store model, all objects\footnote{In the following, the term ``objects''
includes arrays. This keeps the explanations compact.}
of all classes exist at all times, but only those objects that have already been allocated
are alive. Objects cannot be deallocated, thus an object that once gained
the aliveness status cannot lose it later on.
\\[12pt]
 To model the store, we need two functions that give us fresh object Id's for
the allocation of new objects (function @{text "newOID"}) and arrays
(function @{text "newAID"}) as well as a function that maps locations to
their contents (function @{text "vals"}). *}

record StoreImpl = newOID :: "CTypeId \<Rightarrow> ObjectId"
                   newAID :: "Arraytype \<Rightarrow> ObjectId"
                   vals   :: "Location \<Rightarrow> Value"

text {* The function @{text "aliveImpl"} determines for a given value whether
it is alive in a given store.
*}

definition aliveImpl::"Value \<Rightarrow> StoreImpl \<Rightarrow> bool" where
"aliveImpl x s = (case x of
                    boolV b  \<Rightarrow> True
                  | intgV i  \<Rightarrow> True
                  | shortV s  \<Rightarrow> True
                  | byteV by  \<Rightarrow> True
                  | objV C a \<Rightarrow> (a < newOID s C)
                  | arrV T a \<Rightarrow> (a < newAID s T)
                  | nullV    \<Rightarrow> True)"

text {* The store itself is defined as new type. The store ensures
and maintains the following
properties: All stored values are alive; for all locations whose values are
not alive, the store yields the location type's init value; and
all stored values are of the correct type (i.e.~of the type of the location
they are stored in).
*}

definition "Store = {s. (\<forall> l. aliveImpl (vals s l) s) \<and>
                  (\<forall> l. \<not> aliveImpl (ref l) s \<longrightarrow> vals s l = init (ltype l)) \<and>
                  (\<forall> l. typeof (vals s l) \<le> ltype l)}"

typedef Store = Store
  unfolding Store_def
  apply (rule exI [where ?x="\<lparr> newOID = (\<lambda>C. 0),
                          newAID = (\<lambda>T. 0),
                          vals = (\<lambda>l. init (ltype l)) \<rparr>"])
  apply (auto simp add: aliveImpl_def init_def NullT_leaf_array split: Javatype.splits)
  done

text {* One might also model the Store as axiomatic type class and prove that the type StoreImpl belongs
to this type class. This way, a clearer separation between the axiomatic description of the store and its
properties on the one hand and the realization that has been chosen in this formalization on the other hand
could be achieved. Additionally, it would be easier to make use of  different store implementations that
might have different additional features. This separation remains to be performed as future work.
*}

subsection{* The Store Interface *}

text {* The Store interface consists of five functions:
@{text "access"} to read the value that is stored at a location;
@{text "alive"} to test whether a value is alive in the store;
@{text "alloc"} to allocate a new element in the store;
@{text "new"} to read the value of a newly allocated element;
@{text "update"} to change the value that is stored at a location.
 *}

consts access:: "Store \<Rightarrow> Location \<Rightarrow> Value"  ("_@@_" [71,71] 70)
       alive:: "Value \<Rightarrow> Store \<Rightarrow> bool"
       alloc:: "Store \<Rightarrow> New \<Rightarrow> Store"
       new:: "Store \<Rightarrow> New \<Rightarrow> Value"
       update:: "Store \<Rightarrow> Location \<Rightarrow> Value \<Rightarrow> Store"

nonterminal smodifybinds and smodifybind
syntax
  "_smodifybind" :: "['a, 'a]     \<Rightarrow> smodifybind" ("(2_ :=/ _)")
  ""         :: "smodifybind \<Rightarrow> smodifybinds"     ("_")
  ""         :: "CTypeId \<Rightarrow> smodifybind"          ("_")
  "_smodifybinds":: "[smodifybind, smodifybinds] => smodifybinds" ("_,/ _")
  "_sModify"  :: "['a, smodifybinds] \<Rightarrow> 'a"       ("_/\<langle>(_)\<rangle>" [900,0] 900)
translations
  "_sModify s (_smodifybinds b bs)"  == "_sModify (_sModify s b) bs"
  "s\<langle>x:=y\<rangle>"                          == "CONST update s x y"
  "s\<langle>c\<rangle>"                             == "CONST alloc s c"

text {* With this syntactic setup we can write chains of (array) updates and
allocations like in the
following term
@{term "s\<langle>new_instance Node,x:=y,z:=intgV 3,new_array IntgAT 3,a.[i]:=intgV 4,k:=boolV True\<rangle>"}.
*}

text {* In the following, the definitions of the five store interface functions and some lemmas
about them are given. *}

defs alive_def:
"alive x s \<equiv> aliveImpl x (Rep_Store s)"

lemma alive_trivial_simps [simp,intro]:
"alive (boolV b) s"
"alive (intgV i) s"
"alive (shortV sh) s"
"alive (byteV by) s"
"alive nullV     s"
  by (simp_all add: alive_def aliveImpl_def)

defs access_def:
"access s l \<equiv> vals (Rep_Store s) l"

defs update_def:
"update s l v \<equiv> if alive (ref l) s \<and> alive v s \<and> typeof v \<le> ltype l
                then Abs_Store ((Rep_Store s)\<lparr>vals:=(vals (Rep_Store s))(l:=v)\<rparr>)
                else s"

defs alloc_def:
"alloc s t \<equiv>
  (case t of
     new_instance C
      \<Rightarrow> Abs_Store
          ((Rep_Store s)\<lparr>newOID := \<lambda> D. if C=D
                            then Suc (newOID (Rep_Store s) C)
                            else newOID (Rep_Store s) D\<rparr>)
   | new_array T l
      \<Rightarrow> Abs_Store
          ((Rep_Store s)\<lparr>newAID := \<lambda> S. if T=S
                           then Suc (newAID (Rep_Store s) T)
                           else newAID (Rep_Store s) S,
                         vals :=  (vals (Rep_Store s))
                                    (arrLenLoc T (newAID (Rep_Store s) T)
                                      := intgV (int l))\<rparr>))"

defs new_def:
"new s t \<equiv> (case t of
              new_instance C \<Rightarrow> objV C (newOID (Rep_Store s) C)
            | new_array T l  \<Rightarrow> arrV T (newAID (Rep_Store s) T))"

text {* The predicate @{text "wts"} tests whether the store is well-typed. *}

definition
wts :: "Store \<Rightarrow> bool" where
"wts OS = (\<forall> (l::Location) . (typeof (OS@@l)) \<le> (ltype l))"

subsection {* Derived Properties of the Store *}

text {* In this subsection, a number of lemmas formalize various properties of the Store.
Especially the 13 axioms are proven that must hold for a modelling of a Store
(see \cite[p. 45]{Poetzsch-Heffter97specification}). They are labeled with
Store1 to Store13.  *}

lemma alive_init [simp,intro]: "alive (init T) s"
  by (cases T) (simp_all add: alive_def aliveImpl_def)

lemma alive_loc [simp]:
  "\<lbrakk>isObjV x; typeof x \<le> dtype f\<rbrakk> \<Longrightarrow> alive (ref (x..f)) s = alive x s"
  by (cases x) (simp_all)

lemma alive_arr_loc [simp]:
  "isArrV x \<Longrightarrow> alive (ref (x.[i])) s = alive x s"
  by (cases x) (simp_all)

lemma ref_arr_len_new [simp]:
  "ref (arr_len (new s (new_array T n))) = new s (new_array T n)"
  by (simp add: new_def)

lemma ref_arr_loc_new [simp]:
  "ref ((new s (new_array T n)).[i]) = new s (new_array T n)"
  by (simp add: new_def)

lemma ref_loc_new [simp]: "CClassT C \<le> dtype f
  \<Longrightarrow> ref ((new s (new_instance C))..f) = new s (new_instance C)"
  by (simp add: new_def)

lemma access_type_safe [simp,intro]: "typeof (s@@l) \<le> ltype l"
proof -
  have "Rep_Store s \<in> Store"
    by (rule Rep_Store)
  thus ?thesis
    by (auto simp add: access_def Store_def)
qed

text {* The store is well-typed by construction. *}
lemma always_welltyped_store: "wts OS"
  by (simp add: wts_def access_type_safe)

text {* Store8 *}
lemma alive_access [simp,intro]: "alive (s@@l) s"
proof -
  have "Rep_Store s \<in> Store"
    by (rule Rep_Store)
  thus ?thesis
    by (auto simp add: access_def Store_def alive_def aliveImpl_def)
qed

text {* Store3 *}
lemma access_unalive [simp]:
  assumes unalive: "\<not> alive (ref l) s"
  shows "s@@l = init (ltype l)"
proof -
  have "Rep_Store s \<in> Store"
    by (rule Rep_Store)
  with unalive show ?thesis
    by (simp add: access_def Store_def alive_def aliveImpl_def)
qed

lemma update_induct:
  assumes skip: "P s"
  assumes update: "\<lbrakk>alive (ref l) s; alive v s; typeof v \<le> ltype l\<rbrakk> \<Longrightarrow>
               P (Abs_Store ((Rep_Store s)\<lparr>vals:=(vals (Rep_Store s))(l:=v)\<rparr>))"
  shows "P (s\<langle>l:=v\<rangle>)"
  using update skip
  by (simp add: update_def)

lemma vals_update_in_Store:
  assumes alive_l: "alive (ref l) s"
  assumes alive_y: "alive y s"
  assumes type_conform: "typeof y \<le> ltype l"
  shows "(Rep_Store s\<lparr>vals := (vals (Rep_Store s))(l := y)\<rparr>) \<in> Store"
  (is "?s_upd \<in> Store")
proof -
  have s: "Rep_Store s \<in> Store"
    by (rule Rep_Store)
  have alloc_eq: "newOID ?s_upd = newOID (Rep_Store s)"
    by simp
  have "\<forall> l. aliveImpl (vals ?s_upd l) ?s_upd"
  proof
    fix k
    show "aliveImpl (vals ?s_upd k) ?s_upd"
    proof (cases "k=l")
      case True
      with alive_y show ?thesis
        by (simp add: alloc_eq alive_def aliveImpl_def split: Value.splits)
    next
      case False
      from s have "\<forall> l. aliveImpl (vals (Rep_Store s) l) (Rep_Store s)"
        by (simp add: Store_def)
      with False show ?thesis
        by (simp add: aliveImpl_def split: Value.splits)
    qed
  qed
  moreover
  have "\<forall> l. \<not> aliveImpl (ref l) ?s_upd \<longrightarrow> vals ?s_upd l = init (ltype l)"
  proof (intro allI impI)
    fix k
    assume unalive: "\<not> aliveImpl (ref k) ?s_upd"
    show "vals ?s_upd k = init (ltype k)"
    proof -
      from unalive alive_l
      have "k\<noteq>l"
        by (auto simp add: alive_def aliveImpl_def split: Value.splits)
      hence "vals ?s_upd k = vals (Rep_Store s) k"
        by simp
      moreover from unalive
      have "\<not> aliveImpl (ref k) (Rep_Store s)"
        by (simp add: aliveImpl_def split: Value.splits)
      ultimately show ?thesis
        using s by (simp add: Store_def)
    qed
  qed
  moreover
  have "\<forall> l. typeof (vals ?s_upd l) \<le> ltype l"
  proof
    fix k show "typeof (vals ?s_upd k) \<le> ltype k"
    proof (cases "k=l")
      case True
      with type_conform show ?thesis
        by simp
    next
      case False
      hence "vals ?s_upd k = vals (Rep_Store s) k"
        by simp
      with s show ?thesis
        by (simp add: Store_def)
    qed
  qed
  ultimately show ?thesis
    by (simp add: Store_def)
qed

text {* Store6 *}
lemma alive_update_invariant [simp]: "alive x (s\<langle>l:=y\<rangle>) = alive x s"
proof (rule update_induct)
  show "alive x s = alive x s"..
next
  assume "alive (ref l) s" "alive y s" "typeof y \<le> ltype l"
  hence "Rep_Store
          (Abs_Store (Rep_Store s\<lparr>vals := (vals (Rep_Store s))(l := y)\<rparr>))
         = Rep_Store s\<lparr>vals := (vals (Rep_Store s))(l := y)\<rparr>"
    by (rule vals_update_in_Store [THEN Abs_Store_inverse])
  thus "alive x
         (Abs_Store (Rep_Store s\<lparr>vals := (vals (Rep_Store s))(l := y)\<rparr>)) =
        alive x s"
    by (simp add: alive_def aliveImpl_def split: Value.split)
qed

text {* Store1 *}
lemma access_update_other [simp]:
  assumes neq_l_m: "l \<noteq> m"
  shows "s\<langle>l:=x\<rangle>@@m = s@@m"
proof (rule update_induct)
  show "s@@m = s@@m" ..
next
  assume "alive (ref l) s" "alive x s" "typeof x \<le> ltype l"
  hence "Rep_Store
          (Abs_Store (Rep_Store s\<lparr>vals := (vals (Rep_Store s))(l := x)\<rparr>))
         = Rep_Store s\<lparr>vals := (vals (Rep_Store s))(l := x)\<rparr>"
    by (rule vals_update_in_Store [THEN Abs_Store_inverse])
  with neq_l_m
  show "Abs_Store (Rep_Store s\<lparr>vals := (vals (Rep_Store s))(l := x)\<rparr>)@@m = s@@m"
    by (auto simp add: access_def)
qed

text {* Store2 *}
lemma update_access_same [simp]:
  assumes alive_l: "alive (ref l) s"
  assumes alive_x: "alive x s"
  assumes widen_x_l: "typeof x \<le> ltype l"
  shows "s\<langle>l:=x\<rangle>@@l = x"
proof -
  from alive_l alive_x widen_x_l
  have "Rep_Store
          (Abs_Store (Rep_Store s\<lparr>vals := (vals (Rep_Store s))(l := x)\<rparr>))
         = Rep_Store s\<lparr>vals := (vals (Rep_Store s))(l := x)\<rparr>"
    by (rule vals_update_in_Store [THEN Abs_Store_inverse])
  hence "Abs_Store (Rep_Store s\<lparr>vals := (vals (Rep_Store s))(l := x)\<rparr>)@@l = x"
    by (simp add: access_def)
  with alive_l alive_x widen_x_l
  show ?thesis
    by (simp add: update_def)
qed

text {* Store4 *}
lemma update_unalive_val [simp,intro]: "\<not> alive x s \<Longrightarrow> s\<langle>l:=x\<rangle> = s"
  by (simp add: update_def)

lemma update_unalive_loc [simp,intro]: "\<not> alive (ref l) s \<Longrightarrow> s\<langle>l:=x\<rangle> = s"
  by (simp add: update_def)

lemma update_type_mismatch [simp,intro]: "\<not> typeof x \<le> ltype l \<Longrightarrow> s\<langle>l:=x\<rangle> = s"
  by (simp add: update_def)

text {* Store9 *}
lemma alive_primitive [simp,intro]: "isprimitive (typeof x) \<Longrightarrow> alive x s"
  by (cases x) (simp_all)

text {* Store10 *}
lemma new_unalive_old_Store [simp]: "\<not> alive (new s t) s"
  by (cases t) (simp_all add: alive_def aliveImpl_def new_def)

lemma alloc_new_instance_in_Store:
"(Rep_Store s\<lparr>newOID := \<lambda>D. if C = D
                                   then Suc (newOID (Rep_Store s) C)
                                   else newOID (Rep_Store s) D\<rparr>) \<in> Store"
(is "?s_alloc \<in> Store")
proof -
  have s: "Rep_Store s \<in> Store"
    by (rule Rep_Store)
  hence "\<forall> l. aliveImpl (vals (Rep_Store s) l) (Rep_Store s)"
    by (simp add: Store_def)
  then
  have "\<forall> l. aliveImpl (vals ?s_alloc l) ?s_alloc"
    by (auto intro: less_SucI simp add: aliveImpl_def split: Value.splits)
  moreover
  have "\<forall> l. \<not> aliveImpl (ref l) ?s_alloc \<longrightarrow> vals ?s_alloc l = init (ltype l)"
  proof (intro allI impI)
    fix l
    assume "\<not> aliveImpl (ref l) ?s_alloc"
    hence "\<not> aliveImpl (ref l) (Rep_Store s)"
      by (simp add: aliveImpl_def split: Value.splits split_if_asm)
    with s have "vals (Rep_Store s) l = init (ltype l)"
      by (simp add: Store_def)
    thus "vals ?s_alloc l = init (ltype l)"
      by simp
  qed
  moreover
  from s have "\<forall> l. typeof (vals ?s_alloc l) \<le> ltype l"
    by (simp add: Store_def)
  ultimately
  show ?thesis
    by (simp add: Store_def)
qed

lemma alloc_new_array_in_Store:
"(Rep_Store s \<lparr>newAID :=
                  \<lambda>S. if T = S
                      then Suc (newAID (Rep_Store s) T)
                      else newAID (Rep_Store s) S,
               vals := (vals (Rep_Store s))
                         (arrLenLoc T
                           (newAID (Rep_Store s) T) :=
                           intgV (int n))\<rparr>) \<in> Store"
(is "?s_alloc \<in> Store")
proof -
  have s: "Rep_Store s \<in> Store"
    by (rule Rep_Store)
  have "\<forall> l. aliveImpl (vals ?s_alloc l) ?s_alloc"
  proof
    fix l show "aliveImpl (vals ?s_alloc l) ?s_alloc"
    proof (cases "l = arrLenLoc T (newAID (Rep_Store s) T)")
      case True
      thus ?thesis
        by (simp add: aliveImpl_def split: Value.splits)
    next
      case False
      from s have "\<forall> l. aliveImpl (vals (Rep_Store s) l) (Rep_Store s)"
        by (simp add: Store_def)
      with False show ?thesis
        by (auto intro: less_SucI simp add: aliveImpl_def split: Value.splits)
    qed
  qed
  moreover
  have "\<forall> l. \<not> aliveImpl (ref l) ?s_alloc \<longrightarrow> vals ?s_alloc l = init (ltype l)"
  proof (intro allI impI)
    fix l
    assume unalive: "\<not> aliveImpl (ref l) ?s_alloc"
    show "vals ?s_alloc l = init (ltype l)"
    proof (cases "l = arrLenLoc T (newAID (Rep_Store s) T)")
      case True
      with unalive show ?thesis by (simp add: aliveImpl_def)
    next
      case False
      from unalive
      have "\<not> aliveImpl (ref l) (Rep_Store s)"
        by (simp add: aliveImpl_def split: Value.splits split_if_asm)
      with s have "vals (Rep_Store s) l = init (ltype l)"
        by (simp add: Store_def)
      with False show ?thesis
        by simp
    qed
  qed
  moreover
  from s have "\<forall> l. typeof (vals ?s_alloc l) \<le> ltype l"
    by (simp add: Store_def)
  ultimately
  show ?thesis
    by (simp add: Store_def)
qed

lemma new_alive_alloc [simp,intro]: "alive (new s t) (s\<langle>t\<rangle>)"
proof (cases t)
  case new_instance thus ?thesis
    by (simp add: alive_def aliveImpl_def new_def alloc_def
                  alloc_new_instance_in_Store [THEN Abs_Store_inverse])
next
  case new_array thus ?thesis
    by (simp add: alive_def aliveImpl_def new_def alloc_def
                  alloc_new_array_in_Store [THEN Abs_Store_inverse])
qed

lemma value_class_inhabitants:
"(\<forall>x. typeof x = CClassT typeId \<longrightarrow> P x) = (\<forall> a. P (objV typeId a))"
  (is "(\<forall> x. ?A x) = ?B")
proof
  assume "\<forall> x. ?A x" thus "?B"
    by simp
next
  assume B: "?B" show "\<forall> x. ?A x"
  proof
    fix x from B show "?A x"
      by (cases x) auto
  qed
qed

lemma value_array_inhabitants:
"(\<forall>x. typeof x = ArrT typeId \<longrightarrow> P x) = (\<forall> a. P (arrV typeId a))"
  (is "(\<forall> x. ?A x) = ?B")
proof
  assume "\<forall> x. ?A x" thus "?B"
    by simp
next
  assume B: "?B" show "\<forall> x. ?A x"
  proof
    fix x from B show "?A x"
      by (cases x) auto
  qed
qed

text {* The following three lemmas are helper lemmas that are not related to the store theory.
They might as well be stored in a separate helper theory.
*}

lemma le_Suc_eq: "(\<forall>a. (a < Suc n) = (a < Suc m)) = (\<forall>a. (a < n) = (a < m))"
 (is "(\<forall>a. ?A a) = (\<forall> a. ?B a)")
proof
  assume "\<forall>a. ?A a" thus "\<forall> a. ?B a"
    by fastforce
next
  assume B: "\<forall> a. ?B a"
  show "\<forall>a. ?A a"
  proof
    fix a
    from B show "?A a"
      by (cases a) simp_all
  qed
qed

lemma all_le_eq_imp_eq: "\<And> c::nat. (\<forall>a. (a < d) = (a < c)) \<longrightarrow> (d = c)"
proof (induct d)
  case 0 thus ?case by fastforce
next
  case (Suc n c)
  thus ?case
    by (cases c) (auto simp add: le_Suc_eq)
qed

lemma all_le_eq: "(\<forall> a::nat. (a < d) = (a < c)) = (d = c)"
using all_le_eq_imp_eq by auto

text {* Store11 *}
lemma typeof_new: "typeof (new s t) = typeofNew t"
  by (cases t) (simp_all add: new_def typeofNew_def)

text {* Store12 *}
lemma new_eq: "(new s1 t = new s2 t) =
                 (\<forall> x. typeof x = typeofNew t \<longrightarrow> alive x s1 = alive x s2)"
by (cases t)
   (auto simp add: new_def typeofNew_def alive_def aliveImpl_def
                   value_class_inhabitants value_array_inhabitants all_le_eq)

lemma new_update [simp]: "new (s\<langle>l:=x\<rangle>) t = new s t"
  by (simp add: new_eq)

lemma alive_alloc_propagation:
  assumes alive_s: "alive x s" shows  "alive x (s\<langle>t\<rangle>)"
proof (cases t)
  case new_instance with alive_s show ?thesis
    by (cases x)
       (simp_all add: alive_def aliveImpl_def alloc_def
                      alloc_new_instance_in_Store [THEN Abs_Store_inverse])
next
  case new_array with alive_s show ?thesis
    by (cases x)
       (simp_all add: alive_def aliveImpl_def alloc_def
                      alloc_new_array_in_Store [THEN Abs_Store_inverse])
qed

text {* Store7 *}
lemma alive_alloc_exhaust: "alive x (s\<langle>t\<rangle>) = (alive x s \<or> (x = new s t))"
proof
  assume alive_alloc: "alive x (s\<langle>t\<rangle>)"
  show "alive x s \<or> x = new s t"
  proof (cases t)
    case (new_instance C)
    with alive_alloc show ?thesis
      by (cases x) (auto split: split_if_asm
                         simp add: alive_def new_def alloc_def aliveImpl_def
                              alloc_new_instance_in_Store [THEN Abs_Store_inverse])
  next
    case (new_array T l)
    with alive_alloc show ?thesis
      by (cases x) (auto split: split_if_asm
                         simp add: alive_def new_def alloc_def aliveImpl_def
                         alloc_new_array_in_Store [THEN Abs_Store_inverse])
  qed
next
  assume "alive x s \<or> x = new s t"
  then show "alive x (s\<langle>t\<rangle>)"
  proof
    assume "alive x s" thus ?thesis by (rule alive_alloc_propagation)
  next
    assume new: "x=new s t" show ?thesis
    proof (cases t)
      case new_instance with new show ?thesis
        by (simp add: alive_def aliveImpl_def new_def alloc_def
                      alloc_new_instance_in_Store [THEN Abs_Store_inverse])
    next
      case new_array with new show ?thesis
        by (simp add: alive_def aliveImpl_def new_def alloc_def
                      alloc_new_array_in_Store [THEN Abs_Store_inverse])
    qed
  qed
qed

lemma alive_alloc_cases [consumes 1]:
  "\<lbrakk>alive x (s\<langle>t\<rangle>); alive x s \<Longrightarrow> P; x=new s t \<Longrightarrow> P\<rbrakk>
   \<Longrightarrow> P"
  by (auto simp add: alive_alloc_exhaust)

lemma aliveImpl_vals_independent: "aliveImpl x (s\<lparr>vals := z\<rparr>) = aliveImpl x s"
  by (cases x) (simp_all add: aliveImpl_def)

lemma access_arr_len_new_alloc [simp]:
  "s\<langle>new_array T l\<rangle>@@arr_len (new s (new_array T l)) = intgV (int l)"
  by (subst access_def)
     (simp add: new_def alloc_def alive_def
                alloc_new_array_in_Store [THEN Abs_Store_inverse] access_def)

lemma access_new [simp]:
  assumes ref_new: "ref l = new s t"
  assumes no_arr_len: "isNewArr t \<longrightarrow> l \<noteq> arr_len (new s t)"
  shows "s\<langle>t\<rangle>@@l = init (ltype l)"
proof -
  from ref_new
  have "\<not> alive (ref l) s"
    by simp
  hence "s@@l = init (ltype l)"
    by simp
  moreover
  from ref_new
  have "alive (ref l) (s\<langle>t\<rangle>)"
    by simp
  moreover
  from no_arr_len
  have "vals (Rep_Store (s\<langle>t\<rangle>)) l = s@@l"
    by (cases t)
       (simp_all add: alloc_def new_def access_def
                  alloc_new_instance_in_Store [THEN Abs_Store_inverse]
                  alloc_new_array_in_Store [THEN Abs_Store_inverse] )
  ultimately show "s\<langle>t\<rangle>@@l = init (ltype l)"
    by (subst access_def) (simp)
qed

text {* Store5. We have to take into account that the length of an array
is changed during allocation. *}
lemma access_alloc [simp]:
  assumes no_arr_len_new: "isNewArr t \<longrightarrow> l \<noteq> arr_len (new s t)"
  shows "s\<langle>t\<rangle>@@l = s@@l"
proof -
  show ?thesis
  proof (cases "alive (ref l) (s\<langle>t\<rangle>)")
    case True
    then
    have access_alloc_vals: "s\<langle>t\<rangle>@@l = vals (Rep_Store (s\<langle>t\<rangle>)) l"
      by (simp add: access_def alloc_def)
    from True show ?thesis
    proof (cases rule: alive_alloc_cases)
      assume alive_l_s: "alive (ref l) s"
      with new_unalive_old_Store
      have l_not_new: "ref l \<noteq> new s t"
        by fastforce
      hence "vals (Rep_Store (s\<langle>t\<rangle>)) l = s@@l"
        by (cases t)
           (auto simp add: alloc_def new_def access_def
                 alloc_new_instance_in_Store [THEN Abs_Store_inverse]
                 alloc_new_array_in_Store [THEN Abs_Store_inverse])
      with access_alloc_vals
      show ?thesis
        by simp
    next
      assume ref_new: "ref l = new s t"
      with no_arr_len_new
      have "s\<langle>t\<rangle>@@l = init (ltype l)"
        by (simp add: access_new)
      moreover
      from ref_new have "s@@l = init (ltype l)"
        by simp
      ultimately
      show ?thesis by simp
    qed
  next
    case False
    hence "s\<langle>t\<rangle>@@l = init (ltype l)"
      by (simp)
    moreover
    from False have "\<not> alive (ref l) s"
      by (auto simp add: alive_alloc_propagation)
    hence "s@@l = init (ltype l)"
      by simp
    ultimately show ?thesis by simp
  qed
qed

text {* Store13 *}
lemma Store_eqI:
  assumes eq_alive: "\<forall> x. alive x s1 = alive x s2"
  assumes eq_access: "\<forall> l. s1@@l = s2@@l"
  shows "s1=s2"
proof (cases "s1=s2")
  case True thus ?thesis .
next
  case False note neq_s1_s2 = this
  show ?thesis
  proof (cases "newOID (Rep_Store s1) = newOID (Rep_Store s2)")
    case False
    have "\<exists> C. newOID (Rep_Store s1) C \<noteq> newOID (Rep_Store s2) C"
    proof (rule ccontr)
      assume "\<not> (\<exists>C. newOID (Rep_Store s1) C \<noteq> newOID (Rep_Store s2) C)"
      then have "newOID (Rep_Store s1) = newOID (Rep_Store s2)"
        by (blast intro: ext)
      with False show False ..
    qed
    with eq_alive obtain C
      where "newOID (Rep_Store s1) C \<noteq> newOID (Rep_Store s2) C"
            "\<forall> a. alive (objV C a) s1 = alive (objV C a) s2" by auto
    then show ?thesis
      by (simp add: all_le_eq alive_def aliveImpl_def)
  next
    case True note eq_newOID = this
    show ?thesis
    proof (cases "newAID (Rep_Store s1) = newAID (Rep_Store s2)")
      case False
      have "\<exists> T. newAID (Rep_Store s1) T \<noteq> newAID (Rep_Store s2) T"
      proof (rule ccontr)
        assume "\<not> (\<exists>T. newAID (Rep_Store s1) T \<noteq> newAID (Rep_Store s2) T)"
        then have "newAID (Rep_Store s1) = newAID (Rep_Store s2)"
          by (blast intro: ext)
        with False show False ..
      qed
      with eq_alive obtain T
        where "newAID (Rep_Store s1) T \<noteq> newAID (Rep_Store s2) T"
              "\<forall> a. alive (arrV T a) s1 = alive (arrV T a) s2" by auto
      then show ?thesis
        by (simp add: all_le_eq alive_def aliveImpl_def)
    next
      case True note eq_newAID = this
      show ?thesis
      proof (cases "vals (Rep_Store s1) = vals (Rep_Store s2)")
        case True
        with eq_newOID eq_newAID
        have "(Rep_Store s1) = (Rep_Store s2)"
          by (cases "Rep_Store s1",cases "Rep_Store s2") simp
        hence "s1=s2"
          by (simp add: Rep_Store_inject)
        with neq_s1_s2 show ?thesis
          by simp
      next
        case False
        have "\<exists> l. vals (Rep_Store s1) l \<noteq> vals (Rep_Store s2) l"
        proof (rule ccontr)
          assume "\<not> (\<exists>l. vals (Rep_Store s1) l \<noteq> vals (Rep_Store s2) l)"
          hence "vals (Rep_Store s1) = vals (Rep_Store s2)"
            by (blast intro: ext)
          with False show False ..
        qed
        then obtain l
          where "vals (Rep_Store s1) l \<noteq> vals (Rep_Store s2) l"
          by auto
        with eq_access have "False"
          by (simp add: access_def)
        thus ?thesis ..
      qed
    qed
  qed
qed

text {* Lemma 3.1 in [Poetzsch-Heffter97]. The proof of this lemma is quite an
impressive demostration of readable Isar proofs since it closely follows the
textual proof. *}
lemma comm:
  assumes neq_l_new: "ref l \<noteq> new s t"
  assumes neq_x_new: "x \<noteq> new s t"
  shows "s\<langle>t\<rangle>\<langle>l:=x\<rangle> = s\<langle>l:=x\<rangle>\<langle>t\<rangle>"
proof (rule Store_eqI [rule_format])
  fix y
  show "alive y (s\<langle>t\<rangle>\<langle>l:=x\<rangle>) = alive y (s\<langle>l:=x\<rangle>\<langle>t\<rangle>)"
  proof -
    have "alive y (s\<langle>t\<rangle>\<langle>l:=x\<rangle>) = alive y (s\<langle>t\<rangle>)"
      by (rule alive_update_invariant)
    also have "\<dots> = (alive y s \<or> (y = new s t))"
      by (rule alive_alloc_exhaust)
    also have "\<dots> = (alive y (s\<langle>l:=x\<rangle>) \<or> y = new s t)"
      by (simp only: alive_update_invariant)
    also have "\<dots> = (alive y (s\<langle>l:=x\<rangle>) \<or> y = new (s\<langle>l:=x\<rangle>) t)"
    proof -
      have "new s t = new (s\<langle>l:=x\<rangle>) t"
        by simp
      thus ?thesis by simp
    qed
    also have "\<dots> = alive y (s\<langle>l:=x\<rangle>\<langle>t\<rangle>)"
      by (simp add: alive_alloc_exhaust)
    finally show ?thesis .
  qed
next
  fix k
  show "s\<langle>t\<rangle>\<langle>l := x\<rangle>@@k = s\<langle>l := x\<rangle>\<langle>t\<rangle>@@k"
  proof (cases "l=k")
    case False note neq_l_k = this
    show ?thesis
    proof (cases "isNewArr t \<longrightarrow> k \<noteq> arr_len (new s t)")
      case True
      from neq_l_k
      have  "s\<langle>t\<rangle>\<langle>l := x\<rangle>@@k = s\<langle>t\<rangle>@@k" by simp
      also from True
      have "\<dots> = s@@k" by simp
      also from neq_l_k
      have "\<dots> = s\<langle>l:=x\<rangle>@@k" by simp
      also from True
      have "\<dots> = s\<langle>l := x\<rangle>\<langle>t\<rangle>@@k"  by simp
      finally show ?thesis .
    next
      case False
      then obtain T n where
        t: "t=new_array T n" and k: "k=arr_len (new s (new_array T n))"
        by (cases t) auto
      from k have k': "k=arr_len (new (s\<langle>l := x\<rangle>) (new_array T n))"
        by simp
      from neq_l_k
      have  "s\<langle>t\<rangle>\<langle>l := x\<rangle>@@k = s\<langle>t\<rangle>@@k" by simp
      also from t k
      have "\<dots> = intgV (int n)"
        by simp
      also from t k'
      have "\<dots> = s\<langle>l := x\<rangle>\<langle>t\<rangle>@@k"
        by (simp del: new_update)
      finally show ?thesis .
    qed
  next
    case True note eq_l_k = this
    have lemma_3_1:
      "ref l \<noteq> new s t \<Longrightarrow> alive (ref l) (s\<langle>t\<rangle>) = alive (ref l) s"
      by (simp add: alive_alloc_exhaust)
    have lemma_3_2:
      "x \<noteq> new s t \<Longrightarrow> alive x (s\<langle>t\<rangle>) = alive x s"
      by (simp add: alive_alloc_exhaust)
    have lemma_3_3: "s\<langle>l:=x,t\<rangle>@@l = s\<langle>l:=x\<rangle>@@l"
    proof -
      from neq_l_new have "ref l \<noteq> new (s\<langle>l:=x\<rangle>) t"
        by simp
      hence "isNewArr t \<longrightarrow> l \<noteq> arr_len (new (s\<langle>l:=x\<rangle>) t)"
        by (cases t) auto
      thus ?thesis
        by (simp)
    qed
    show ?thesis
    proof (cases "alive x s")
      case True note alive_x = this
      show ?thesis
      proof (cases "alive (ref l) s")
        case True note alive_l = this
        show ?thesis
        proof (cases "typeof x \<le> ltype l")
          case True
          with alive_l alive_x
          have "s\<langle>l:=x\<rangle>@@l = x"
            by (rule update_access_same)
          moreover
          have "s\<langle>t\<rangle>\<langle>l:=x\<rangle>@@l = x"
          proof -
            from alive_l neq_l_new have "alive (ref l) (s\<langle>t\<rangle>)"
              by (simp add: lemma_3_1)
            moreover
            from alive_x neq_x_new have "alive x (s\<langle>t\<rangle>)"
              by (simp add: lemma_3_2)
            ultimately
            show "s\<langle>t\<rangle>\<langle>l:=x\<rangle>@@l = x"
              using True by (rule update_access_same)
          qed
          ultimately show ?thesis
            using eq_l_k lemma_3_3 by simp
        next
          case False
          thus ?thesis by simp
        qed
      next
        case False note not_alive_l = this
        from not_alive_l neq_l_new have "\<not> alive (ref l) (s\<langle>t\<rangle>)"
          by (simp add: lemma_3_1)
        then have "s\<langle>t\<rangle>\<langle>l:=x\<rangle>@@l = init (ltype l)"
          by simp
        also from not_alive_l have "\<dots> = s\<langle>l:=x\<rangle>@@l"
          by simp
        also have "\<dots> = s\<langle>l:=x\<rangle>\<langle>t\<rangle>@@l"
          by (simp add: lemma_3_3)
        finally show ?thesis by (simp add: eq_l_k)
      qed
    next
      case False note not_alive_x = this
      from not_alive_x neq_x_new have "\<not> alive x (s\<langle>t\<rangle>)"
        by (simp add: lemma_3_2)
      then have "s\<langle>t\<rangle>\<langle>l:=x\<rangle>@@l = s\<langle>t\<rangle>@@l"
        by (simp)
      also have "\<dots> = s@@l"
      proof -
        from neq_l_new
        have "isNewArr t \<longrightarrow> l \<noteq> arr_len (new s t)"
          by (cases t) auto
        thus ?thesis
          by (simp)
      qed
      also from not_alive_x have "\<dots> = s\<langle>l:=x\<rangle>@@l"
        by (simp)
      also have "\<dots> = s\<langle>l:=x\<rangle>\<langle>t\<rangle>@@l"
        by (simp add: lemma_3_3)
      finally show ?thesis by (simp add: eq_l_k)
    qed
  qed
qed

end