theory CTL
  imports Graphs
begin

lemmas [simp] = holds.simps

context Graph_Defs
begin

definition
  "Alw_ev \<phi> x \<equiv> \<forall> xs. run (x ## xs) \<longrightarrow> ev (holds \<phi>) (x ## xs)"

definition
  "Alw_alw \<phi> x \<equiv> \<forall> xs. run (x ## xs) \<longrightarrow> alw (holds \<phi>) (x ## xs)"

definition
  "Ex_ev \<phi> x \<equiv> \<exists> xs. run (x ## xs) \<and> ev (holds \<phi>) (x ## xs)"

definition
  "Ex_alw \<phi> x \<equiv> \<exists> xs. run (x ## xs) \<and> alw (holds \<phi>) (x ## xs)"

definition
  "leadsto \<phi> \<psi> x \<equiv> Alw_alw (\<lambda> x. \<phi> x \<longrightarrow> Alw_ev \<psi> x) x"

definition
  "deadlocked x \<equiv> \<not> (\<exists> y. x \<rightarrow> y)"

definition
  "deadlock x \<equiv> \<exists> y. reaches x y \<and> deadlocked y"

lemma no_deadlockD:
  "\<not> deadlocked y" if "\<not> deadlock x" "reaches x y"
  using that unfolding deadlock_def by auto

lemma not_deadlockedE:
  assumes "\<not> deadlocked x"
  obtains y where "x \<rightarrow> y"
  using assms unfolding deadlocked_def by auto

lemma holds_Not:
  "holds (Not \<circ> \<phi>) = (\<lambda> x. \<not> holds \<phi> x)"
  by auto

lemma Alw_alw_iff:
  "Alw_alw \<phi> x \<longleftrightarrow> \<not> Ex_ev (Not o \<phi>) x"
  unfolding Alw_alw_def Ex_ev_def holds_Not not_ev_not[symmetric] by simp

lemma Ex_alw_iff:
  "Ex_alw \<phi> x \<longleftrightarrow> \<not> Alw_ev (Not o \<phi>) x"
  unfolding Alw_ev_def Ex_alw_def holds_Not not_ev_not[symmetric] by simp

lemma leadsto_iff:
  "leadsto \<phi> \<psi> x \<longleftrightarrow> \<not> Ex_ev (\<lambda> x. \<phi> x \<and> \<not> Alw_ev \<psi> x) x"
  unfolding leadsto_def Alw_alw_iff by (simp add: comp_def)

lemma run_siterate_from:
  assumes "\<forall>y. x \<rightarrow>* y \<longrightarrow> (\<exists> z. y \<rightarrow> z)"
  shows "run (siterate (\<lambda> x. SOME y. x \<rightarrow> y) x)" (is "run (siterate ?f x)")
  using assms
proof (coinduction arbitrary: x)
  case (run x)
  let ?y = "SOME y. x \<rightarrow> y"
  from run have "x \<rightarrow> ?y"
    by (auto intro: someI)
  with run show ?case including graph_automation_aggressive by auto
qed

(* XXX Move *)
lemma extend_run':
  "run zs" if "steps xs" "run ys" "last xs = shd ys" "xs @- stl ys = zs"
  (* s/h *)
  by (metis
      Graph_Defs.run.cases Graph_Defs.steps_non_empty' extend_run
      stream.exhaust_sel stream.inject that)

lemma no_deadlock_run_extend:
  "\<exists> ys. run (x ## xs @- ys)" if "\<not> deadlock x" "steps (x # xs)"
proof -
  include graph_automation
  let ?x = "last (x # xs)" let ?f = "\<lambda> x. SOME y. x \<rightarrow> y" let ?ys = "siterate ?f ?x"
  have "\<exists>z. y \<rightarrow> z" if "?x \<rightarrow>* y" for y
  proof -
    from \<open>steps (x # xs)\<close> have "x \<rightarrow>* ?x"
    by auto
    from \<open>x \<rightarrow>* ?x\<close> \<open>?x \<rightarrow>* y\<close> have "x \<rightarrow>* y"
      by auto
    with \<open>\<not> deadlock x\<close> show ?thesis
      by (auto dest: no_deadlockD elim: not_deadlockedE)
  qed
  then have "run ?ys"
    by (blast intro: run_siterate_from)
  with \<open>steps (x # xs)\<close> show ?thesis
    by (fastforce intro: extend_run')
qed

lemma Ex_ev:
  "Ex_ev \<phi> x \<longleftrightarrow> (\<exists> y. x \<rightarrow>* y \<and> \<phi> y)" if "\<not> deadlock x"
  unfolding Ex_ev_def
proof safe
  fix xs assume prems: "run (x ## xs)" "ev (holds \<phi>) (x ## xs)"
  show "\<exists>y. x \<rightarrow>* y \<and> \<phi> y"
  proof (cases "\<phi> x")
    case True
    then show ?thesis
      by auto
  next
    case False
    with prems obtain y ys zs where
      "\<phi> y" "xs = ys @- y ## zs" "y \<notin> set ys"
      unfolding ev_holds_sset by (auto elim!:split_stream_first')
    with prems have "steps (x # ys @ [y])"
      by (auto intro: run_decomp[THEN conjunct1]) (* XXX *)
    with \<open>\<phi> y\<close> show ?thesis
      including graph_automation by (auto 4 3)
  qed
next
  fix y assume "x \<rightarrow>* y" "\<phi> y"
  then obtain xs where
    "\<phi> (last xs)" "x = hd xs" "steps xs" "y = last xs"
    by (auto dest: reaches_steps)
  then show "\<exists>xs. run (x ## xs) \<and> ev (holds \<phi>) (x ## xs)"
    by (cases xs)
       (auto split: if_split_asm simp: ev_holds_sset dest!: no_deadlock_run_extend[OF that])
qed

lemma Alw_ev:
  "Alw_ev \<phi> x \<longleftrightarrow> \<not> (\<exists> xs. run (x ## xs) \<and> alw (holds (Not o \<phi>)) (x ## xs))"
  unfolding Alw_ev_def
proof (safe, goal_cases)
  case prems: (1 xs)
  then have "ev (holds \<phi>) (x ## xs)" by auto
  then show ?case
    using prems(2,3) by induction (auto intro: run_stl)
next
  case prems: (2 xs)
  then have "\<not> alw (holds (Not \<circ> \<phi>)) (x ## xs)"
    by auto
  moreover have "(\<lambda> x. \<not> holds (Not \<circ> \<phi>) x) = holds \<phi>"
    by (rule ext) simp
  ultimately show ?case
    unfolding not_alw_iff by simp
qed

lemma leadsto_iff':
  "leadsto \<phi> \<psi> x \<longleftrightarrow> (\<nexists>y. x \<rightarrow>* y \<and> \<phi> y \<and> \<not> Alw_ev \<psi> y)" if "\<not> deadlock x"
  unfolding leadsto_iff Ex_ev[OF \<open>\<not> deadlock x\<close>] ..

end (* Graph Defs *)

context Bisimulation_Invariant
begin

context
  fixes \<phi> :: "'a \<Rightarrow> bool" and \<psi> :: "'b \<Rightarrow> bool"
  assumes compatible: "A_B.equiv' a b \<Longrightarrow> \<phi> a \<longleftrightarrow> \<psi> b"
begin

lemma ev_\<psi>_\<phi>:
  "ev (holds \<phi>) xs" if "stream_all2 B_A.equiv' ys xs" "ev (holds \<psi>) ys"
  using that
  apply -
  apply (drule stream_all2_rotate_1)
  apply (drule ev_imp_shift)
  apply clarify
  unfolding stream_all2_shift2
  apply (subst (asm) stream.rel_sel)
  apply (auto intro!: ev_shift dest!: compatible[symmetric])
  done

lemma ev_\<phi>_\<psi>:
  "ev (holds \<psi>) ys" if "stream_all2 A_B.equiv' xs ys" "ev (holds \<phi>) xs"
  using that
  apply -
  apply (subst (asm) stream.rel_flip[symmetric])
  apply (drule ev_imp_shift)
  apply clarify
  unfolding stream_all2_shift2
  apply (subst (asm) stream.rel_sel)
  apply (auto intro!: ev_shift dest!: compatible)
  done

lemma Ex_ev_iff:
  "A.Ex_ev \<phi> a \<longleftrightarrow> B.Ex_ev \<psi> b" if "A_B.equiv' a b"
  unfolding Graph_Defs.Ex_ev_def
  apply safe
  subgoal for xs
    apply (drule A_B.simulation_run[of a xs b])
    subgoal
      using that .
    apply clarify
    subgoal for ys
      apply (inst_existentials ys)
      using that
       apply (auto intro!: ev_\<phi>_\<psi> dest: stream_all2_rotate_1)
      done
    done
  subgoal for ys
    apply (drule B_A.simulation_run[of b ys a])
    subgoal
      using that by (rule equiv'_rotate_1)
    apply clarify
    subgoal for xs
      apply (inst_existentials xs)
      using that
       apply (auto intro!: ev_\<psi>_\<phi> dest: equiv'_rotate_1)
      done
    done
  done

lemma Alw_ev_iff:
  "A.Alw_ev \<phi> a \<longleftrightarrow> B.Alw_ev \<psi> b" if "A_B.equiv' a b"
  unfolding Graph_Defs.Alw_ev_def
  apply safe
  subgoal for ys
    apply (drule B_A.simulation_run[of b ys a])
    subgoal
      using that by (rule equiv'_rotate_1)
    apply safe
    subgoal for xs
      apply (inst_existentials xs)
        apply (elim allE impE, assumption)
      using that
        apply (auto intro!: ev_\<phi>_\<psi> dest: stream_all2_rotate_1)
      done
    done
  subgoal for xs
    apply (drule A_B.simulation_run[of a xs b])
    subgoal
      using that .
    apply safe
    subgoal for ys
      apply (inst_existentials ys)
      apply (elim allE impE, assumption)
      using that
      apply (auto intro!: ev_\<psi>_\<phi>)
       apply (erule equiv'_rotate_1)
        apply (erule stream_all2_rotate_2)
      done
    done
  done

end (* Compatiblity *)

context
  fixes \<phi> :: "'a \<Rightarrow> bool" and \<psi> :: "'b \<Rightarrow> bool"
  assumes compatible1: "A_B.equiv' a b \<Longrightarrow> \<phi> a \<longleftrightarrow> \<psi> b"
begin

lemma Alw_alw_iff_strong:
  "A.Alw_alw \<phi> a \<longleftrightarrow> B.Alw_alw \<psi> b" if "A_B.equiv' a b"
  unfolding Graph_Defs.Alw_alw_iff using that by (auto dest: compatible1 intro!: Ex_ev_iff)

lemma Ex_alw_iff:
  "A.Ex_alw \<phi> a \<longleftrightarrow> B.Ex_alw \<psi> b" if "A_B.equiv' a b"
  unfolding Graph_Defs.Ex_alw_iff using that by (auto dest: compatible1 intro!: Alw_ev_iff)

end (* Compatibility *)

context
  fixes \<phi> :: "'a \<Rightarrow> bool" and \<psi> :: "'b \<Rightarrow> bool"
    and \<phi>' :: "'a \<Rightarrow> bool" and \<psi>' :: "'b \<Rightarrow> bool"
  assumes compatible1: "A_B.equiv' a b \<Longrightarrow> \<phi> a \<longleftrightarrow> \<psi> b"
  assumes compatible2: "A_B.equiv' a b \<Longrightarrow> \<phi>' a \<longleftrightarrow> \<psi>' b"
begin

lemma Leadsto_iff:
  "A.leadsto \<phi> \<phi>' a \<longleftrightarrow> B.leadsto \<psi> \<psi>' b" if "A_B.equiv' a b"
  unfolding Graph_Defs.leadsto_def
  by (auto
        dest: Alw_ev_iff[of \<phi>' \<psi>', rotated] compatible1 compatible2 equiv'_D
        intro!: Alw_alw_iff_strong[OF _ that]
     )

end (* Compatibility *)

lemma deadlock_iff:
  "A.deadlock a \<longleftrightarrow> B.deadlock b" if "a \<sim> b" "PA a" "PB b"
  using that unfolding A.deadlock_def A.deadlocked_def B.deadlock_def B.deadlocked_def
  by (force dest: A_B_step B_A_step B_A.simulation_reaches A_B.simulation_reaches)

end

lemmas [simp del] = holds.simps

end (* Theory *)


(*  Title:      Uint16.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Unsigned words of 16 bits\<close>

theory Uint16 imports
  Word_Type_Copies
  Code_Target_Integer_Bit
begin

text \<open>
  Restriction for ML code generation:
  This theory assumes that the ML system provides a Word16
  implementation (mlton does, but PolyML 5.5 does not).
  Therefore, the code setup lives in the target \<open>SML_word\<close>
  rather than \<open>SML\<close>.  This ensures that code generation still
  works as long as \<open>uint16\<close> is not involved.
  For the target \<open>SML\<close> itself, no special code generation
  for this type is set up. Nevertheless, it should work by emulation via \<^typ>\<open>16 word\<close>
  if the theory \<^text>\<open>Code_Target_Int_Bit\<close> is imported.

  Restriction for OCaml code generation:
  OCaml does not provide an int16 type, so no special code generation
  for this type is set up.
\<close>

section \<open>Type definition and primitive operations\<close>

typedef uint16 = \<open>UNIV :: 16 word set\<close> ..

global_interpretation uint16: word_type_copy Abs_uint16 Rep_uint16
  using type_definition_uint16 by (rule word_type_copy.intro)

setup_lifting type_definition_uint16

declare uint16.of_word_of [code abstype]

declare Quotient_uint16 [transfer_rule]

instantiation uint16 :: \<open>{comm_ring_1, semiring_modulo, equal, linorder}\<close>
begin

lift_definition zero_uint16 :: uint16 is 0 .
lift_definition one_uint16 :: uint16 is 1 .
lift_definition plus_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(+)\<close> .
lift_definition uminus_uint16 :: \<open>uint16 \<Rightarrow> uint16\<close> is uminus .
lift_definition minus_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(-)\<close> .
lift_definition times_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(*)\<close> .
lift_definition divide_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(div)\<close> .
lift_definition modulo_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>(mod)\<close> .
lift_definition equal_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> bool\<close> is \<open>HOL.equal\<close> .
lift_definition less_eq_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> bool\<close> is \<open>(\<le>)\<close> .
lift_definition less_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> bool\<close> is \<open>(<)\<close> .

global_interpretation uint16: word_type_copy_ring Abs_uint16 Rep_uint16
  by standard (fact zero_uint16.rep_eq one_uint16.rep_eq
    plus_uint16.rep_eq uminus_uint16.rep_eq minus_uint16.rep_eq
    times_uint16.rep_eq divide_uint16.rep_eq modulo_uint16.rep_eq
    equal_uint16.rep_eq less_eq_uint16.rep_eq less_uint16.rep_eq)+

instance proof -
  show \<open>OFCLASS(uint16, comm_ring_1_class)\<close>
    by (rule uint16.of_class_comm_ring_1)
  show \<open>OFCLASS(uint16, semiring_modulo_class)\<close>
    by (fact uint16.of_class_semiring_modulo)
  show \<open>OFCLASS(uint16, equal_class)\<close>
    by (fact uint16.of_class_equal)
  show \<open>OFCLASS(uint16, linorder_class)\<close>
    by (fact uint16.of_class_linorder)
qed

end

instantiation uint16 :: ring_bit_operations
begin

lift_definition bit_uint16 :: \<open>uint16 \<Rightarrow> nat \<Rightarrow> bool\<close> is bit .
lift_definition not_uint16 :: \<open>uint16 \<Rightarrow> uint16\<close> is \<open>Bit_Operations.not\<close> .
lift_definition and_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>Bit_Operations.and\<close> .
lift_definition or_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>Bit_Operations.or\<close> .
lift_definition xor_uint16 :: \<open>uint16 \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is \<open>Bit_Operations.xor\<close> .
lift_definition mask_uint16 :: \<open>nat \<Rightarrow> uint16\<close> is mask .
lift_definition push_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is push_bit .
lift_definition drop_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is drop_bit .
lift_definition signed_drop_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is signed_drop_bit .
lift_definition take_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is take_bit .
lift_definition set_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is Bit_Operations.set_bit .
lift_definition unset_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is unset_bit .
lift_definition flip_bit_uint16 :: \<open>nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is flip_bit .

global_interpretation uint16: word_type_copy_bits Abs_uint16 Rep_uint16 signed_drop_bit_uint16
  by standard (fact bit_uint16.rep_eq not_uint16.rep_eq and_uint16.rep_eq or_uint16.rep_eq xor_uint16.rep_eq
    mask_uint16.rep_eq push_bit_uint16.rep_eq drop_bit_uint16.rep_eq signed_drop_bit_uint16.rep_eq take_bit_uint16.rep_eq
    set_bit_uint16.rep_eq unset_bit_uint16.rep_eq flip_bit_uint16.rep_eq)+

instance
  by (fact uint16.of_class_ring_bit_operations)

end

lift_definition uint16_of_nat :: \<open>nat \<Rightarrow> uint16\<close>
  is word_of_nat .

lift_definition nat_of_uint16 :: \<open>uint16 \<Rightarrow> nat\<close>
  is unat .

lift_definition uint16_of_int :: \<open>int \<Rightarrow> uint16\<close>
  is word_of_int .

lift_definition int_of_uint16 :: \<open>uint16 \<Rightarrow> int\<close>
  is uint .

context
  includes integer.lifting
begin

lift_definition Uint16 :: \<open>integer \<Rightarrow> uint16\<close>
  is word_of_int .

lift_definition integer_of_uint16 :: \<open>uint16 \<Rightarrow> integer\<close>
  is uint .

end

global_interpretation uint16: word_type_copy_more Abs_uint16 Rep_uint16 signed_drop_bit_uint16
  uint16_of_nat nat_of_uint16 uint16_of_int int_of_uint16 Uint16 integer_of_uint16
  apply standard
       apply (simp_all add: uint16_of_nat.rep_eq nat_of_uint16.rep_eq
         uint16_of_int.rep_eq int_of_uint16.rep_eq
         Uint16.rep_eq integer_of_uint16.rep_eq integer_eq_iff)
  done

instantiation uint16 :: "{size, msb, lsb, set_bit, bit_comprehension}"
begin

lift_definition size_uint16 :: \<open>uint16 \<Rightarrow> nat\<close> is size .

lift_definition msb_uint16 :: \<open>uint16 \<Rightarrow> bool\<close> is msb .
lift_definition lsb_uint16 :: \<open>uint16 \<Rightarrow> bool\<close> is lsb .

text \<open>Workaround: avoid name space clash by spelling out \<^text>\<open>lift_definition\<close> explicitly.\<close>

definition set_bit_uint16 :: \<open>uint16 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint16\<close>
  where set_bit_uint16_eq: \<open>set_bit_uint16 a n b = (if b then Bit_Operations.set_bit else unset_bit) n a\<close>

context
  includes lifting_syntax
begin

lemma set_bit_uint16_transfer [transfer_rule]:
  \<open>(cr_uint16 ===> (=) ===> (\<longleftrightarrow>) ===> cr_uint16) Generic_set_bit.set_bit Generic_set_bit.set_bit\<close>
  by (simp only: set_bit_eq [abs_def] set_bit_uint16_eq [abs_def]) transfer_prover

end

lift_definition set_bits_uint16 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> uint16\<close> is set_bits .
lift_definition set_bits_aux_uint16 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> uint16 \<Rightarrow> uint16\<close> is set_bits_aux .

global_interpretation uint16: word_type_copy_misc Abs_uint16 Rep_uint16 signed_drop_bit_uint16
  uint16_of_nat nat_of_uint16 uint16_of_int int_of_uint16 Uint16 integer_of_uint16 16 set_bits_aux_uint16
  by (standard; transfer) simp_all

instance using uint16.of_class_bit_comprehension
  uint16.of_class_set_bit uint16.of_class_lsb
  by simp_all standard

end

section \<open>Code setup\<close>

code_printing code_module Uint16 \<rightharpoonup> (SML_word)
\<open>(* Test that words can handle numbers between 0 and 15 *)
val _ = if 4 <= Word.wordSize then () else raise (Fail ("wordSize less than 4"));

structure Uint16 : sig
  val set_bit : Word16.word -> IntInf.int -> bool -> Word16.word
  val shiftl : Word16.word -> IntInf.int -> Word16.word
  val shiftr : Word16.word -> IntInf.int -> Word16.word
  val shiftr_signed : Word16.word -> IntInf.int -> Word16.word
  val test_bit : Word16.word -> IntInf.int -> bool
end = struct

fun set_bit x n b =
  let val mask = Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
  in if b then Word16.orb (x, mask)
     else Word16.andb (x, Word16.notb mask)
  end

fun shiftl x n =
  Word16.<< (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr x n =
  Word16.>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr_signed x n =
  Word16.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun test_bit x n =
  Word16.andb (x, Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word16.fromInt 0

end; (* struct Uint16 *)\<close>
code_reserved SML_word Uint16

code_printing code_module Uint16 \<rightharpoonup> (Haskell)
 \<open>module Uint16(Int16, Word16) where

  import Data.Int(Int16)
  import Data.Word(Word16)\<close>
code_reserved Haskell Uint16

text \<open>Scala provides unsigned 16-bit numbers as Char.\<close>

code_printing code_module Uint16 \<rightharpoonup> (Scala)
\<open>object Uint16 {

def set_bit(x: scala.Char, n: BigInt, b: Boolean) : scala.Char =
  if (b)
    (x | (1.toChar << n.intValue)).toChar
  else
    (x & (1.toChar << n.intValue).unary_~).toChar

def shiftl(x: scala.Char, n: BigInt) : scala.Char = (x << n.intValue).toChar

def shiftr(x: scala.Char, n: BigInt) : scala.Char = (x >>> n.intValue).toChar

def shiftr_signed(x: scala.Char, n: BigInt) : scala.Char = (x.toShort >> n.intValue).toChar

def test_bit(x: scala.Char, n: BigInt) : Boolean = (x & (1.toChar << n.intValue)) != 0

} /* object Uint16 */\<close>
code_reserved Scala Uint16

text \<open>
  Avoid @{term Abs_uint16} in generated code, use @{term Rep_uint16'} instead.
  The symbolic implementations for code\_simp use @{term Rep_uint16}.

  The new destructor @{term Rep_uint16'} is executable.
  As the simplifier is given the [code abstract] equations literally,
  we cannot implement @{term Rep_uint16} directly, because that makes code\_simp loop.

  If code generation raises Match, some equation probably contains @{term Rep_uint16}
  ([code abstract] equations for @{typ uint16} may use @{term Rep_uint16} because
  these instances will be folded away.)

  To convert @{typ "16 word"} values into @{typ uint16}, use @{term "Abs_uint16'"}.
\<close>

definition Rep_uint16' where [simp]: "Rep_uint16' = Rep_uint16"

lemma Rep_uint16'_transfer [transfer_rule]:
  "rel_fun cr_uint16 (=) (\<lambda>x. x) Rep_uint16'"
unfolding Rep_uint16'_def by(rule uint16.rep_transfer)

lift_definition Abs_uint16' :: "16 word \<Rightarrow> uint16" is "\<lambda>x :: 16 word. x" .

lemma Abs_uint16'_code [code]:
  "Abs_uint16' x = Uint16 (integer_of_int (uint x))"
including integer.lifting by transfer simp

declare [[code drop: "term_of_class.term_of :: uint16 \<Rightarrow> _"]]

lemma term_of_uint16_code [code]:
  defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''" shows
  "term_of_class.term_of x =
   Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint16.uint16.Abs_uint16'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]], TR (STR ''Uint16.uint16'') []]))
       (term_of_class.term_of (Rep_uint16' x))"
by(simp add: term_of_anything)

lemma Uint16_code [code]: "Rep_uint16 (Uint16 i) = word_of_int (int_of_integer_symbolic i)"
unfolding Uint16_def int_of_integer_symbolic_def by(simp add: Abs_uint16_inverse)

code_printing
  type_constructor uint16 \<rightharpoonup>
  (SML_word) "Word16.word" and
  (Haskell) "Uint16.Word16" and
  (Scala) "scala.Char"
| constant Uint16 \<rightharpoonup>
  (SML_word) "Word16.fromLargeInt (IntInf.toLarge _)" and
  (Haskell) "(Prelude.fromInteger _ :: Uint16.Word16)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Word16)" and
  (Scala) "_.charValue"
| constant "0 :: uint16" \<rightharpoonup>
  (SML_word) "(Word16.fromInt 0)" and
  (Haskell) "(0 :: Uint16.Word16)" and
  (Scala) "0"
| constant "1 :: uint16" \<rightharpoonup>
  (SML_word) "(Word16.fromInt 1)" and
  (Haskell) "(1 :: Uint16.Word16)" and
  (Scala) "1"
| constant "plus :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.+ ((_), (_))" and
  (Haskell) infixl 6 "+" and
  (Scala) "(_ +/ _).toChar"
| constant "uminus :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.~" and
  (Haskell) "negate" and
  (Scala) "(- _).toChar"
| constant "minus :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.- ((_), (_))" and
  (Haskell) infixl 6 "-" and
  (Scala) "(_ -/ _).toChar"
| constant "times :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.* ((_), (_))" and
  (Haskell) infixl 7 "*" and
  (Scala) "(_ */ _).toChar"
| constant "HOL.equal :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "!((_ : Word16.word) = _)" and
  (Haskell) infix 4 "==" and
  (Scala) infixl 5 "=="
| class_instance uint16 :: equal \<rightharpoonup> (Haskell) -
| constant "less_eq :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "Word16.<= ((_), (_))" and
  (Haskell) infix 4 "<=" and
  (Scala) infixl 4 "<="
| constant "less :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "Word16.< ((_), (_))" and
  (Haskell) infix 4 "<" and
  (Scala) infixl 4 "<"
| constant "Bit_Operations.not :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.notb" and
  (Haskell) "Data'_Bits.complement" and
  (Scala) "_.unary'_~.toChar"
| constant "Bit_Operations.and :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.andb ((_),/ (_))" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (Scala) "(_ & _).toChar"
| constant "Bit_Operations.or :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.orb ((_),/ (_))" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (Scala) "(_ | _).toChar"
| constant "Bit_Operations.xor :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.xorb ((_),/ (_))" and
  (Haskell) "Data'_Bits.xor" and
  (Scala) "(_ ^ _).toChar"

definition uint16_div :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
where "uint16_div x y = (if y = 0 then undefined ((div) :: uint16 \<Rightarrow> _) x (0 :: uint16) else x div y)"

definition uint16_mod :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
where "uint16_mod x y = (if y = 0 then undefined ((mod) :: uint16 \<Rightarrow> _) x (0 :: uint16) else x mod y)"

context includes undefined_transfer begin

lemma div_uint16_code [code]: "x div y = (if y = 0 then 0 else uint16_div x y)"
unfolding uint16_div_def by transfer (simp add: word_div_def)

lemma mod_uint16_code [code]: "x mod y = (if y = 0 then x else uint16_mod x y)"
unfolding uint16_mod_def by transfer (simp add: word_mod_def)

lemma uint16_div_code [code]:
  "Rep_uint16 (uint16_div x y) =
  (if y = 0 then Rep_uint16 (undefined ((div) :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x div Rep_uint16 y)"
unfolding uint16_div_def by transfer simp

lemma uint16_mod_code [code]:
  "Rep_uint16 (uint16_mod x y) =
  (if y = 0 then Rep_uint16 (undefined ((mod) :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x mod Rep_uint16 y)"
unfolding uint16_mod_def by transfer simp

end

code_printing constant uint16_div \<rightharpoonup>
  (SML_word) "Word16.div ((_), (_))" and
  (Haskell) "Prelude.div" and
  (Scala) "(_ '/ _).toChar"
| constant uint16_mod \<rightharpoonup>
  (SML_word) "Word16.mod ((_), (_))" and
  (Haskell) "Prelude.mod" and
  (Scala) "(_ % _).toChar"

definition uint16_test_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool"
where [code del]:
  "uint16_test_bit x n =
  (if n < 0 \<or> 15 < n then undefined (bit :: uint16 \<Rightarrow> _) x n
   else bit x (nat_of_integer n))"

lemma test_bit_uint16_code [code]:
  "bit x n \<longleftrightarrow> n < 16 \<and> uint16_test_bit x (integer_of_nat n)"
  including undefined_transfer integer.lifting unfolding uint16_test_bit_def
  by (transfer, simp, transfer, simp)

lemma uint16_test_bit_code [code]:
  "uint16_test_bit w n =
  (if n < 0 \<or> 15 < n then undefined (bit :: uint16 \<Rightarrow> _) w n else bit (Rep_uint16 w) (nat_of_integer n))"
  unfolding uint16_test_bit_def by (simp add: bit_uint16.rep_eq)

code_printing constant uint16_test_bit \<rightharpoonup>
  (SML_word) "Uint16.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (Scala) "Uint16.test'_bit"

definition uint16_set_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint16"
where [code del]:
  "uint16_set_bit x n b =
  (if n < 0 \<or> 15 < n then undefined (set_bit :: uint16 \<Rightarrow> _) x n b
   else set_bit x (nat_of_integer n) b)"

lemma set_bit_uint16_code [code]:
  "set_bit x n b = (if n < 16 then uint16_set_bit x (integer_of_nat n) b else x)"
including undefined_transfer integer.lifting unfolding uint16_set_bit_def
by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

lemma uint16_set_bit_code [code]:
  "Rep_uint16 (uint16_set_bit w n b) =
  (if n < 0 \<or> 15 < n then Rep_uint16 (undefined (set_bit :: uint16 \<Rightarrow> _) w n b)
   else set_bit (Rep_uint16 w) (nat_of_integer n) b)"
including undefined_transfer unfolding uint16_set_bit_def by transfer simp

code_printing constant uint16_set_bit \<rightharpoonup>
  (SML_word) "Uint16.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (Scala) "Uint16.set'_bit"

definition uint16_shiftl :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_shiftl x n = (if n < 0 \<or> 16 \<le> n then undefined (push_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) x n else push_bit (nat_of_integer n) x)"

lemma shiftl_uint16_code [code]: "push_bit n x = (if n < 16 then uint16_shiftl x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint16_shiftl_def
  by transfer simp

lemma uint16_shiftl_code [code]:
  "Rep_uint16 (uint16_shiftl w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (push_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) w n)
   else push_bit (nat_of_integer n) (Rep_uint16 w))"
  including undefined_transfer unfolding uint16_shiftl_def
  by transfer simp

code_printing constant uint16_shiftl \<rightharpoonup>
  (SML_word) "Uint16.shiftl" and
  (Haskell) "Data'_Bits.shiftlBounded" and
  (Scala) "Uint16.shiftl"

definition uint16_shiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_shiftr x n = (if n < 0 \<or> 16 \<le> n then undefined (drop_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) x n else drop_bit (nat_of_integer n) x)"

lemma shiftr_uint16_code [code]: "drop_bit n x = (if n < 16 then uint16_shiftr x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint16_shiftr_def
  by transfer simp

lemma uint16_shiftr_code [code]:
  "Rep_uint16 (uint16_shiftr w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (drop_bit :: nat \<Rightarrow> uint16 \<Rightarrow> _) w n)
   else drop_bit (nat_of_integer n) (Rep_uint16 w))"
including undefined_transfer unfolding uint16_shiftr_def by transfer simp

code_printing constant uint16_shiftr \<rightharpoonup>
  (SML_word) "Uint16.shiftr" and
  (Haskell) "Data'_Bits.shiftrBounded" and
  (Scala) "Uint16.shiftr"

definition uint16_sshiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_sshiftr x n =
  (if n < 0 \<or> 16 \<le> n then undefined signed_drop_bit_uint16 n x else signed_drop_bit_uint16 (nat_of_integer n) x)"

lemma sshiftr_uint16_code [code]:
  "signed_drop_bit_uint16 n x =
  (if n < 16 then uint16_sshiftr x (integer_of_nat n) else if bit x 15 then -1 else 0)"
  including undefined_transfer integer.lifting unfolding uint16_sshiftr_def
  by transfer (simp add: not_less signed_drop_bit_beyond word_size)

lemma uint16_sshiftr_code [code]:
  "Rep_uint16 (uint16_sshiftr w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined signed_drop_bit_uint16 n w)
   else signed_drop_bit (nat_of_integer n) (Rep_uint16 w))"
  including undefined_transfer unfolding uint16_sshiftr_def
  by transfer simp

code_printing constant uint16_sshiftr \<rightharpoonup>
  (SML_word) "Uint16.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Int16) _)) :: Uint16.Word16)" and
  (Scala) "Uint16.shiftr'_signed"

lemma uint16_msb_test_bit: "msb x \<longleftrightarrow> bit (x :: uint16) 15"
  by transfer (simp add: msb_word_iff_bit)

lemma msb_uint16_code [code]: "msb x \<longleftrightarrow> uint16_test_bit x 15"
  by (simp add: uint16_test_bit_def uint16_msb_test_bit)

lemma uint16_of_int_code [code]: "uint16_of_int i = Uint16 (integer_of_int i)"
including integer.lifting by transfer simp

lemma int_of_uint16_code [code]:
  "int_of_uint16 x = int_of_integer (integer_of_uint16 x)"
  by (simp add: int_of_uint16.rep_eq integer_of_uint16_def)

lemma uint16_of_nat_code [code]:
  "uint16_of_nat = uint16_of_int \<circ> int"
  by transfer (simp add: fun_eq_iff)

lemma nat_of_uint16_code [code]:
  "nat_of_uint16 x = nat_of_integer (integer_of_uint16 x)"
  unfolding integer_of_uint16_def including integer.lifting by transfer simp

lemma integer_of_uint16_code [code]:
  "integer_of_uint16 n = integer_of_int (uint (Rep_uint16' n))"
unfolding integer_of_uint16_def by transfer auto

code_printing
  constant "integer_of_uint16" \<rightharpoonup>
  (SML_word) "Word16.toInt _ : IntInf.int" and
  (Haskell) "Prelude.toInteger" and
  (Scala) "BigInt"

section \<open>Quickcheck setup\<close>

definition uint16_of_natural :: "natural \<Rightarrow> uint16"
where "uint16_of_natural x \<equiv> Uint16 (integer_of_natural x)"

instantiation uint16 :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint16 \<equiv> qc_random_cnv uint16_of_natural"
definition "exhaustive_uint16 \<equiv> qc_exhaustive_cnv uint16_of_natural"
definition "full_exhaustive_uint16 \<equiv> qc_full_exhaustive_cnv uint16_of_natural"
instance ..
end

instantiation uint16 :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. let x = Uint16 i in (x, 0xFFFF - x)" "0"
  "Typerep.Typerep (STR ''Uint16.uint16'') []" .

definition "narrowing_uint16 d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint16 itself \<Rightarrow> _"]]
lemmas partial_term_of_uint16 [code] = partial_term_of_code

instance ..
end

end


section \<open> Expressions \<close>

theory Expressions
  imports Variables
  keywords "pretty_exprs" "full_exprs" "lit_vars" "expr_vars" "expr_ctr" "expr_constructor" :: "thy_decl_block"
begin

subsection \<open> Types and Constructs \<close>

named_theorems expr_defs

text \<open> An expression is represented simply as a function from the state space @{typ "'s"} to
  the return type @{typ "'a"}, which is the simplest shallow model for Isabelle/HOL.

  The aim of this theory is to provide transparent conversion between this representation
  and a more intuitive expression syntax. For example, an expression @{term "x + y"} where
  $x$ and $y$ are both state variables, can be represented by @{term "\<lambda> s. get\<^bsub>x\<^esub> s + get\<^bsub>y\<^esub> s"}
  when both variables are modelled using lenses. Rather than having to write $\lambda$-terms
  directly, it is more convenient to hide this threading of state behind a parser.
\<close>

type_synonym ('a, 's) expr = "'s \<Rightarrow> 'a"

text \<open> The following constructor is used to syntactically mark functions that actually
  denote expressions. It is semantically vacuous. \<close>

definition SEXP :: "('s \<Rightarrow> 'a) \<Rightarrow> ('a, 's) expr" ("[_]\<^sub>e") where
[expr_defs]: "SEXP x = x"

lemma SEXP_apply [simp]: "SEXP e s = (e s)" by (simp add: SEXP_def)

lemma SEXP_idem [simp]: "[[e]\<^sub>e]\<^sub>e = [e]\<^sub>e" by (simp add: SEXP_def)

text \<open> We can create the core constructs of a simple expression language as indicated below. \<close>

abbreviation (input) var :: "('a \<Longrightarrow> 's) \<Rightarrow> ('a, 's) expr" where
"var x \<equiv> (\<lambda> s. get\<^bsub>x\<^esub> s)"

abbreviation (input) lit :: "'a \<Rightarrow> ('a, 's) expr" where
"lit k \<equiv> (\<lambda> s. k)"

abbreviation (input) uop :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 's) expr \<Rightarrow> ('b, 's) expr" where
"uop f e \<equiv> (\<lambda> s. f (e s))"

abbreviation (input) bop
  :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a, 's) expr \<Rightarrow> ('b, 's) expr \<Rightarrow> ('c, 's) expr" where
"bop f e\<^sub>1 e\<^sub>2 \<equiv> (\<lambda> s. f (e\<^sub>1 s) (e\<^sub>2 s))"

definition taut :: "(bool, 's) expr \<Rightarrow> bool" where
[expr_defs]: "taut e = (\<forall> s. e s)"

definition expr_select :: "('a, 's) expr \<Rightarrow> ('b \<Longrightarrow> 'a) \<Rightarrow> ('b, 's) expr" where
[expr_defs, code_unfold]: "expr_select e x = (\<lambda> s. get\<^bsub>x\<^esub> (e s))"

definition expr_if :: "('a, 's) expr \<Rightarrow> (bool, 's) expr \<Rightarrow> ('a, 's) expr \<Rightarrow> ('a, 's) expr" where
[expr_defs, code_unfold]: "expr_if P b Q = (\<lambda> s. if (b s) then P s else Q s)"

subsection \<open> Lifting Parser and Printer \<close>

text \<open> The lifting parser creates a parser directive that converts an expression to a
  @{const SEXP} boxed $\lambda$-term that gives it a semantics. A pretty printer converts
  a boxed $\lambda$-term back to an expression. \<close>

ML_file \<open>Lift_Expr_Options.ML\<close>

text \<open> We create a number of commands for configuring the way the parser works. \<close>

full_exprs
pretty_exprs

text \<open> We can disable pretty printing of $\lambda$ expressions using \textbf{full\_exprs} and
  re-enable pretty printing with \textbf{pretty\_exprs}. \<close>

lit_vars
expr_vars

text \<open> Expressions, of course, can contain variables. However, a variable can denote one of
  three things: (1) a state variable (i.e. a lens); (2) a placeholder for a value (i.e. a
  HOL literal); and (3) a placeholder for another expression. The command \textbf{lit\_vars}
  selects option (2) as the default behaviour, and \textbf{expr\_vars} selects option (3). \<close>

nonterminal sexp

text \<open> Next, we create some syntactic constants and define parse and print translations for
  them. \<close>

syntax
  "_sexp_state"      :: "id"
  "_sexp_quote"      :: "logic \<Rightarrow> logic" ("'(_')\<^sub>e")
  \<comment> \<open> Convert the expression to a lambda term, but do not box it. \<close>
  "_sexp_quote_1way" :: "logic \<Rightarrow> logic" ("'(_')\<^sup>e")
  "_sexp_lit"        :: "logic \<Rightarrow> logic" ("\<guillemotleft>_\<guillemotright>")
  "_sexp_var"        :: "svid \<Rightarrow> logic" ("$_" [990] 990)
  "_sexp_evar"       :: "id_position \<Rightarrow> logic" ("@_" [999] 999)
  "_sexp_evar"       :: "logic \<Rightarrow> logic" ("@'(_')" [999] 999)
  "_sexp_pqt"        :: "logic \<Rightarrow> sexp" ("[_]\<^sub>e")
  "_sexp_taut"       :: "logic \<Rightarrow> logic" ("`_`")
  "_sexp_select"     :: "logic \<Rightarrow> svid \<Rightarrow> logic" ("_:_" [1000, 999] 1000)
  "_sexp_if"         :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(3_ \<triangleleft> _ \<triangleright>/ _)" [52,0,53] 52)

expr_constructor expr_select
expr_constructor expr_if

ML_file \<open>Lift_Expr.ML\<close>

parse_translation \<open>
  [(@{syntax_const "_sexp_state"}, fn ctx => fn term => Syntax.free Lift_Expr.state_id),
   (@{syntax_const "_sexp_quote"}
   , fn ctx => fn terms =>
      case terms of
        [Const (@{const_syntax SEXP}, t) $ e] => Const (@{const_name SEXP}, t) $ e |
        [e] =>
            Syntax.const @{const_name SEXP} $ Lift_Expr.mk_lift_expr ctx e),
   (@{syntax_const "_sexp_quote_1way"}
   , fn ctx => fn terms =>
      case terms of
        [e] => Lift_Expr.mk_lift_expr ctx e)]
\<close>

print_translation \<open>
  [(@{const_syntax "SEXP"}
   , fn ctx => fn ts =>
     if (FullExprs.get (Proof_Context.theory_of ctx))
     then Term.list_comb (Syntax.const @{syntax_const "_sexp_pqt"}, ts)
     else
     Syntax.const @{syntax_const "_sexp_quote"}
     $ Lift_Expr.print_expr ctx (betapply ((hd ts), Syntax.const @{syntax_const "_sexp_state"})))]
\<close>

translations
  "_sexp_var x" => "get\<^bsub>x\<^esub> _sexp_state"
  "_sexp_taut p" == "CONST taut (p)\<^sub>e"
  "_sexp_select e x" == "CONST expr_select (e)\<^sub>e x"
  "_sexp_if P b Q" == "CONST expr_if P (b)\<^sub>e Q"
  "_sexp_var (_svid_tuple (_of_svid_list (x +\<^sub>L y)))" <= "_sexp_var (x +\<^sub>L y)"

text \<open> The main directive is the $e$ subscripted brackets, @{term "(e)\<^sub>e"}. This converts the
  expression $e$ to a boxed $\lambda$ term. Essentially, the parser behaviour is as follows:

  \begin{enumerate}
    \item a new $\lambda$ abstraction over the state variable $s$ is wrapped around $e$;
    \item every occurrence of free lens @{term "$x"} in $e$ is replace by @{term "get\<^bsub>x\<^esub> s"};
    \item every occurrence of an expression variable @{term "e"} is replaced by @{term "e s"}.
  \end{enumerate}

  The pretty printer does this in reverse. Some examples follow. For now, we turn of the
  pretty printer so that we can see the results of the parser.
\<close>

full_exprs

term "(f + g)\<^sub>e"
term "(f + g)\<^sup>e"

text \<open> The default behaviour of our parser is to recognise identifiers as expression variables.
  So, the above expression becomes the term @{term "[\<lambda>\<s>. f \<s> + g \<s>]\<^sub>e"}. We can easily change
  this: \<close>

lit_vars

term "(f + g)\<^sub>e"

text \<open> Now, @{term f} and @{term g} are both parsed as literals, and so the term is
  @{term "[\<lambda>\<s>. f + g]\<^sub>e"}. Alternatively, we could have a lens in the expression: \<close>

term "($x + g)\<^sub>e"

text \<open> This gives the term @{term "[\<lambda>\<s>. get\<^bsub>x\<^esub> \<s> + g]\<^sub>e"}. Although we have default behaviours
  for parsing, we can use different markup to coerce identifiers to particular variable kinds. \<close>

term "($x + @g)\<^sub>e"

text \<open> This gives @{term "[\<lambda>\<s>. get\<^bsub>x\<^esub> \<s> + g \<s>]\<^sub>e"}, the we have requested that @{term "g"} is
  treated as an expression variable. We can do similar with literal, as show below. \<close>

term "(f + \<guillemotleft>x\<guillemotright>)\<^sub>e"

text \<open> Some further examples follow. \<close>

term "(\<guillemotleft>f\<guillemotright> (@e))\<^sub>e"

term "(@f + @g)\<^sub>e"

term "(@x)\<^sub>e"

term "($x:y:z)\<^sub>e"

term "(($x:y):z)\<^sub>e"

term "(x::nat)\<^sub>e"

term "(\<forall> x::nat. x > 2)\<^sub>e"

term "SEXP(\<lambda> \<s>. get\<^bsub>x\<^esub> \<s> + e \<s> + v)"

term "(v \<in> $xs \<union> ($f) ys \<union> {} \<and> @e)\<^sub>e"

pretty_exprs
expr_vars

term "($x\<^sup>< = $x\<^sup>>)\<^sub>e"

term "($x.1 = $y.2)\<^sub>e"

text \<open> The pretty printer works even when we don't use the parser, as shown below. \<close>

term "[\<lambda> \<s>. get\<^bsub>x\<^esub> \<s> + e \<s> + v]\<^sub>e"

text \<open> A grammar category for lifted expressions \<close>

nonterminal sexpr

syntax "_sexpr" :: "logic \<Rightarrow> sexpr" ("_")

parse_translation \<open>
  [(@{syntax_const "_sexpr"}, fn ctx => fn [e] =>
    Syntax.const @{const_name SEXP}
            $ (lambda (Syntax.free Lift_Expr.state_id)
                      (Lift_Expr.lift_expr ctx (Term_Position.strip_positions e))))]
\<close>

subsection \<open> Reasoning \<close>

lemma expr_eq_iff: "P = Q \<longleftrightarrow> `P = Q`"
  by (simp add: taut_def fun_eq_iff)

lemma refine_iff_implies: "P \<le> Q \<longleftrightarrow> `P \<longrightarrow> Q`"
  by (simp add: le_fun_def taut_def)

lemma taut_True [simp]: "`True` = True"
  by (simp add: taut_def)

lemma taut_False [simp]: "`False` = False"
  by (simp add: taut_def)

lemma tautI: "\<lbrakk> \<And> s. P s \<rbrakk> \<Longrightarrow> taut P"
  by (simp add: taut_def)

named_theorems expr_simps

text \<open> Lemmas to help automation of expression reasoning \<close>

lemma fst_case_sum [simp]: "fst (case p of Inl x \<Rightarrow> (a1 x, a2 x) | Inr x \<Rightarrow> (b1 x, b2 x)) = (case p of Inl x \<Rightarrow> a1 x | Inr x \<Rightarrow> b1 x)"
  by (simp add: sum.case_eq_if)

lemma snd_case_sum [simp]: "snd (case p of Inl x \<Rightarrow> (a1 x, a2 x) | Inr x \<Rightarrow> (b1 x, b2 x)) = (case p of Inl x \<Rightarrow> a2 x | Inr x \<Rightarrow> b2 x)"
  by (simp add: sum.case_eq_if)

lemma sum_case_apply [simp]: "(case p of Inl x \<Rightarrow> f x | Inr x \<Rightarrow> g x) y = (case p of Inl x \<Rightarrow> f x y | Inr x \<Rightarrow> g x y)"
  by (simp add: sum.case_eq_if)

text \<open> A method for simplifying shallow expressions to HOL terms  \<close>

method expr_simp uses add =
  ((simp add: expr_simps)? \<comment> \<open> Perform any possible simplifications retaining the lens structure \<close>
   ;((simp add: fun_eq_iff prod.case_eq_if alpha_splits expr_defs lens_defs add)? ; \<comment> \<open> Explode the rest \<close>
     (simp add: expr_defs lens_defs add)?))

text \<open> A method for dealing with tautologies \<close>

method expr_taut uses add =
  (rule tautI;
   expr_simp add: add;
   rename_alpha_vars?)

text \<open> A method for simplifying shallow expressions to HOL terms and applying @{method auto} \<close>

method expr_auto uses add =
  (expr_simp add: add;
   (auto simp add: alpha_splits lens_defs add)?;
   (rename_alpha_vars)? \<comment> \<open> Rename any logical variables with v subscripts \<close>
  )

subsection \<open> Algebraic laws \<close>

lemma expr_if_idem [simp]: "P \<triangleleft> b \<triangleright> P = P"
  by expr_auto

lemma expr_if_sym: "P \<triangleleft> b \<triangleright> Q = Q \<triangleleft> \<not>b \<triangleright> P"
  by expr_auto

lemma expr_if_assoc: "(P \<triangleleft> b \<triangleright> Q) \<triangleleft> c \<triangleright> R = P \<triangleleft> b \<and> c \<triangleright> (Q \<triangleleft> c \<triangleright> R)"
  by expr_auto

lemma expr_if_distr: "P \<triangleleft> b \<triangleright> (Q \<triangleleft> c \<triangleright> R) = (P \<triangleleft> b \<triangleright> Q) \<triangleleft> c \<triangleright> (P \<triangleleft> b \<triangleright> R)"
  by expr_auto

lemma expr_if_true [simp]: "P \<triangleleft> True \<triangleright> Q = P"
  by expr_auto

lemma expr_if_false [simp]: "P \<triangleleft> False \<triangleright> Q = Q"
  by expr_auto

lemma expr_if_reach [simp]: "P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R) = P \<triangleleft> b \<triangleright> R"
  by expr_auto

lemma expr_if_disj [simp]: "P \<triangleleft> b \<triangleright> (P \<triangleleft> c \<triangleright> Q) = P \<triangleleft> b \<or> c \<triangleright> Q"
  by expr_auto

end


(*  Title:      HOL/Metis_Examples/Type_Encodings.thy
    Author:     Jasmin Blanchette, TU Muenchen

Example that exercises Metis's (and hence Sledgehammer's) type encodings.
*)

section \<open>
Example that Exercises Metis's (and Hence Sledgehammer's) Type Encodings
\<close>

theory Type_Encodings
imports Main
begin

declare [[metis_new_skolem]]

text \<open>Setup for testing Metis exhaustively\<close>

lemma fork: "P \<Longrightarrow> P \<Longrightarrow> P" by assumption

ML \<open>
val type_encs =
  ["erased",
   "poly_guards",
   "poly_guards?",
   "poly_guards??",
   "poly_guards@",
   "poly_tags",
   "poly_tags?",
   "poly_tags??",
   "poly_tags@",
   "poly_args",
   "poly_args?",
   "raw_mono_guards",
   "raw_mono_guards?",
   "raw_mono_guards??",
   "raw_mono_guards@",
   "raw_mono_tags",
   "raw_mono_tags?",
   "raw_mono_tags??",
   "raw_mono_tags@",
   "raw_mono_args",
   "raw_mono_args?",
   "mono_guards",
   "mono_guards?",
   "mono_guards??",
   "mono_tags",
   "mono_tags?",
   "mono_tags??",
   "mono_args"]

fun metis_exhaust_tac ctxt ths =
  let
    fun tac [] st = all_tac st
      | tac (type_enc :: type_encs) st =
        st (* |> tap (fn _ => tracing (@{make_string} type_enc)) *)
           |> ((if null type_encs then all_tac else resolve_tac ctxt @{thms fork} 1)
               THEN Metis_Tactic.metis_tac [type_enc]
                    ATP_Problem_Generate.combsN ctxt ths 1
               THEN COND (has_fewer_prems 2) all_tac no_tac
               THEN tac type_encs)
  in tac type_encs end
\<close>

method_setup metis_exhaust = \<open>
  Attrib.thms >>
    (fn ths => fn ctxt => SIMPLE_METHOD (metis_exhaust_tac ctxt ths))
\<close> "exhaustively run Metis with all type encodings"

text \<open>Miscellaneous tests\<close>

lemma "x = y \<Longrightarrow> y = x"
by metis_exhaust

lemma "[a] = [Suc 0] \<Longrightarrow> a = 1"
by (metis_exhaust last.simps One_nat_def)

lemma "map Suc [0] = [Suc 0]"
by (metis_exhaust list.map)

lemma "map Suc [1 + 1] = [Suc 2]"
by (metis_exhaust list.map nat_1_add_1)

lemma "map Suc [2] = [Suc (1 + 1)]"
by (metis_exhaust list.map nat_1_add_1)

definition "null xs = (xs = [])"

lemma "P (null xs) \<Longrightarrow> null xs \<Longrightarrow> xs = []"
by (metis_exhaust null_def)

lemma "(0::nat) + 0 = 0"
by (metis_exhaust add_0_left)

end


theory Word_Extensions
imports
  "HOL-Library.Omega_Words_Fun"
  List_Extensions
begin

  hide_const (open) Sublist.prefix Sublist.suffix

  (*abbreviation "prefix k w \<equiv> map w [0 ..< k]"*)
  abbreviation "scan f w a \<equiv> \<lambda> i. fold f (prefix i w) a"

  (*lemma set_subsequence[intro, simp]: "set (w[i\<rightarrow>j]) \<subseteq> range w"
    unfolding subsequence_def by auto*)
  lemma range_suffix[intro, simp]: "range (suffix i w) \<subseteq> range w"
    unfolding Omega_Words_Fun.suffix_def by blast

  lemma suffix_comp: "suffix i v = v \<circ> plus i" unfolding suffix_def by force

  (* \<rightarrow> see subsequence_shift
  lemma map_suffix[simp]: "map (suffix i v) [j ..< j + n] = map v [i + j ..< i + j + n]"
  proof -
    have "map (suffix i v) [j ..< j + n] = map (v \<circ> op + i) [j ..< j + n]"
      unfolding suffix_comp by simp
    also have "\<dots> = (map v \<circ> map (op + i)) [j ..< j + n]" by simp
    also have "\<dots> =  map v (map (op + i) [j ..< j + n])" unfolding comp_apply by simp
    also have "\<dots> =  map v [i + j ..< i + j + n]" by (simp add: algebra_simps)
    finally show ?thesis by this
  qed*)

  (*
  \<rightarrow> see suffix_subseq_join

  lemma suffix_prefix_suffix[simp]: "map v [i ..< i + n] \<frown> suffix (i + n) v = suffix i v"
  proof -
    have "suffix i v = map (suffix i v) [0 ..< n] \<frown> suffix n (suffix i v)"
      using prefix_suffix
      by blast
    also have "\<dots> = map (suffix i v) [0 ..< 0 + n] \<frown> suffix (i + n) v" by simp
    also have "\<dots> = map v [i ..< i + n] \<frown> suffix (i + n) v" unfolding map_suffix by simp
    finally show ?thesis by simp
  qed*)

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_Inv5 imports DiskPaxos_Inv3 DiskPaxos_Inv4 begin

subsection \<open>Invariant 5\<close>

text \<open>
  This invariant asserts that, if a processor $p$ is in phase 2,
  then either its $bal$ and $inp$ values satisfy $maxBalInp$, or
  else $p$ must eventually abort its current ballot. Processor $p$
  will eventually abort its ballot if there is some processor $q$
  and majority set $D$ such that $p$ has not read $q$'s block on
  any disk $D$, and all of those blocks have $mbal$ values greater
  than $bal(dblock s p)$.
\<close>

definition maxBalInp :: "state \<Rightarrow> nat \<Rightarrow> InputsOrNi \<Rightarrow> bool"
  where "maxBalInp s b v = (\<forall>bk\<in>allBlocks s. b \<le> bal bk \<longrightarrow> inp bk = v)"

definition HInv5_inner_R :: "state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "HInv5_inner_R s p =
          (maxBalInp s (bal(dblock s p)) (inp(dblock s p))
        \<or> (\<exists>D\<in>MajoritySet. \<exists>q. (\<forall>d\<in>D.  bal(dblock s p) < mbal(disk s d q)
                                      \<and> \<not>hasRead s p d q)))"

definition HInv5_inner :: "state \<Rightarrow> Proc \<Rightarrow> bool"
  where "HInv5_inner s p = (phase s p = 2 \<longrightarrow> HInv5_inner_R s p)"

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

subsubsection \<open>Proof of Invariant 5\<close>

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

theorem HInit_HInv5: "HInit s \<Longrightarrow> HInv5 s"
  using Disk_isMajority
  by(auto simp add: HInit_def Init_def HInv5_def HInv5_inner_def)

text \<open>
  We will use the notation used in the proofs of invariant 4, and prove
the lemma $action$-$HInv5$-$p$ and $action$-$HInv5$-$q$ for each action, for
the cases $p=q$ and $p\not = q$ respectively.

  Also, for each action we will define an $action$-$allBlocks$ lemma in the
same way that we defined -$blocksOf$ lemmas in the proofs of $HInv2$. Now we prove
that for each action the new $allBlocks$ are included in the old $allBlocks$ or, in
some cases, included in the old $allBlocks$ union the new $dblock$.
\<close>

lemma HStartBallot_HInv5_p:
  assumes act: "HStartBallot s s' p"
  and inv: "HInv5_inner s p"
  shows "HInv5_inner s' p" using assms
  by(auto simp add: StartBallot_def HInv5_inner_def)

lemma  HStartBallot_blocksOf_q:
  assumes act: "HStartBallot s s' p"
  and pnq: "p\<noteq>q"
  shows "blocksOf s' q \<subseteq> blocksOf s q" using assms
  by(auto simp add: StartBallot_def InitializePhase_def blocksOf_def rdBy_def)

lemma HStartBallot_allBlocks:
  assumes act: "HStartBallot s s' p"
  shows "allBlocks s' \<subseteq> allBlocks s \<union> {dblock s' p}"
proof(auto simp del: HStartBallot_def simp add: allBlocks_def
           dest: HStartBallot_blocksOf_q[OF act])
  fix x pa
  assume x_pa: "x \<in> blocksOf s' pa" and
         x_nblks: "\<forall>xa. x \<notin> blocksOf s xa"
  show "x=dblock s' p"
  proof(cases "p=pa")
    case True
    from x_nblks
    have "x \<notin> blocksOf s p"
      by auto
    with True subsetD[OF HStartBallot_blocksOf[OF act] x_pa]
    show ?thesis
      by auto
  next
    case False
    from x_nblks subsetD[OF HStartBallot_blocksOf_q[OF act False] x_pa]
    show ?thesis
      by auto
  qed
qed

lemma HStartBallot_HInv5_q1:
  assumes act: "HStartBallot s s' p"
  and pnq: "p\<noteq>q"
  and inv5_1: "maxBalInp s (bal(dblock s q)) (inp(dblock s q))"
  shows "maxBalInp s' (bal(dblock s' q)) (inp(dblock s' q))"
proof(auto simp add: maxBalInp_def)
  fix bk
  assume bk: "bk \<in> allBlocks s'"
    and bal: "bal (dblock s' q) \<le> bal bk"
  from act pnq
  have dblock': "dblock s' q = dblock s q" by(auto simp add: StartBallot_def)
  from subsetD[OF HStartBallot_allBlocks[OF act] bk]
  show "inp bk = inp (dblock s' q)"
  proof
    assume bk: "bk \<in> allBlocks s"
    with inv5_1 dblock' bal
    show ?thesis
      by(auto simp add: maxBalInp_def)
  next
    assume bk: "bk \<in> {dblock s' p}"
    have "dblock s p \<in> allBlocks s"
      by(auto simp add: allBlocks_def blocksOf_def)
    with bal act bk dblock' inv5_1
    show ?thesis
      by(auto simp add: maxBalInp_def StartBallot_def)
  qed
qed

lemma HStartBallot_HInv5_q2:
  assumes act: "HStartBallot s s' p"
  and pnq: "p\<noteq>q"
  and inv5_2: "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s q) < mbal(disk s d qq)
                                     \<and> \<not>hasRead s q d qq)"
  shows "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s' q) < mbal(disk s' d qq)
                                     \<and> \<not>hasRead s' q d qq)"
proof -
  from act pnq
  have  disk: "disk s' = disk s"
    and blocksRead: "\<forall>d. blocksRead s' q d = blocksRead s q d"
    and dblock: "dblock s' q = dblock s q"
    by(auto simp add: StartBallot_def InitializePhase_def)
  with inv5_2
  show ?thesis
    by(auto simp add: hasRead_def)
qed

lemma HStartBallot_HInv5_q:
  assumes act: "HStartBallot s s' p"
  and inv: "HInv5_inner s q"
  and pnq: "p\<noteq>q"
  shows "HInv5_inner s' q"
  using assms and HStartBallot_HInv5_q1[OF act pnq] HStartBallot_HInv5_q2[OF act pnq]
  by(auto simp add: HInv5_inner_def HInv5_inner_R_def StartBallot_def)

theorem HStartBallot_HInv5:
  "\<lbrakk> HStartBallot s s' p; HInv5_inner s q \<rbrakk> \<Longrightarrow> HInv5_inner s' q"
by(blast dest: HStartBallot_HInv5_q HStartBallot_HInv5_p)

lemma HPhase1or2Write_HInv5_p2:
  assumes act: "HPhase1or2Write s s' p d"
  and inv4c: "HInv4c s p"
  and phase: "phase s p = 2"
  and inv5_2: "\<exists>D\<in>MajoritySet. \<exists>q. (\<forall>d\<in>D.    bal(dblock s p) < mbal(disk s d q)
                                     \<and> \<not>hasRead s p d q)"
  shows "\<exists>D\<in>MajoritySet. \<exists>q. (\<forall>d\<in>D.    bal(dblock s' p) < mbal(disk s' d q)
                                     \<and> \<not>hasRead s' p d q)"
proof -
  from inv5_2
  obtain D q
    where i1: "IsMajority D"
      and i2: "\<forall>d\<in>D. bal(dblock s p) < mbal(disk s d q)"
      and i3: "\<forall>d\<in>D. \<not>hasRead s p d q"
    by(auto simp add: MajoritySet_def)
  have pnq: "p\<noteq>q"
  proof -
    from inv4c phase
    obtain D1 where r1: "IsMajority D1 \<and> (\<forall>d\<in>D1. mbal(disk s d p) = bal (dblock s p))"
      by(auto simp add: HInv4c_def MajoritySet_def)
    with i1 majorities_intersect
    have "D\<inter>D1\<noteq>{}" by auto
    then obtain dd where  "dd\<in>D\<inter>D1"
      by auto
    with i1 i2 r1
    have "bal(dblock s p) < mbal(disk s dd q) \<and> mbal(disk s dd p) = bal (dblock s p)"
      by auto
    thus ?thesis by auto
  qed
  from act pnq
      \<comment> \<open>$dblock$ and $hasRead$ do not change\<close>
  have  "dblock s' = dblock s"
    and "\<forall>d. hasRead s' p d q = hasRead s p d q"
      \<comment> \<open>In all disks $q$ blocks don't change\<close>
    and "\<forall>d. disk s' d q = disk s d q"
    by(auto simp add: Phase1or2Write_def hasRead_def)
  with i2 i1 i3 majority_nonempty
  have "\<forall>d\<in>D. bal (dblock s' p) < mbal (disk s' d q) \<and> \<not>hasRead s' p d q"
    by auto
  with i1
  show ?thesis
    by(auto simp add: MajoritySet_def)
qed

lemma HPhase1or2Write_HInv5_p:
  assumes act: "HPhase1or2Write s s' p d"
  and inv: "HInv5_inner s p"
  and inv4: "HInv4c s p"
  shows "HInv5_inner s' p"
proof(auto simp add: HInv5_inner_def HInv5_inner_R_def)
  assume phase': "phase s' p = 2"
    and i2: "\<forall>D\<in>MajoritySet. \<forall>q. \<exists>d\<in>D. bal (dblock s' p) < mbal (disk s' d q) \<longrightarrow> hasRead s' p d q"
  with act have phase: "phase s p = 2"
    by(auto simp add: Phase1or2Write_def)
  show "maxBalInp s' (bal (dblock s' p)) (inp (dblock s' p))"
  proof(rule HPhase1or2Write_HInv5_1[OF act, of p])
    from HPhase1or2Write_HInv5_p2[OF act inv4 phase] inv i2 phase
    show "maxBalInp s (bal (dblock s p)) (inp (dblock s p))"
      by(auto simp add: HInv5_inner_def HInv5_inner_R_def, blast)
  qed
qed

lemma HPhase1or2Write_allBlocks:
  assumes act: "HPhase1or2Write s s' p d"
  shows "allBlocks s' \<subseteq> allBlocks s"
  using HPhase1or2Write_blocksOf[OF act]
  by(auto simp add: allBlocks_def)

lemma HPhase1or2Write_HInv5_q2:
  assumes act: "HPhase1or2Write s s' p d"
  and pnq: "p\<noteq>q"
  and inv4a: "HInv4a s p"
  and inv5_2: "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s q) < mbal(disk s d qq)
                                     \<and> \<not>hasRead s q d qq)"
  shows "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s' q) < mbal(disk s' d qq)
                                     \<and> \<not>hasRead s' q d qq)"
proof -
  from inv5_2
  obtain D qq
    where i1: "IsMajority D"
      and i2: "\<forall>d\<in>D. bal(dblock s q) < mbal(disk s d qq)"
      and i3: "\<forall>d\<in>D. \<not>hasRead s q d qq"
    by(auto simp add: MajoritySet_def)
  from act pnq
      \<comment> \<open>$dblock$ and $hasRead$ do not change\<close>
  have  dblock': "dblock s' = dblock s"
    and hasread: "\<forall>d. hasRead s' q d qq = hasRead s q d qq"
    by(auto simp add: Phase1or2Write_def hasRead_def)
  have "\<forall>d\<in>D. bal (dblock s' q) < mbal (disk s' d qq) \<and> \<not>hasRead s' q d qq"
  proof(cases "qq=p")
    case True
    have "bal(dblock s q) < mbal(dblock s p)"
    proof -
      from inv4a act i1
      have "\<exists>d\<in>D. mbal(disk s d p) \<le> mbal(dblock s p)"
        by(auto simp add: MajoritySet_def HInv4a_def
                          HInv4a2_def Phase1or2Write_def)
      with True i2
      show "bal(dblock s q) < mbal(dblock s p)"
        by auto
    qed
    with hasread dblock' True i1 i2 i3 act
    show ?thesis
      by(auto simp add: Phase1or2Write_def)
  next
    case False
    with act i2 i3
    show ?thesis
      by(auto simp add: Phase1or2Write_def hasRead_def)
  qed
  with i1
  show ?thesis
    by(auto simp add: MajoritySet_def)
qed

lemma HPhase1or2Write_HInv5_q:
  assumes act: "HPhase1or2Write s s' p d"
  and inv: "HInv5_inner s q"
  and inv4a: "HInv4a s p"
  and pnq: "p\<noteq>q"
  shows "HInv5_inner s' q"
proof(auto simp add: HInv5_inner_def HInv5_inner_R_def)
  assume phase': "phase s' q = 2"
    and i2: "\<forall>D\<in>MajoritySet. \<forall>qa. \<exists>d\<in>D. bal (dblock s' q) < mbal (disk s' d qa) \<longrightarrow> hasRead s' q d qa"
  from phase' act have phase: "phase s q = 2"
    by(auto simp add: Phase1or2Write_def)
  show "maxBalInp s' (bal (dblock s' q)) (inp (dblock s' q))"
  proof(rule HPhase1or2Write_HInv5_1[OF act, of q])
    from HPhase1or2Write_HInv5_q2[OF act pnq inv4a] inv i2 phase
    show "maxBalInp s (bal (dblock s q)) (inp (dblock s q))"
      by(auto simp add: HInv5_inner_def HInv5_inner_R_def, blast)
  qed
qed

theorem HPhase1or2Write_HInv5:
  "\<lbrakk> HPhase1or2Write s s' p d; HInv5_inner s q;
     HInv4c s p; HInv4a s p \<rbrakk> \<Longrightarrow> HInv5_inner s' q"
  by(blast dest: HPhase1or2Write_HInv5_q HPhase1or2Write_HInv5_p)

lemma HPhase1or2ReadThen_HInv5_1:
  assumes act: "HPhase1or2ReadThen s s' p d r"
  and inv5_1: "maxBalInp s (bal(dblock s q)) (inp(dblock s q))"
  shows "maxBalInp s' (bal(dblock s' q)) (inp(dblock s' q))"
  using assms and HPhase1or2ReadThen_blocksOf[OF act]
  by(auto simp add: Phase1or2ReadThen_def maxBalInp_def allBlocks_def)

lemma HPhase1or2ReadThen_HInv5_p2:
  assumes act: "HPhase1or2ReadThen s s' p d r"
  and inv4c: "HInv4c s p"
  and inv2c: "Inv2c_inner s p"
  and phase: "phase s p = 2"
  and inv5_2: "\<exists>D\<in>MajoritySet. \<exists>q. (\<forall>d\<in>D.    bal(dblock s p) < mbal(disk s d q)
                                     \<and> \<not>hasRead s p d q)"
  shows "\<exists>D\<in>MajoritySet. \<exists>q. (\<forall>d\<in>D.    bal(dblock s' p) < mbal(disk s' d q)
                                     \<and> \<not>hasRead s' p d q)"
proof -
  from inv5_2
  obtain D q
    where i1: "IsMajority D"
      and i2: "\<forall>d\<in>D. bal(dblock s p) < mbal(disk s d q)"
      and i3: "\<forall>d\<in>D. \<not>hasRead s p d q"
    by(auto simp add: MajoritySet_def)
  from inv2c phase
  have "bal(dblock s p)=mbal(dblock s p)"
    by(auto simp add: Inv2c_inner_def)
  moreover
  from act have "mbal (disk s d r) < mbal (dblock s p)"
    by(auto simp add: Phase1or2ReadThen_def)
  moreover
  from i2 have "d\<in>D \<longrightarrow> bal(dblock s p) < mbal(disk s d q)" by auto
  ultimately have pnr: "d\<in>D \<longrightarrow> q\<noteq>r" by auto
  have pnq: "p\<noteq>q"
  proof -
    from inv4c phase
    obtain D1 where r1: "IsMajority D1 \<and> (\<forall>d\<in>D1. mbal(disk s d p) = bal (dblock s p))"
      by(auto simp add: HInv4c_def MajoritySet_def)
    with i1 majorities_intersect
    have "D\<inter>D1\<noteq>{}" by auto
    then obtain dd where  "dd\<in>D\<inter>D1"
      by auto
    with i1 i2 r1
    have "bal(dblock s p) < mbal(disk s dd q) \<and> mbal(disk s dd p) = bal (dblock s p)"
      by auto
    thus ?thesis by auto
  qed
  from pnr act
  have hasRead': "\<forall>d\<in>D. hasRead s' p d q = hasRead s p d q"
    by(auto simp add: Phase1or2ReadThen_def hasRead_def)
  from act pnq
      \<comment> \<open>$dblock$ and $disk$ do not change\<close>
  have  "dblock s' = dblock s"
    and "\<forall>d. disk s' = disk s"
    by(auto simp add: Phase1or2ReadThen_def)
  with i2 hasRead' i3
  have "\<forall>d\<in>D. bal (dblock s' p) < mbal (disk s' d q) \<and> \<not>hasRead s' p d q"
    by auto
  with i1
  show ?thesis
    by(auto simp add: MajoritySet_def)
qed

lemma HPhase1or2ReadThen_HInv5_p:
  assumes act: "HPhase1or2ReadThen s s' p d r"
  and inv: "HInv5_inner s p"
  and inv4: "HInv4c s p"
  and inv2c: "Inv2c s"
  shows "HInv5_inner s' p"
proof(auto simp add: HInv5_inner_def HInv5_inner_R_def)
  assume phase': "phase s' p = 2"
    and i2: "\<forall>D\<in>MajoritySet. \<forall>q. \<exists>d\<in>D. bal (dblock s' p) < mbal (disk s' d q) \<longrightarrow> hasRead s' p d q"
  with act have phase: "phase s p = 2"
    by(auto simp add: Phase1or2ReadThen_def)
  show "maxBalInp s' (bal (dblock s' p)) (inp (dblock s' p))"
  proof(rule HPhase1or2ReadThen_HInv5_1[OF act, of p])
    from inv2c
    have "Inv2c_inner s p" by(auto simp add: Inv2c_def)
    from HPhase1or2ReadThen_HInv5_p2[OF act inv4 this phase] inv i2 phase
    show "maxBalInp s (bal (dblock s p)) (inp (dblock s p))"
      by(auto simp add: HInv5_inner_def HInv5_inner_R_def, blast)
  qed
qed

lemma HPhase1or2ReadThen_allBlocks:
  assumes act: "HPhase1or2ReadThen s s' p d r"
  shows "allBlocks s' \<subseteq> allBlocks s"
  using HPhase1or2ReadThen_blocksOf[OF act]
  by(auto simp add: allBlocks_def)

lemma HPhase1or2ReadThen_HInv5_q2:
  assumes act: "HPhase1or2ReadThen s s' p d r"
  and pnq: "p\<noteq>q"
  and inv4a: "HInv4a s p"
  and inv5_2: "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s q) < mbal(disk s d qq)
                                     \<and> \<not>hasRead s q d qq)"
  shows "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s' q) < mbal(disk s' d qq)
                                     \<and> \<not>hasRead s' q d qq)"
proof -
  from inv5_2
  obtain D qq
    where i1: "IsMajority D"
      and i2: "\<forall>d\<in>D. bal(dblock s q) < mbal(disk s d qq)"
      and i3: "\<forall>d\<in>D. \<not>hasRead s q d qq"
    by(auto simp add: MajoritySet_def)
  from act pnq
      \<comment> \<open>$dblock$ and $hasRead$ do not change\<close>
  have  dblock': "dblock s' = dblock s"
    and   disk': "disk s' = disk s"
    and hasread: "\<forall>d. hasRead s' q d qq = hasRead s q d qq"
    by(auto simp add: Phase1or2ReadThen_def hasRead_def)
  with i2 i3
  have "\<forall>d\<in>D. bal (dblock s' q) < mbal (disk s' d qq) \<and> \<not>hasRead s' q d qq"
    by auto
  with i1
  show ?thesis
    by(auto simp add: MajoritySet_def)
qed

lemma HPhase1or2ReadThen_HInv5_q:
  assumes act: "HPhase1or2ReadThen s s' p d r"
  and inv: "HInv5_inner s q"
  and inv4a: "HInv4a s p"
  and pnq: "p\<noteq>q"
  shows "HInv5_inner s' q"
proof(auto simp add: HInv5_inner_def HInv5_inner_R_def)
  assume phase': "phase s' q = 2"
    and i2: "\<forall>D\<in>MajoritySet. \<forall>qa. \<exists>d\<in>D. bal (dblock s' q) < mbal (disk s' d qa) \<longrightarrow> hasRead s' q d qa"
  from phase' act have phase: "phase s q = 2"
    by(auto simp add: Phase1or2ReadThen_def)
  show "maxBalInp s' (bal (dblock s' q)) (inp (dblock s' q))"
  proof(rule HPhase1or2ReadThen_HInv5_1[OF act, of q])
    from HPhase1or2ReadThen_HInv5_q2[OF act pnq inv4a] inv i2 phase
    show "maxBalInp s (bal (dblock s q)) (inp (dblock s q))"
      by(auto simp add: HInv5_inner_def HInv5_inner_R_def, blast)
  qed
qed

theorem HPhase1or2ReadThen_HInv5:
  "\<lbrakk> HPhase1or2ReadThen s s' p d r; HInv5_inner s q;
     Inv2c s; HInv4c s p; HInv4a s p \<rbrakk> \<Longrightarrow> HInv5_inner s' q"
  by(blast dest: HPhase1or2ReadThen_HInv5_q HPhase1or2ReadThen_HInv5_p)

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

lemma HEndPhase2_HInv5_p:
  "HEndPhase2 s s' p  \<Longrightarrow> HInv5_inner s' p"
  by(auto simp add: EndPhase2_def HInv5_inner_def)

lemma HEndPhase2_allBlocks:
  assumes act: "HEndPhase2 s s' p"
  shows "allBlocks s' \<subseteq> allBlocks s"
  using HEndPhase2_blocksOf[OF act]
  by(auto simp add: allBlocks_def)

lemma HEndPhase2_HInv5_q1:
  assumes act: "HEndPhase2 s s' p"
  and pnq: "p\<noteq>q"
  and inv5_1: "maxBalInp s (bal(dblock s q)) (inp(dblock s q))"
  shows "maxBalInp s' (bal(dblock s' q)) (inp(dblock s' q))"
proof(auto simp add: maxBalInp_def)
  fix bk
  assume bk: "bk \<in> allBlocks s'"
    and bal: "bal (dblock s' q) \<le> bal bk"
  from act pnq
  have dblock': "dblock s' q = dblock s q" by(auto simp add: EndPhase2_def)
  from subsetD[OF HEndPhase2_allBlocks[OF act] bk] inv5_1 dblock' bal
  show "inp bk = inp (dblock s' q)"
      by(auto simp add: maxBalInp_def)
qed

lemma HEndPhase2_HInv5_q2:
  assumes act: "HEndPhase2 s s' p"
  and pnq: "p\<noteq>q"
  and inv5_2: "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s q) < mbal(disk s d qq)
                                     \<and> \<not>hasRead s q d qq)"
  shows "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s' q) < mbal(disk s' d qq)
                                     \<and> \<not>hasRead s' q d qq)"
proof -
  from act pnq
  have  disk: "disk s' = disk s"
    and blocksRead: "\<forall>d. blocksRead s' q d = blocksRead s q d"
    and dblock: "dblock s' q = dblock s q"
    by(auto simp add: EndPhase2_def InitializePhase_def)
  with inv5_2
  show ?thesis
    by(auto simp add: hasRead_def)
qed

lemma HEndPhase2_HInv5_q:
  assumes act: "HEndPhase2 s s' p"
  and inv: "HInv5_inner s q"
  and pnq: "p\<noteq>q"
  shows "HInv5_inner s' q"
  using assms and HEndPhase2_HInv5_q1[OF act pnq] HEndPhase2_HInv5_q2[OF act pnq]
  by(auto simp add: HInv5_inner_def HInv5_inner_R_def EndPhase2_def)

theorem HEndPhase2_HInv5:
  "\<lbrakk> HEndPhase2 s s' p; HInv5_inner s q \<rbrakk> \<Longrightarrow> HInv5_inner s' q"
  by(blast dest: HEndPhase2_HInv5_q HEndPhase2_HInv5_p)

lemma HEndPhase1_HInv5_p:
  assumes act: "HEndPhase1 s s' p"
  and inv4: "HInv4 s"
  and inv2a: "Inv2a s"
  and inv2a': "Inv2a s'"
  and inv2c: "Inv2c s"
  and asm4: "\<not>maxBalInp s' (bal(dblock s' p)) (inp(dblock s' p))"
  shows "(\<exists>D\<in>MajoritySet. \<exists>q. (\<forall>d\<in>D.    bal(dblock s' p) < mbal(disk s' d q)
                                     \<and> \<not>hasRead s' p d q))"
proof -
  have "\<exists>bk\<in>allBlocks s. bal(dblock s' p) \<le> bal bk \<and> bk \<noteq> dblock s' p"
  proof -
    from asm4
    obtain bk
      where p31: "bk\<in>allBlocks s' \<and>  bal(dblock s' p) \<le> bal bk \<and> bk \<noteq> dblock s' p"
      by(auto simp add: maxBalInp_def)
    then obtain q where p32: "bk \<in> blocksOf s' q"
      by(auto simp add: allBlocks_def)
    from act
    have dblock: "p\<noteq>q \<Longrightarrow> dblock s' q = dblock s q"
      by(auto simp add: EndPhase1_def)
    have "bk \<in> blocksOf s q"
    proof(cases "p=q")
      case True
      with p32 p31 HEndPhase1_blocksOf[OF act]
      show ?thesis
        by auto
    next
      case False
      from dblock[OF False] subsetD[OF HEndPhase1_blocksOf[OF act, of q] p32]
      show ?thesis
        by(auto simp add: blocksOf_def)
    qed
    with p31
    show ?thesis
    by(auto simp add: allBlocks_def)
  qed
  then obtain bk where p22: "bk\<in>allBlocks s \<and> bal (dblock s' p) \<le> bal bk \<and> bk \<noteq> dblock s' p" by auto
  have "\<exists>q\<in>UNIV-{p}. bk \<in> blocksOf s q"
  proof -
    from p22
    obtain q where bk: "bk\<in> blocksOf s q"
      by(auto simp add: allBlocks_def)
    from act p22
    have "mbal(dblock s p) \<le> bal bk"
      by(auto simp add: EndPhase1_def)
    moreover
    from act
    have "phase s p = 1"
      by(auto simp add: EndPhase1_def)
    moreover
    from inv4
    have "HInv4b s p" by(auto simp add: HInv4_def)
    ultimately
    have "p\<noteq>q"
      using bk
      by(auto simp add: HInv4_def HInv4b_def)
    with bk
    show ?thesis
      by auto
  qed
  then obtain q where p23: "q\<in>UNIV-{p} \<and> bk \<in> blocksOf s q"
    by auto
  have "\<exists>D\<in>MajoritySet.\<forall>d\<in>D. bal(dblock s' p) \<le> mbal(disk s d q)"
  proof -
    from p23 inv4
    have i4d: "\<exists>D\<in>MajoritySet.\<forall>d\<in>D. bal bk \<le> mbal(disk s d q)"
      by(auto simp add: HInv4_def HInv4d_def)
    from i4d p22
    show ?thesis
      by force
  qed
  then obtain D where Dmaj: "D\<in>MajoritySet" and p24:"(\<forall>d\<in>D. bal(dblock s' p) \<le> mbal(disk s d q))"
    by auto
  have p25: "\<forall>d\<in>D. bal(dblock s' p) < mbal(disk s d q)"
  proof -
    from inv2c
    have "Inv2c_inner s p"
      by(auto simp add: Inv2c_def)
    with act
    have bal_pos: "0 < bal(dblock s' p)"
      by(auto simp add: Inv2c_inner_def EndPhase1_def)
    with inv2a'
    have "bal(dblock s' p) \<in> Ballot p \<union> {0}"
      by(auto simp add: Inv2a_def Inv2a_inner_def
                        Inv2a_innermost_def blocksOf_def)
    with bal_pos have bal_in_p: "bal(dblock s' p) \<in> Ballot p"
      by auto
    from inv2a have "Inv2a_inner s q" by(auto simp add: Inv2a_def)
    hence "\<forall>d\<in>D. mbal(disk s d q) \<in> Ballot q \<union> {0}"
      by(auto simp add: Inv2a_inner_def Inv2a_innermost_def
                        blocksOf_def)
    with p24 bal_pos
    have "\<forall>d\<in>D. mbal(disk s d q) \<in> Ballot q"
      by force
    with  Ballot_disj p23 bal_in_p
    have "\<forall>d\<in>D. mbal(disk s d q)\<noteq> bal(dblock s' p)"
      by force
    with p23 p24
    show ?thesis
      by force
  qed
  with p23 act
  have "\<forall>d\<in>D. bal(dblock s' p) < mbal(disk s' d q) \<and> \<not>hasRead s' p d q"
    by(auto simp add: EndPhase1_def InitializePhase_def hasRead_def)
  with Dmaj
  show ?thesis
    by blast
qed

lemma union_inclusion:
 "\<lbrakk> A \<subseteq> A'; B\<subseteq> B' \<rbrakk> \<Longrightarrow> A\<union>B \<subseteq> A'\<union>B'"
by blast

lemma  HEndPhase1_blocksOf_q:
  assumes act: "HEndPhase1 s s' p"
  and pnq: "p\<noteq>q"
  shows "blocksOf s' q \<subseteq> blocksOf s q"
proof -
  from act pnq
  have dblock: "{dblock s' q} \<subseteq> {dblock s q}"
    and disk: "disk s' = disk s"
    and blks: "blocksRead s' q = blocksRead s q"
    by(auto simp add: EndPhase1_def InitializePhase_def)
  from disk
  have disk': "{disk s' d q | d . d\<in> UNIV} \<subseteq> {disk s d q | d . d\<in> UNIV}" (is "?D' \<subseteq> ?D")
    by auto
  from pnq act
  have "(UN qq d. rdBy s' q qq d) \<subseteq> (UN qq d. rdBy s q qq d)"
    by(auto simp add: EndPhase1_def InitializePhase_def rdBy_def split: if_split_asm, blast)
  hence "{block br | br. br \<in> (UN qq d. rdBy s' q qq d)} \<subseteq> {block br | br. br \<in> (UN qq d. rdBy s q qq d)}" (is "?R' \<subseteq> ?R")
    by auto blast
  from union_inclusion[OF dblock union_inclusion[OF disk' this]]
  show ?thesis
    by(auto simp add: blocksOf_def)
qed

lemma HEndPhase1_allBlocks:
  assumes act: "HEndPhase1 s s' p"
  shows "allBlocks s' \<subseteq> allBlocks s \<union> {dblock s' p}"
proof(auto simp del: HEndPhase1_def simp add: allBlocks_def
           dest: HEndPhase1_blocksOf_q[OF act])
  fix x pa
  assume x_pa: "x \<in> blocksOf s' pa" and
         x_nblks: "\<forall>xa. x \<notin> blocksOf s xa"
  show "x=dblock s' p"
  proof(cases "p=pa")
    case True
    from x_nblks
    have "x \<notin> blocksOf s p"
      by auto
    with True subsetD[OF HEndPhase1_blocksOf[OF act] x_pa]
    show ?thesis
      by auto
  next
    case False
    from x_nblks subsetD[OF HEndPhase1_blocksOf_q[OF act False] x_pa]
    show ?thesis
      by auto
  qed
qed

lemma HEndPhase1_HInv5_q:
  assumes act: "HEndPhase1 s s' p"
  and inv: "HInv5 s"
  and inv1: "Inv1 s"
  and inv2a: "Inv2a s'"
  and inv2a_q: "Inv2a s"
  and inv2b: "Inv2b s"
  and inv2c: "Inv2c s"
  and inv3: "HInv3 s"
  and phase': "phase s' q = 2"
  and pnq: "p\<noteq>q"
  and asm4: "\<not>maxBalInp s' (bal(dblock s' q)) (inp(dblock s' q))"
  shows "(\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s' q) < mbal(disk s' d qq)
                                     \<and> \<not>hasRead s' q d qq))"
proof -
  from act pnq
  have "phase s' q = phase s q"
    and phase_p: "phase s p = 1"
    and disk: "disk s' = disk s"
    and dblock: "dblock s' q = dblock s q"
    and bal: "bal(dblock s' p) = mbal(dblock s p)"
    by(auto simp add: EndPhase1_def InitializePhase_def)
  with phase'
  have phase: "phase s q = 2" by auto
  from phase inv2c
  have bal_dblk_q: "bal(dblock s q) \<in> Ballot q"
    by(auto simp add: Inv2c_def Inv2c_inner_def)
  have "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s q) < mbal(disk s d qq)
                                     \<and> \<not>hasRead s q d qq)"
  proof(cases "maxBalInp s (bal(dblock s q)) (inp(dblock s q))")
    case True
    have p21: "bal(dblock s q) < bal(dblock s' p) \<and> inp(dblock s q) \<noteq> inp(dblock s' p)"
    proof -
      from True asm4 dblock HEndPhase1_allBlocks[OF act]
      have p32: "  bal(dblock s q)\<le> bal(dblock s' p)
                 \<and> inp(dblock s q) \<noteq> inp(dblock s' p)"
        by(auto simp add: maxBalInp_def)
      from inv2a
      have "bal(dblock s' p) \<in> Ballot p \<union> {0}"
        by(auto simp add: Inv2a_def Inv2a_inner_def
                          Inv2a_innermost_def blocksOf_def)
      moreover
      from Ballot_disj Ballot_nzero pnq
      have "Ballot q \<inter> (Ballot p \<union> {0}) = {}"
        by auto
      ultimately
      have "bal(dblock s' p) \<noteq> bal(dblock s q)"
        using bal_dblk_q
        by auto
      with p32
      show ?thesis
        by auto
    qed
    have "\<exists>D\<in>MajoritySet.\<forall>d\<in>D. bal(dblock s q) < mbal(disk s d p) \<and> hasRead s p d q"
    proof -
      from  act
      have "\<exists>D\<in>MajoritySet.\<forall>d\<in>D. d\<in>disksWritten s p \<and> (\<forall>q\<in>UNIV-{p}. hasRead s p d q)"
        by(auto simp add: EndPhase1_def MajoritySet_def)
      then obtain D
        where act1: "\<forall>d\<in>D. d\<in>disksWritten s p \<and> (\<forall>q\<in>UNIV-{p}. hasRead s p d q)"
        and Dmaj: "D\<in>MajoritySet"
        by auto
      from inv2b
      have "\<forall>d. Inv2b_inner s p d" by(auto simp add: Inv2b_def)
      with act1 pnq phase_p bal
      have "\<forall>d\<in>D. bal(dblock s' p)= mbal(disk s d p) \<and> hasRead s p d q"
        by(auto simp add: Inv2b_def Inv2b_inner_def)
      with p21 Dmaj
      have "\<forall>d\<in>D. bal(dblock s q)< mbal(disk s d p) \<and> hasRead s p d q"
        by auto
      with Dmaj
      show ?thesis
        by auto
    qed
    then obtain D
      where p22: "D\<in>MajoritySet \<and> (\<forall>d\<in>D. bal(dblock s q) < mbal(disk s d p) \<and> hasRead s p d q)"
      by auto
    have p23: "\<forall>d\<in>D.\<lparr>block=dblock s q, proc=q\<rparr> \<notin> blocksRead s p d"
    proof -
      have "dblock s q \<in> allBlocksRead s p \<longrightarrow> inp(dblock s' p) = inp(dblock s q)"
      proof auto
        assume dblock_q: "dblock s q \<in> allBlocksRead s p"
        from inv2a_q
        have "(bal(dblock s q)=0) = (inp (dblock s q) = NotAnInput)"
          by(auto simp add: Inv2a_def Inv2a_inner_def
                            blocksOf_def Inv2a_innermost_def)
        with bal_dblk_q Ballot_nzero dblock_q InputsOrNi
        have dblock_q_nib: "dblock s q \<in> nonInitBlks s p"
          by(auto simp add: nonInitBlks_def blocksSeen_def)
        with act
        have dblock_max: "inp(dblock s' p)=inp(maxBlk s p)"
          by(auto simp add: EndPhase1_def)
        from maxBlk_in_nonInitBlks[OF dblock_q_nib inv1]
        have max_in_nib: "maxBlk s p \<in> nonInitBlks s p" ..
        hence "nonInitBlks s p \<subseteq> allBlocks s"
          by(auto simp add: allBlocks_def nonInitBlks_def
                            blocksSeen_def blocksOf_def rdBy_def
                            allBlocksRead_def allRdBlks_def)
        with True subsetD[OF this max_in_nib]
        have "bal (dblock s q) \<le> bal (maxBlk s p) \<longrightarrow> inp (maxBlk s p) = inp (dblock s q)"
          by(auto simp add: maxBalInp_def)
        with maxBlk_in_nonInitBlks[OF dblock_q_nib inv1]
             dblock_q_nib dblock_max
        show "inp(dblock s' p) = inp(dblock s q)"
          by auto
      qed
      with p21
      have "dblock s q \<notin> block ` allRdBlks s p"
        by(auto simp add: allBlocksRead_def)
      hence "\<forall>d. dblock s q \<notin> block ` blocksRead s p d"
        by(auto simp add: allRdBlks_def)
      thus ?thesis
        by force
    qed
    have p24: "\<forall>d\<in>D. \<not> (\<exists>br\<in> blocksRead s q d. bal(dblock s q) \<le> mbal (block br))"
    proof -
      from inv2c phase
      have "\<forall>d. \<forall>br\<in>blocksRead s q d. mbal(block br)<mbal(dblock s q)"
        and "bal(dblock s q) = mbal(dblock s q)"
        by(auto simp add: Inv2c_def Inv2c_inner_def)
      thus ?thesis
        by force
    qed
    have p25: "\<forall>d\<in>D. \<not>hasRead s q d p"
    proof auto
      fix d
      assume  d_in_D: "d \<in> D"
        and hasRead_qdp: "hasRead s q d p"
      have p31: "\<lparr>block=dblock s p, proc=p\<rparr>\<in>blocksRead s q d"
      proof -
        from "d_in_D" p22
        have hasRead_pdq: "hasRead s p d q" by auto
        with hasRead_qdp phase phase_p inv3
        have "HInv3_R s q p d"
          by(auto simp add: HInv3_def HInv3_inner_def HInv3_L_def)
        with p23 d_in_D
        show ?thesis
          by(auto simp add: HInv3_R_def)
      qed
      from p21 act
      have p32: "bal(dblock s q) < mbal(dblock s p)"
        by(auto simp add: EndPhase1_def)
      with p31 d_in_D hasRead_qdp p24
      show False
        by(force)
    qed
    with p22
    show ?thesis
      by auto
  next
    case False
    with inv phase
    show ?thesis
      by(auto simp add: HInv5_def HInv5_inner_def HInv5_inner_R_def)
  qed
  then obtain D qq
    where "D\<in>MajoritySet \<and> (\<forall>d\<in>D.    bal(dblock s q) < mbal(disk s d qq)
                                   \<and> \<not>hasRead s q d qq)"
    by auto
  moreover
  from act pnq
  have "\<forall>d. hasRead s' q d qq = hasRead s q d qq"
    by(auto simp add: EndPhase1_def InitializePhase_def hasRead_def)
  ultimately show ?thesis
    using disk dblock
    by auto
qed

theorem HEndPhase1_HInv5:
  assumes act: "HEndPhase1 s s' p"
  and inv: "HInv5 s"
  and inv1: "Inv1 s"
  and inv2a: "Inv2a s"
  and inv2a': "Inv2a s'"
  and inv2b: "Inv2b s"
  and inv2c: "Inv2c s"
  and inv3: "HInv3 s"
  and inv4: "HInv4 s"
shows "HInv5_inner s' q"
  using HEndPhase1_HInv5_p[OF act inv4 inv2a inv2a' inv2c]
        HEndPhase1_HInv5_q[OF act inv inv1 inv2a' inv2a inv2b inv2c inv3, of q]
  by(auto simp add: HInv5_def HInv5_inner_def HInv5_inner_R_def)

lemma HFail_HInv5_p:
  "HFail s s' p  \<Longrightarrow> HInv5_inner s' p"
  by(auto simp add: Fail_def HInv5_inner_def)

lemma  HFail_blocksOf_q:
  assumes act: "HFail s s' p"
  and pnq: "p\<noteq>q"
  shows "blocksOf s' q \<subseteq> blocksOf s q"
  using assms
  by(auto simp add: Fail_def InitializePhase_def blocksOf_def rdBy_def)

lemma HFail_allBlocks:
  assumes act: "HFail s s' p"
  shows "allBlocks s' \<subseteq> allBlocks s \<union> {dblock s' p}"
proof(auto simp del: HFail_def simp add: allBlocks_def
           dest: HFail_blocksOf_q[OF act])
  fix x pa
  assume x_pa: "x \<in> blocksOf s' pa" and
         x_nblks: "\<forall>xa. x \<notin> blocksOf s xa"
  show "x=dblock s' p"
  proof(cases "p=pa")
    case True
    from x_nblks
    have "x \<notin> blocksOf s p"
      by auto
    with True subsetD[OF HFail_blocksOf[OF act] x_pa]
    show ?thesis
      by auto
  next
    case False
    from x_nblks subsetD[OF HFail_blocksOf_q[OF act False] x_pa]
    show ?thesis
      by auto
  qed
qed

lemma HFail_HInv5_q1:
  assumes act: "HFail s s' p"
  and pnq: "p\<noteq>q"
  and inv2a: "Inv2a_inner s' q"
  and inv5_1: "maxBalInp s (bal(dblock s q)) (inp(dblock s q))"
  shows "maxBalInp s' (bal(dblock s' q)) (inp(dblock s' q))"
proof(auto simp add: maxBalInp_def)
  fix bk
  assume bk: "bk \<in> allBlocks s'"
    and bal: "bal (dblock s' q) \<le> bal bk"
  from act pnq
  have dblock': "dblock s' q = dblock s q" by(auto simp add: Fail_def)
  from subsetD[OF HFail_allBlocks[OF act] bk]
  show "inp bk = inp (dblock s' q)"
  proof
    assume bk: "bk \<in> allBlocks s"
    with inv5_1 dblock' bal
    show ?thesis
      by(auto simp add: maxBalInp_def)
  next
    assume bk: "bk \<in> {dblock s' p}"
    with act have bk_init: "bk = InitDB"
      by(auto simp add: Fail_def)
    with bal
    have "bal (dblock s' q)=0"
      by(auto simp add: InitDB_def)
    with inv2a
    have "inp (dblock s' q)= NotAnInput"
      by(auto simp add: Inv2a_inner_def Inv2a_innermost_def blocksOf_def)
    with bk_init
    show ?thesis
      by(auto simp add: InitDB_def)
  qed
qed

lemma HFail_HInv5_q2:
  assumes act: "HFail s s' p"
  and pnq: "p\<noteq>q"
  and inv5_2: "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s q) < mbal(disk s d qq)
                                     \<and> \<not>hasRead s q d qq)"
  shows "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s' q) < mbal(disk s' d qq)
                                     \<and> \<not>hasRead s' q d qq)"
proof -
  from act pnq
  have  disk: "disk s' = disk s"
    and blocksRead: "\<forall>d. blocksRead s' q d = blocksRead s q d"
    and dblock: "dblock s' q = dblock s q"
    by(auto simp add: Fail_def InitializePhase_def)
  with inv5_2
  show ?thesis
    by(auto simp add: hasRead_def)
qed

lemma HFail_HInv5_q:
  assumes act: "HFail s s' p"
  and inv: "HInv5_inner s q"
  and pnq: "p\<noteq>q"
  and inv2a: "Inv2a s'"
  shows "HInv5_inner s' q"
proof(auto simp add: HInv5_inner_def HInv5_inner_R_def)
  assume phase': "phase s' q = 2"
    and nR2: " \<forall>D\<in>MajoritySet.
        \<forall>qa. \<exists>d\<in>D. bal (dblock s' q) < mbal (disk s' d qa) \<longrightarrow>
                   hasRead s' q d qa" (is "?P s'")
  from HFail_HInv5_q2[OF act pnq]
  have "\<not> (?P s) \<Longrightarrow> \<not>(?P s')"
    by auto
  with nR2
  have P: "?P s"
    by blast
  from inv2a
  have inv2a': "Inv2a_inner s' q" by (auto simp add: Inv2a_def)
  from act pnq phase'
  have "phase s q = 2"
    by(auto simp add: Fail_def split: if_split_asm)
  with inv HFail_HInv5_q1[OF act pnq inv2a'] P
  show "maxBalInp s' (bal (dblock s' q)) (inp (dblock s' q))"
    by(auto simp add: HInv5_inner_def HInv5_inner_R_def)
qed

theorem HFail_HInv5:
  "\<lbrakk> HFail s s' p; HInv5_inner s q; Inv2a s' \<rbrakk> \<Longrightarrow> HInv5_inner s' q"
by(blast dest: HFail_HInv5_q HFail_HInv5_p)

lemma HPhase0Read_HInv5_p:
  "HPhase0Read s s' p d \<Longrightarrow> HInv5_inner s' p"
  by(auto simp add: Phase0Read_def HInv5_inner_def)

lemma HPhase0Read_allBlocks:
  assumes act: "HPhase0Read s s' p d"
  shows "allBlocks s' \<subseteq> allBlocks s"
  using HPhase0Read_blocksOf[OF act]
  by(auto simp add: allBlocks_def)

lemma HPhase0Read_HInv5_1:
  assumes act: "HPhase0Read s s' p d"
  and inv5_1: "maxBalInp s (bal(dblock s q)) (inp(dblock s q))"
  shows "maxBalInp s' (bal(dblock s' q)) (inp(dblock s' q))"
  using assms and HPhase0Read_blocksOf[OF act]
  by(auto simp add: Phase0Read_def maxBalInp_def allBlocks_def)

lemma HPhase0Read_HInv5_q2:
  assumes act: "HPhase0Read s s' p d"
  and pnq: "p\<noteq>q"
  and inv5_2: "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s q) < mbal(disk s d qq)
                                     \<and> \<not>hasRead s q d qq)"
  shows "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s' q) < mbal(disk s' d qq)
                                     \<and> \<not>hasRead s' q d qq)"
proof -
  from act pnq
  have  disk: "disk s' = disk s"
    and blocksRead: "\<forall>d. blocksRead s' q d = blocksRead s q d"
    and dblock: "dblock s' q = dblock s q"
    by(auto simp add: Phase0Read_def InitializePhase_def)
  with inv5_2
  show ?thesis
    by(auto simp add: hasRead_def)
qed

lemma HPhase0Read_HInv5_q:
  assumes act: "HPhase0Read s s' p d"
  and inv: "HInv5_inner s q"
  and pnq: "p\<noteq>q"
  shows "HInv5_inner s' q"
proof(auto simp add: HInv5_inner_def HInv5_inner_R_def)
  assume phase': "phase s' q = 2"
    and i2: "\<forall>D\<in>MajoritySet. \<forall>qa. \<exists>d\<in>D. bal (dblock s' q) < mbal (disk s' d qa) \<longrightarrow> hasRead s' q d qa"
  from phase' act have phase: "phase s q = 2"
    by(auto simp add: Phase0Read_def)
  show "maxBalInp s' (bal (dblock s' q)) (inp (dblock s' q))"
  proof(rule HPhase0Read_HInv5_1[OF act, of q])
    from HPhase0Read_HInv5_q2[OF act pnq] inv i2 phase
    show "maxBalInp s (bal (dblock s q)) (inp (dblock s q))"
      by(auto simp add: HInv5_inner_def HInv5_inner_R_def, blast)
  qed
qed

theorem HPhase0Read_HInv5:
  "\<lbrakk> HPhase0Read s s' p d; HInv5_inner s q \<rbrakk> \<Longrightarrow> HInv5_inner s' q"
by(blast dest: HPhase0Read_HInv5_q HPhase0Read_HInv5_p)

lemma HEndPhase0_HInv5_p:
  "HEndPhase0 s s' p  \<Longrightarrow> HInv5_inner s' p"
  by(auto simp add: EndPhase0_def HInv5_inner_def)

lemma  HEndPhase0_blocksOf_q:
  assumes act: "HEndPhase0 s s' p"
  and pnq: "p\<noteq>q"
  shows "blocksOf s' q \<subseteq> blocksOf s q"
proof -
  from act pnq
  have dblock: "{dblock s' q} \<subseteq> {dblock s q}"
    and disk: "disk s' = disk s"
    and blks: "blocksRead s' q = blocksRead s q"
    by(auto simp add: EndPhase0_def InitializePhase_def)
  from disk
  have disk': "{disk s' d q | d . d\<in> UNIV} \<subseteq> {disk s d q | d . d\<in> UNIV}" (is "?D' \<subseteq> ?D")
    by auto
  from pnq act
  have "(UN qq d. rdBy s' q qq d) \<subseteq> (UN qq d. rdBy s q qq d)"
    by(auto simp add: EndPhase0_def InitializePhase_def
                rdBy_def split: if_split_asm, blast)
  hence "{block br | br. br \<in> (UN qq d. rdBy s' q qq d)} \<subseteq>
         {block br | br. br \<in> (UN qq d. rdBy s q qq d)}"
    (is "?R' \<subseteq> ?R")
    by auto blast
  from union_inclusion[OF dblock union_inclusion[OF disk' this]]
  show ?thesis
    by(auto simp add: blocksOf_def)
qed

lemma HEndPhase0_allBlocks:
  assumes act: "HEndPhase0 s s' p"
  shows "allBlocks s' \<subseteq> allBlocks s \<union> {dblock s' p}"
proof(auto simp del: HEndPhase0_def simp add: allBlocks_def
           dest: HEndPhase0_blocksOf_q[OF act])
  fix x pa
  assume x_pa: "x \<in> blocksOf s' pa" and
         x_nblks: "\<forall>xa. x \<notin> blocksOf s xa"
  show "x=dblock s' p"
  proof(cases "p=pa")
    case True
    from x_nblks
    have "x \<notin> blocksOf s p"
      by auto
    with True subsetD[OF HEndPhase0_blocksOf[OF act] x_pa]
    show ?thesis
      by auto
  next
    case False
    from x_nblks subsetD[OF HEndPhase0_blocksOf_q[OF act False] x_pa]
    show ?thesis
      by auto
  qed
qed

lemma HEndPhase0_HInv5_q1:
  assumes act: "HEndPhase0 s s' p"
  and pnq: "p\<noteq>q"
  and inv1: "Inv1 s"
  and inv5_1: "maxBalInp s (bal(dblock s q)) (inp(dblock s q))"
  shows "maxBalInp s' (bal(dblock s' q)) (inp(dblock s' q))"
proof(auto simp add: maxBalInp_def)
  fix bk
  assume bk: "bk \<in> allBlocks s'"
    and bal: "bal (dblock s' q) \<le> bal bk"
  from act pnq
  have dblock': "dblock s' q = dblock s q" by(auto simp add: EndPhase0_def)
  from subsetD[OF HEndPhase0_allBlocks[OF act] bk]
  show "inp bk = inp (dblock s' q)"
  proof
    assume bk: "bk \<in> allBlocks s"
    with inv5_1 dblock' bal
    show ?thesis
      by(auto simp add: maxBalInp_def)
  next
    assume bk: "bk \<in> {dblock s' p}"
    with HEndPhase0_some[OF act inv1] act
    have "\<exists>ba\<in>allBlocksRead s p. bal ba = bal (dblock s' p) \<and> inp ba = inp (dblock s' p)"
      by(auto simp add: EndPhase0_def)
    then obtain ba
      where ba_blksread: "ba\<in>allBlocksRead s p"
      and ba_balinp: "bal ba = bal (dblock s' p) \<and> inp ba = inp (dblock s' p)"
      by auto
    have "allBlocksRead s p \<subseteq> allBlocks s"
      by(auto simp add: allBlocksRead_def allRdBlks_def
                      allBlocks_def blocksOf_def rdBy_def)
    from subsetD[OF this ba_blksread] ba_balinp bal bk dblock' inv5_1
    show ?thesis
      by(auto simp add: maxBalInp_def)
  qed
qed

lemma HEndPhase0_HInv5_q2:
  assumes act: "HEndPhase0 s s' p"
  and pnq: "p\<noteq>q"
  and inv5_2: "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s q) < mbal(disk s d qq)
                                     \<and> \<not>hasRead s q d qq)"
  shows "\<exists>D\<in>MajoritySet. \<exists>qq. (\<forall>d\<in>D.    bal(dblock s' q) < mbal(disk s' d qq)
                                     \<and> \<not>hasRead s' q d qq)"
proof -
  from act pnq
  have  disk: "disk s' = disk s"
    and blocksRead: "\<forall>d. blocksRead s' q d = blocksRead s q d"
    and dblock: "dblock s' q = dblock s q"
    by(auto simp add: EndPhase0_def InitializePhase_def)
  with inv5_2
  show ?thesis
    by(auto simp add: hasRead_def)
qed

lemma HEndPhase0_HInv5_q:
  assumes act: "HEndPhase0 s s' p"
  and inv: "HInv5_inner s q"
  and inv1: "Inv1 s"
  and pnq: "p\<noteq>q"
  shows "HInv5_inner s' q"
  using assms and
    HEndPhase0_HInv5_q1[OF act pnq inv1]
    HEndPhase0_HInv5_q2[OF act pnq]
  by(auto simp add: HInv5_inner_def HInv5_inner_R_def EndPhase0_def)

theorem HEndPhase0_HInv5:
  "\<lbrakk> HEndPhase0 s s' p; HInv5_inner s q; Inv1 s \<rbrakk> \<Longrightarrow> HInv5_inner s' q"
  by(blast dest: HEndPhase0_HInv5_q HEndPhase0_HInv5_p)

text\<open>
  $HInv1 \wedge HInv2 \wedge HInv3 \wedge HInv4 \wedge HInv5$ is an invariant of $HNext$.

\<close>

lemma I2e:
  assumes nxt: "HNext s s'"
  and inv: "HInv1 s \<and> HInv2 s \<and> HInv2 s' \<and> HInv3 s \<and> HInv4 s \<and> HInv5 s"
  shows "HInv5 s'"
  using assms
  by(auto simp add: HInv5_def HNext_def Next_def,
       auto simp add: HInv2_def intro: HStartBallot_HInv5,
       auto intro: HPhase0Read_HInv5,
        auto simp add: HInv4_def intro: HPhase1or2Write_HInv5,
        auto simp add: Phase1or2Read_def
             intro: HPhase1or2ReadThen_HInv5
                    HPhase1or2ReadElse_HInv5,
        auto simp add: EndPhase1or2_def HInv1_def HInv4_def HInv5_def
             intro: HEndPhase1_HInv5
                    HEndPhase2_HInv5,
        auto intro: HFail_HInv5,
        auto intro: HEndPhase0_HInv5 simp add: HInv1_def)

end