theory Semantics_Facts imports Semantics
begin

(*
 * Various lemmas about the semantics constructs from Semantics.thy
 *)

lemma Excp_1' :
  assumes H: "sem_exec_c_p gs m1 1 m2"
  shows  "sem_step_p gs m1 m2"
  using H
proof(cases rule: sem_exec_c_p.cases)
  case Excp_0
  then show ?thesis by auto
next
  case (Excp_Suc m2' n)

  have "sem_exec_c_p gs m2' 0 m2"
    using Excp_Suc by auto

  hence "m2' = m2"
    by(cases rule: sem_exec_c_p.cases; auto)

  then show ?thesis using Excp_Suc by auto
qed

lemma exec_c_p_split :
  assumes H : "sem_exec_c_p gs m1 n m3"
  assumes Hj : "j \<le> n"
  shows "\<exists> m2 . sem_exec_c_p gs m1 j m2 \<and> sem_exec_c_p gs m2 (n - j) m3"
  using H Hj
proof(induction arbitrary: j rule: sem_exec_c_p.induct)
  case (Excp_0 m)

  have "sem_exec_c_p gs m j m \<and> sem_exec_c_p gs m (0 - j) m"
    using sem_exec_c_p.intros(1)[of gs m] Excp_0
    by auto

  then show ?case by blast
next
  case (Excp_Suc m1 m2 n m3)
  then show ?case
  proof(cases j)
    case 0

    have C1 : "sem_exec_c_p gs m1 0 m1"
      using sem_exec_c_p.intros(1)[of gs m1] by auto

    have C2 : "sem_exec_c_p gs m1 (Suc n) m3" using sem_exec_c_p.intros(2)[OF Excp_Suc(1) Excp_Suc(2)]
      by auto

    have "sem_exec_c_p gs m1 j m1 \<and> sem_exec_c_p gs m1 (Suc n - j) m3"
      using C1 C2 0 by auto

    then show ?thesis by blast

  next
    case (Suc j')

    hence Leq : "j' \<le> n" using Excp_Suc by auto

    obtain m2x where M2x1 : "sem_exec_c_p gs m2 j' m2x" and M2x2 : "sem_exec_c_p gs m2x (n - j') m3"
      using Excp_Suc.IH[OF Leq]
      by auto

    have "sem_exec_c_p gs m1 (j' + 1) m2x" using sem_exec_c_p.intros(2)[OF Excp_Suc(1) M2x1]
      by auto

    hence C1' : "sem_exec_c_p gs m1 (j) m2x" using Suc by auto

    have C2' : "sem_exec_c_p gs m2x (Suc n - j) m3" using M2x2 Suc Excp_Suc.prems
      by auto

    show ?thesis using C1' C2' by blast

  qed
qed

lemma exec_c_p_determ :
  assumes H1 : "sem_exec_c_p gs m1 n m2"
  assumes H2 : "sem_exec_c_p gs m1 n m2'"
  shows "m2 = m2'" using H1 H2
proof(induction arbitrary: m2' rule: sem_exec_c_p.induct)
  case (Excp_0 m)
  then show ?case
    by(cases rule: sem_exec_c_p.cases; auto)
next
  case (Excp_Suc m1 m2 n m3)

  obtain m2_copy
    where M2_copy1 : "sem_exec_c_p gs m1 1 m2_copy" and
      M2_copy2 :"sem_exec_c_p gs m2_copy (Suc n - 1) m2'"
    using exec_c_p_split[OF Excp_Suc.prems, of 1]
    by auto

  have Step' : "sem_step_p gs m1 m2_copy" using M2_copy1
  proof(cases rule: sem_exec_c_p.cases)
    case Excp_0
    then show ?thesis by auto
  next
    case Excp_Suc' : (Excp_Suc m2z nz)

    then have "sem_exec_c_p gs m2z 0 m2_copy"
      by auto

    hence M2_eq : "m2z = m2_copy"
      by(cases rule: sem_exec_c_p.cases; auto)

    then show ?thesis using Excp_Suc' by auto
  qed

  have M2_eq : "m2 = m2_copy"
    using determE[OF sem_step_determ Step', of m2] Excp_Suc.hyps(1)
    by auto

  hence M2_copy2' : "sem_exec_c_p gs m2 (n) m2'"
    using M2_copy2 by auto

  show ?case using Excp_Suc.IH[OF M2_copy2'] by auto
qed

(* lemma for reasoning about compound executions *)
lemma rtranclp_bisect1 :
  assumes H0 : "determ R"
  assumes H : "R\<^sup>*\<^sup>* xi xp"
  assumes H1 : "R xi x1"
  assumes H2 : "R xp xf"
  shows "R\<^sup>*\<^sup>* x1 xf" using H H0 H1 H2
proof(induction arbitrary: x1 xf rule: rtranclp_induct)
  case base

  have Eq : "x1 = xf" using determE[OF H0 base(2) base(3)] by auto

  then show ?case using base by auto
next
  case (step y z)

  have X1z : "R\<^sup>*\<^sup>* x1 z" using step.IH[OF step.prems(1) step.prems(2) step.hyps(2)]
    by auto

  show ?case using rtranclp.intros(2)[OF X1z step.prems(3)] by auto
qed

(* lemma for reasoning about executions which cannot step  *)
lemma rtranclp_nostep :
  assumes H0 : "determ R"
  assumes H : "R\<^sup>*\<^sup>* x1 x2"
  assumes H1 : "\<And> x1' . R x1 x1' \<Longrightarrow> False"
  shows "x1 = x2" using H H0 H1
proof(induction  rule: rtranclp_induct)
  case base
  then show ?case by auto
next
  case (step y z)

  have Xeq : "x1 = y"
    using step.IH[OF step.prems(1) step.prems(2), of id]
    by auto

  show ?case using step.hyps step.prems(2) unfolding Xeq
    by auto
qed

lemma rtranclp_induct_alt :
  assumes H : "rtranclp r a b"
  assumes Ha : "P a"
  assumes Hsteps : "(\<And> y z . rtranclp r a y \<Longrightarrow> rtranclp r y z \<Longrightarrow> P y \<Longrightarrow> P z)"
  shows "P b" using assms
proof(induction rule: rtranclp_induct)
  case base
  then show ?case by auto
next
  case (step y z)

  have Py : "P y" using step.IH[OF step.prems(1) step.prems(2)]
    by auto

  have Rz : "rtranclp r y z" using step.hyps
    by(auto)

  show ?case using step.prems(2)[OF step.hyps(1) Rz Py] by auto
qed

lemma rtranclp_paths_step :
  assumes H0 : "determ R"
  assumes H1 : "R\<^sup>*\<^sup>* x1 y"
  assumes H2 : "R x1 x2"
  shows "(x1 = y \<or> R\<^sup>*\<^sup>* x2 y)" using H1 H2
proof(induction arbitrary: x2 rule:rtranclp_induct)
  case base
  then show ?case by auto
next
  case (step nxt last)

  have Opts : "x1 = nxt \<or> R\<^sup>*\<^sup>* x2 nxt"
    using step.IH[OF step.prems(1)] by auto

  then show ?case
  proof(cases "x1 = nxt")
    case True

    then have X1alt : "R x1 last"
      using step.hyps by auto

    then have X2alt : "x2 = last"
      using determE[OF H0 X1alt step.prems(1)]
      by auto

    hence "R\<^sup>*\<^sup>* x2 last"
      by auto

    thus ?thesis by auto
  next
    case False

    then have False' : "R\<^sup>*\<^sup>* x2 nxt" using Opts by auto

    show ?thesis using rtranclp.intros(2)[OF False' step.hyps(2)]
      by auto
  qed
qed

lemma rtranclp_paths :
  assumes H0 : "determ R"
  assumes H1 : "R\<^sup>*\<^sup>* x y1"
  assumes H2 : "R\<^sup>*\<^sup>* x y2"
  shows
    "(R\<^sup>*\<^sup>* y2 y1) \<or>
     (R\<^sup>*\<^sup>* y1 y2)" using H1 H2
proof(induction arbitrary: y2 rule:rtranclp_induct)
  case base
  then show ?case by auto
next
  case (step nxt last)

  have Alts : "R\<^sup>*\<^sup>* y2 nxt \<or> R\<^sup>*\<^sup>* nxt y2"
    using step.IH[OF step.prems(1)] by auto

  show ?case
  proof(cases "R\<^sup>*\<^sup>* y2 nxt")
    case True

    then have "R\<^sup>*\<^sup>* y2 last"
      using rtranclp.intros(2)[OF True step.hyps(2)] by auto

    then show ?thesis by auto
  next
    case False

    then have False' : "R\<^sup>*\<^sup>* nxt y2" using Alts by auto

    have Alts' : "nxt = y2 \<or> R\<^sup>*\<^sup>* last y2"
      using rtranclp_paths_step[OF H0 False' step.hyps(2)]
      by auto

    show ?thesis
    proof(cases "nxt = y2")
      case True

      then have "R\<^sup>*\<^sup>* y2 last" using step.hyps(2) by auto

      then show ?thesis by auto
    next
      case False

      hence False'' : "R\<^sup>*\<^sup>* last y2" using Alts' by auto

      then show ?thesis by auto
    qed
  qed
qed

(* Facts relating executable interpreters to propositional ones *)
lemma sem_exec_c_p_exec' :
  assumes "sem_exec gs n m = Inl m'"
  shows "sem_exec_c_p gs m n m'"
  using assms
proof(induction n arbitrary: m m')
  case 0

  then have Meq : "m = m'"
    by(cases "cont m"; auto split: list.splits)

  show ?case unfolding Meq 0
    by(auto intro:sem_exec_c_p.intros)
next

  case (Suc n)

  then obtain m1 where M1: "sem_step gs m = Inl m1"
    by(auto split: sum.splits list.splits simp add: sem_step_def)

  then have Rest : "sem_exec gs n m1 = Inl m'" using Suc
    by(auto split: sum.splits list.splits simp add: sem_step_def)

  have Rest' : "sem_exec_c_p gs m1 n m'"
    using Suc.IH[OF Rest] by auto

  have Conc' : "sem_exec_c_p gs m (1 + n) m'"
  proof(rule Excp_Suc_gen)
    show "sem_exec_c_p gs m 1 m1"
      using Excp_1[OF M1[unfolded sym[OF sem_step_p_eq]]]
      by auto
  next
    show "sem_exec_c_p gs m1 n m'"
      using Rest' by auto
  qed

  then show ?case by auto
qed

lemma sem_exec_c_p_run:
  assumes "sem_exec_c_p gs m n m'"
  assumes "cont m' = Inl l"
  shows "sem_run gs n m = Inl m'"
  using assms
proof(induction arbitrary: l rule: sem_exec_c_p.induct)
  case (Excp_0 m)
  then show ?case
    by(auto split: sum.splits list.splits)
next
  case (Excp_Suc m1 m2 n m3)
  show ?case
  proof(cases "cont m1")
    case (Inr msg)

    then show ?thesis using Excp_Suc
      by(auto simp add: sem_step_p_eq sem_step_def)

  next

    case (Inl l1)

    show ?thesis
    proof(cases l1)

      case Nil

      then show ?thesis using Excp_Suc Inl
        by(auto simp add: sem_step_p_eq sem_step_def)
    next
      case (Cons l1h l1t)

      then show ?thesis using Excp_Suc Inl
        by(auto simp add: sem_step_p_eq sem_step_def)
    qed
  qed
qed

(* problem. sem_exec_c_p tries to run
exactly that many steps. *)
lemma sem_exec_c_p_run' :
  assumes "sem_run gs n m = Inl m'"
  shows "\<exists> nmin . nmin \<le> n \<and> sem_exec_c_p gs m nmin m'"
  using assms
proof(induction n arbitrary: m m')
  case 0

  then have "m = m'"
    by(auto split: sum.splits list.splits)

  then show ?case
    by(auto intro: sem_exec_c_p.intros)

next

  case (Suc n)

  show ?case
  proof(cases "cont m")
    case (Inr msg)

    then show ?thesis using Suc
      by(auto simp add: sem_step_p_eq sem_step_def)

  next

    case (Inl l1)

    show ?thesis
    proof(cases l1)
      case Nil

      then have Eq: "m = m'" using Suc.prems Inl
        by(auto)

      have Conc' : "sem_exec_c_p gs m 0 m'"
        unfolding Eq
        by(auto intro: sem_exec_c_p.intros)

      then show ?thesis
        by fastforce
    next

      case (Cons l1h l1t)

      then obtain m1 where M1 : "sem_step gs m = Inl m1"
        using Suc.prems Inl
        by(auto simp add: sem_step_def)

      then have Rest: "sem_run gs n m1 = Inl m'"
        using Suc.prems Cons Inl
        by(auto simp add: sem_step_def)

      then obtain nmin where Nmin :
        "sem_exec_c_p gs m1 nmin m'" "nmin \<le> n"
        using Suc.IH[OF Rest]
        by(auto)

      then have Conc' : "sem_exec_c_p gs m (1 + nmin) m'"
        using sem_exec_c_p.intros(2)
          [OF sem_step_sem_step_p[OF M1] Nmin(1)]
        by auto

      then show ?thesis using Nmin(2)by fastforce
    qed
  qed
qed

(*
  proof(cases l)
    case Nil

    then show ?thesis using Excp_Suc
      by(auto simp add: sem_step_p_eq sem_step_def split:sum.splits list.splits)
  next
    case (Cons lh lt)

    have Rest : "sem_run gs n m2 = Inl m3"
      using Excp_Suc
      by auto

    then show ?thesis using Excp_Suc.prems Rest Cons
      apply(auto split: sum.splits list.splits)
*)
(*
  case 0

  then have Meq : "m = m'"
    by(cases "cont m"; auto split: list.splits)

  show ?case unfolding Meq 0
    by(auto intro:sem_exec_c_p.intros)
next

  case (Suc n)

  then obtain m1 where M1: "sem_step gs m = Inl m1"
    by(auto split: sum.splits list.splits simp add: sem_step_def)

  then have Rest : "sem_exec gs n m1 = Inl m'" using Suc
    by(auto split: sum.splits list.splits simp add: sem_step_def)

  have Rest' : "sem_exec_c_p gs m1 n m'"
    using Suc.IH[OF Rest] by auto

  have Conc' : "sem_exec_c_p gs m (1 + n) m'"
  proof(rule Excp_Suc_gen)
    show "sem_exec_c_p gs m 1 m1"
      using Excp_1[OF M1[unfolded sym[OF sem_step_p_eq]]]
      by auto
  next
    show "sem_exec_c_p gs m1 n m'"
      using Rest' by auto
  qed

  then show ?case by auto
qed
*)

end


theory ListDemo
imports "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

(*
primrec hd :: "'a Lst \<Rightarrow> 'a"
where
  "hd (Cons x xs) = x"
*)
fun app :: "'a Lst \<Rightarrow> 'a Lst \<Rightarrow> 'a Lst"
where
  "app Emp xs = xs"
| "app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a Lst \<Rightarrow> 'a Lst"
where
  "rev Emp = Emp"
| "rev (Cons x xs) = app (rev xs) (Cons x Emp)"

fun qrev :: "'a Lst \<Rightarrow> 'a Lst \<Rightarrow> 'a Lst"
where
  "qrev Emp a = a"
| "qrev (Cons x xs) a = qrev xs (Cons x a)"

hipster app
lemma lemma_a [thy_expl]: "app y Emp = y"
  apply (induct y)
  apply simp
  apply simp
  done

lemma lemma_aa [thy_expl]: "app (app y z) x2 = app y (app z x2)"
  apply (induct y arbitrary: x2 z)
  apply simp
  apply simp
  done
(*lemma lemma_a [thy_expl]: "app x2 Emp = x2"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.rev.simps ListDemo.app.simps thy_expl} *})

lemma lemma_aa [thy_expl]: "app (app x2 y2) z2 = app x2 (app y2 z2)"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.rev.simps ListDemo.app.simps thy_expl} *})
*)

hipster rev
lemma lemma_ab [thy_expl]: "app (ListDemo.rev z) (ListDemo.rev y) = ListDemo.rev (app y z)"
apply (induct y arbitrary: z)
apply (simp add: lemma_a)
apply (metis ListDemo.rev.simps(2) app.simps(2) lemma_aa)
done

lemma lemma_ac [thy_expl]: "ListDemo.rev (Lst.Cons z (ListDemo.rev y)) = app y (Lst.Cons z Emp)"
apply (induct y)
  apply simp
  apply (metis ListDemo.rev.simps(2) Lst.distinct(1) Lst.inject app.elims app.simps(1) lemma_ab rev.elims)
  done

lemma lemma_ad [thy_expl]: "ListDemo.rev (app z (ListDemo.rev y)) = app y (ListDemo.rev z)"
  apply (induct y arbitrary: z)
  apply (metis ListDemo.rev.simps(1) lemma_ab)
  apply (metis ListDemo.rev.simps(1) ListDemo.rev.simps(2) app.simps(1) app.simps(2) lemma_ab)
  done
(*lemma lemma_ab [thy_expl]: "app (ListDemo.rev x5) (ListDemo.rev y5) = ListDemo.rev (app y5 x5)"
apply (induct y5)
sledgehammer
apply (metis ListDemo.rev.simps(1) app.simps(1) lemma_a)
sledgehammer
by (metis ListDemo.rev.simps(2) app.simps(2) lemma_aa)
*)

theorem rev_rev : "rev(rev xs) = xs "
(* by hipster_induct*)
  apply (induct xs)
  apply simp
  apply (metis ListDemo.rev.simps(1) ListDemo.rev.simps(2) app.simps(1) app.simps(2) lemma_ab)
  done
 (* sledgehammer
  by (metis ListDemo.rev.simps(1) lemma_a lemma_ad)*)
(*apply (induct xs)
sledgehammer
(* apply (tactic {* Hipster_Explore.explore_goal @{context} ["ListDemo.rev", "ListDemo.app"] *}) *)
apply (metis ListDemo.rev.simps(1))
apply simp
sledgehammer
by (metis ListDemo.rev.simps(1) ListDemo.rev.simps(2) app.simps(1) app.simps(2) lemma_ab)
*)
(*
Try first proving lemmas:

lemma lemma_a [thy_expl]: "app x2 Emp = x2"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.rev.simps ListDemo.app.simps thy_expl} *})

lemma lemma_aa [thy_expl]: "app (app x2 y2) z2 = app x2 (app y2 z2)"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.rev.simps ListDemo.app.simps thy_expl} *})

lemma lemma_ab [thy_expl]: "app (ListDemo.rev x5) (ListDemo.rev y5) = ListDemo.rev (app y5 x5)"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.rev.simps ListDemo.app.simps thy_expl} *})

then prove the open goal ListDemo.rev (ListDemo.rev xs) = xs by (tactic {*Simp_Metis_Tacs.routine_tac @{context}*})
*)

ML\<open>Hipster_Explore.explore @{context} ["ListDemo.app", "ListDemo.rev", "ListDemo.qrev"];
\<close>
lemma lemma_a' [thy_expl]: "app x2 Emp = x2"
by (tactic \<open>Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl}\<close>)

lemma lemma_aa' [thy_expl]: "qrev (qrev x2 y2) z2 = qrev y2 (app x2 z2)"
by (tactic \<open>Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl}\<close>)

lemma lemma_ab' [thy_expl]: "qrev (ListDemo.rev x5) y5 = app x5 y5"
by (tactic \<open>Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl}\<close>)
thm thy_expl

setup \<open>Hipster_Explore.setup_exploration ["ListDemo.app", "ListDemo.rev", "ListDemo.qrev"];
\<close>

thm thy_expl

theorem rev_qrev : "rev xs = qrev xs Emp"
apply (induct xs)
apply simp
apply simp
by (metis thy_expl qrev.simps(1))
(*
apply (tactic {* Hipster_Explore.explore_goal @{context} ["ListDemo.rev", "ListDemo.app", "ListDemo.qrev"] *})
*)
ML \<open>\<close>

(*

lemma lemma_a [thy_expl]: "app x2 Emp = x2"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl} *})

lemma lemma_aa [thy_expl]: "qrev (qrev x2 y2) z2 = qrev y2 (app x2 z2)"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl} *})

lemma lemma_ab [thy_expl]: "qrev (ListDemo.rev x5) y5 = app x5 y5"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl} *})

lemma rev_qrev: "rev xs = qrev xs Emp"
sledgehammer
by (metis lemma_a lemma_aa lemma_ab)

lemma rev_rev : "rev(rev xs) = xs"
sledgehammer
by (metis lemma_a lemma_ab rev_qrev)

ML{* Hipster_Explore.explore @{context} ["ListDemo.qrev", "ListDemo.rev"]; *}

lemma f
 explore
proof -
  have lemma1: f
    proof
  have lemma2: g
    proof
  from lemma1 lemma2 show ?thesis
    proof
qed

*)
lemma lemma_ab'' [thy_expl]: "qrev x5 Emp = ListDemo.rev x5"
by (tactic \<open>Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl}\<close>)

end


theory "FMap-HOLCF"
  imports FMap  "HOLCF-Set"
begin

default_sort type

lemma cont_compose2:
  assumes "cont c"
  assumes "\<And> x. cont (c x)"
  assumes "cont f"
  assumes "cont g"
  shows "cont (\<lambda>x. c (f x) (g x))"
proof-
  have "monofun (\<lambda>x. c (f x) (g x))"
    apply (rule monofunI)
    apply (rule below_trans[OF cont2monofunE[OF assms(2) cont2monofunE[OF `cont g`]]], assumption)
    apply (rule fun_belowD[OF cont2monofunE[OF `cont c` cont2monofunE[OF `cont f`]]], assumption)
    done
  thus ?thesis
    apply (rule contI2)
    apply (subst cont2contlubE[OF `cont f`], assumption)
    apply (subst cont2contlubE[OF `cont g`], assumption)
    apply (subst cont2contlubE[OF `cont c` ch2ch_cont[OF `cont f`]], assumption)
    apply (subst lub_fun[OF ch2ch_cont[OF `cont c` ch2ch_cont[OF `cont f`]]], assumption)
    apply (subst cont2contlubE[OF assms(2)ch2ch_cont[OF `cont g`]], assumption)
    apply (subst diag_lub)
    apply (rule ch2ch_fun[OF ch2ch_cont[OF `cont c` ch2ch_cont[OF `cont f`]]], assumption)
    apply (rule ch2ch_cont[OF assms(2) ch2ch_cont[OF `cont g`]], assumption)
    apply (rule below_refl)
    done
qed

subsubsection {* A partial order on finite maps *}

instantiation fmap :: (type, po) po
begin
  definition "(a::'a f\<rightharpoonup> 'b) \<sqsubseteq> b \<equiv> (fdom a = fdom b) \<and> (\<forall>x \<in> fdom a. a f! x \<sqsubseteq> b f! x)"

instance
proof default
  fix x :: "'a f\<rightharpoonup> 'b"
  show "x \<sqsubseteq> x" by (auto simp add:below_fmap_def)
next
  fix x y z :: "'a f\<rightharpoonup> 'b"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z"
  thus "x \<sqsubseteq> z"
  apply (auto simp add: below_fmap_def)
  by (metis rev_below_trans)
next
  fix x y :: "'a f\<rightharpoonup> 'b"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x"
  thus "x = y"
  by (metis "FMap-HOLCF.below_fmap_def" fmap_eqI po_eq_conv)
qed
end

lemma fmap_belowI:
  assumes "fdom a = fdom b"
    and "\<And> x. \<lbrakk>
      x \<in> fdom a;
      x \<in> fdom b
      \<rbrakk>  \<Longrightarrow> a f! x \<sqsubseteq> b f! x"
  shows "a \<sqsubseteq> b"
  using assms
  by (metis below_fmap_def)

lemma fmap_belowE:
  assumes "m1 \<sqsubseteq> m2"
  shows "m1 f! x \<sqsubseteq> m2 f! x"
  apply (cases "x \<in> fdom m1")
  using assms
  apply (metis below_fmap_def)
  using assms unfolding below_fmap_def
  apply (transfer, auto)
  done

subsubsection {* The order is chain-complete *}

definition fmap_lub_raw where
  "fmap_lub_raw S = (\<lambda> x.
      if (x \<in> dom (S 0))
      then Some (\<Squnion>i::nat. the (S i x))
      else None)"

lemma fmap_lub_raw_dom[simp]: "dom (fmap_lub_raw S) = dom (S 0)"
  by (auto simp add: fmap_lub_raw_def dom_def)

lift_definition fmap_lub :: "(nat \<Rightarrow> ('key f\<rightharpoonup> 'value::po)) \<Rightarrow> 'key f\<rightharpoonup> 'value" is "fmap_lub_raw"
  unfolding Lifting.invariant_def
  apply auto
  apply (erule  meta_allE[of _ 0])
  apply auto[1]
  apply (subgoal_tac "fun1 = fun2")
  apply auto
  done

lemma fmap_below_dom:
  "a \<sqsubseteq> b \<Longrightarrow> fdom a = fdom b"
  unfolding below_fmap_def by simp

lemma is_lub_fmap:
  assumes "chain (S::nat => 'a f\<rightharpoonup> 'b::cpo)"
  shows "range S <<| fmap_lub S"
proof(rule is_lubI)

  def d \<equiv> "fdom (S 0)"
  have [simp]:"\<And>i . fdom (S i) = d"
    using chain_mono[OF `chain S`, of 0]
    unfolding d_def
    by (metis fmap_below_dom le0)
  hence [simp]: "fdom (fmap_lub S) = d"
    unfolding fmap_lub.rep_eq fdom.rep_eq fmap_lub_raw_def  dom_def
    by auto

{
  show "range S <| fmap_lub S"
  proof(rule is_ubI)
  case (goal1 m)
    then obtain i where "m = S i" by auto
    hence "S 0 \<sqsubseteq> m" using chain_mono[OF `chain S`] by auto

    have [simp]: "fdom m = d" using `m = S i` by simp

    show "m \<sqsubseteq> fmap_lub S"
    proof(rule fmap_belowI)
      fix x
      assume "x \<in> fdom m"
      hence c2: "chain (\<lambda> i. the (Rep_fmap (S i) x))" using `chain S`
        unfolding chain_def below_fmap_def lookup.rep_eq
        by auto

      have "m f! x = the (Rep_fmap (S i) x)"  using `m = _` by (auto simp add: lookup.rep_eq)
      hence ylt: "m f! x \<sqsubseteq> (\<Squnion>i::nat. the (Rep_fmap (S i) x))"
          using is_ub_thelub[OF c2] by (auto simp add: lookup.rep_eq)
      also
      have "x \<in> fdom (S 0) " using `x \<in> fdom m` by simp
      hence "(\<Squnion>i::nat. the (Rep_fmap (S i) x)) = (fmap_lub S) f! x"
        by (auto simp add: fmap_lub.rep_eq lookup.rep_eq fmap_lub_raw_def fdom.rep_eq)
      finally
      show "m f! x \<sqsubseteq> (fmap_lub S) f! x".
    qed simp
  qed
next
  fix u
  assume "range S <| u"

  hence [simp]: "fdom u = d"
    by (metis ub_rangeD  `\<And>i. fdom (S i) = d` fmap_below_dom)

  show "fmap_lub S \<sqsubseteq> u "
  proof(rule fmap_belowI)
    fix x

    assume  "x \<in> fdom (fmap_lub S)"
    hence c2: "chain (\<lambda> i. the (Rep_fmap (S i) x))" (is "chain ?S2") using `chain S`
      unfolding chain_def below_fmap_def lookup.rep_eq
      by auto

    have "x \<in> fdom (S 0) " using `x \<in> fdom (fmap_lub S)` by simp
    hence "lookup (fmap_lub S) x = Some (lub (range ?S2))"
      by (auto simp add: fmap_lub.rep_eq lookup.rep_eq fmap_lub_raw_def fdom.rep_eq)

    hence lub_at_x: "range ?S2 <<| (fmap_lub S f! x)"
      by (metis c2 the.simps thelubE)

    assume "x \<in> fdom u"
    have "range ?S2 <| (u f! x)"
      using ub_rangeD[OF `range S <| u`] `x \<in> fdom u`
      by (auto intro: ub_rangeI simp add:  below_fmap_def lookup.rep_eq)

    thus "(fmap_lub S) f! x \<sqsubseteq> u f! x"
      by (rule is_lubD2[OF lub_at_x])
  qed simp
}
qed

instance fmap :: (type, cpo) cpo
apply default
proof
  fix S :: "nat \<Rightarrow> 'a f\<rightharpoonup> 'b"
  assume "chain S"
  thus "range S <<| fmap_lub S"
    by (rule is_lub_fmap)
qed

lemma unfold_lub_fmap:  "chain (Y::nat => 'a f\<rightharpoonup> 'b::cpo) \<Longrightarrow> lub (range Y) = fmap_lub Y"
  by (rule lub_eqI, rule is_lub_fmap)

subsubsection {* Continuity and finite maps *}

lemma chain_fdom:
  assumes "chain (Y :: nat \<Rightarrow> 'a\<Colon>type f\<rightharpoonup> 'b\<Colon>cpo) "
  shows "fdom (Y i) = fdom (Y 0)" and "fdom (\<Squnion> i. Y i) = fdom (Y 0)"
proof-
    have "Y 0 \<sqsubseteq> Y i" apply (rule chain_mono[OF `chain Y`]) by simp
    thus "fdom (Y i) = fdom (Y 0)" by-(drule fmap_below_dom, rule sym)
    moreover
    have "Y 0 \<sqsubseteq> (\<Squnion>i . Y i)"  by (rule is_ub_thelub[OF `chain Y`])
    thus "fdom (\<Squnion> i. Y i) = fdom (Y 0)" by-(drule fmap_below_dom, rule sym)
qed

lemma cont_if_fdom:
  assumes "cont (\<lambda>x. k (f x))"
  assumes "cont (\<lambda>x. k (g x))"
  assumes "cont h"
  shows "cont (\<lambda>x. k (if j (fdom (h x))  then f x else g x))"
proof-
  have "monofun (\<lambda>x. k (if j (fdom (h x)) then f x else g x))"
    apply (rule monofunI)
    apply (frule fmap_below_dom[OF cont2monofunE[OF `cont h`]])
    apply (auto intro: cont2monofunE[OF assms(1)] cont2monofunE[OF assms(2)])
    done
  thus ?thesis
    unfolding if_distrib
    apply (rule contI2)
    apply (subst cont2contlubE[OF `cont h`], assumption)
    apply (subst chain_fdom(1)[OF ch2ch_cont[OF `cont h`]], assumption)
    apply (subst chain_fdom(2)[OF ch2ch_cont[OF `cont h`]], assumption)
    apply (subst cont2contlubE[OF cont_if[OF assms(1) assms(2)]], assumption)
    apply (rule below_refl)
    done
qed

lemma lookup_chain:
  assumes "chain (Y :: nat \<Rightarrow> 'a f\<rightharpoonup> 'b::cpo)"
  shows "chain (\<lambda> i . (Y i) f! x)"
proof(rule chainI)
  fix i
  have "fdom (Y i) = fdom (Y 0)" and
       "fdom (Y (Suc i)) = fdom (Y 0)" and
       "fdom (Y j) = fdom (Y 0)"
       by (intro chain_fdom[OF `chain Y`])+
  have "Y i \<sqsubseteq> Y (Suc i)" using `chain _` by (rule chainE)
    hence "fdom (Y (Suc i)) = fdom (Y i)" unfolding below_fmap_def by simp
  show "(Y i) f! x \<sqsubseteq> Y (Suc i) f! x"
    proof(cases "x \<in> fdom (Y i)")
    case True thus ?thesis using `_ \<sqsubseteq> _`  by (simp add: below_fmap_def)
    next
    case False
      hence "(Y i) f! x = the None"
        by (transfer, auto simp add: dom_def)
      moreover
      have "x \<notin> fdom (Y (Suc i))"
        using False `fdom (Y (Suc i)) = fdom (Y i)` by simp
      hence "Y (Suc i) f! x = the None"
        by (transfer, auto simp add: dom_def)
      ultimately show ?thesis by simp
    qed
qed

lemma lookup_cont:
  assumes "chain (Y :: nat \<Rightarrow> 'a f\<rightharpoonup> 'b::cpo)"
  shows "(\<Squnion> i. Y i) f! x = (\<Squnion> i. (Y i) f! x)"
proof(cases "x \<in> fdom (Y 0)")
case True thus ?thesis
  unfolding unfold_lub_fmap[OF `chain Y`]
  apply transfer
  apply (auto simp add: fmap_lub_raw_def)
  done
next
case False
  have "\<And> i. lookup (Y i) x = None"
    by (metis False assms chain_fdom(1) domIff fdom.rep_eq lookup.rep_eq)
  thus ?thesis
    unfolding unfold_lub_fmap[OF `chain Y`]
    by (transfer, auto simp add: fmap_lub_raw_def)
qed

lemma cont2cont_lookup[simp,cont2cont]:
  fixes f :: "'a::cpo \<Rightarrow> 'b::type f\<rightharpoonup> 'c::cpo"
  assumes "cont f"
  shows "cont (\<lambda>p. (f p) f! x)"
proof (rule cont_compose[OF _ `cont f`], rule contI)
  fix Y :: "nat \<Rightarrow> 'b::type f\<rightharpoonup> 'c::cpo"
  assume "chain Y"
  show "range (\<lambda>i. (Y i) f! x) <<| ((\<Squnion> i. Y i) f! x)"
    by (subst lookup_cont[OF `chain Y`], rule cpo_lubI[OF lookup_chain[OF `chain Y`]])
qed

lemma fmap_cont_via_lookupI:
  assumes "\<And> x y . x \<sqsubseteq> y \<Longrightarrow> fdom (f x) = fdom (f y)"
  assumes "\<And> x. cont (\<lambda> \<rho> . f \<rho> f! x)"
  shows "cont f"
proof-
  have "monofun f"
    apply (rule monofunI)
    apply (rule fmap_belowI)
    apply (erule assms(1))
    apply (erule cont2monofunE[OF assms(2)])
    done
  thus ?thesis
    apply (rule contI2)
    apply (rule fmap_belowI)
    apply (simp add: chain_fdom)
    apply (erule assms(1)[symmetric, OF is_ub_thelub])
    apply (subst cont2contlubE[OF assms(2)], assumption)
    apply (subst lookup_cont, assumption)
    apply (rule below_refl)
    done
qed

lemma fmap_upd_mono:
  "\<rho>1 \<sqsubseteq> \<rho>2 \<Longrightarrow> v1 \<sqsubseteq> v2 \<Longrightarrow> \<rho>1(x f\<mapsto> v1) \<sqsubseteq> \<rho>2(x f\<mapsto> v2)"
  apply (rule fmap_belowI)
  apply (auto dest:fmap_below_dom)[1]
  apply (case_tac "xa = x")
  apply simp
  apply (auto elim:fmap_belowE)
  done

lemma fmap_upd_cont[simp,cont2cont]:
  assumes "cont f" and "cont h"
  shows "cont (\<lambda> x. fmap_upd (f x) v (h x) :: 'a f\<rightharpoonup> 'b::cpo)"
  apply (rule fmap_cont_via_lookupI)
  apply (drule fmap_below_dom[OF cont2monofunE[OF `cont f`]], simp)
  apply (case_tac "x = v")
  apply (auto simp add: assms)
  done

lemma fdom_adm[intro]: "adm (\<lambda> a. P (fdom a))"
  by (rule admI, metis chain_fdom(2))

lemma fdom_adm_eq[simp]:
   "adm (\<lambda>\<rho>. fdom \<rho> = z)"
   by (rule fdom_adm)

lemma  fun_merge_belowI:
  assumes "fdom x \<union> fdom y = fdom z"
  and "\<And> a. a \<in> fdom y \<Longrightarrow> y f! a \<sqsubseteq> z f! a"
  and "\<And> a. a \<in> fdom x \<Longrightarrow> a \<notin> fdom y \<Longrightarrow> x f! a \<sqsubseteq> z f! a"
  shows  "x f++ y \<sqsubseteq> z"
  using assms
  apply -
  apply (rule fmap_belowI)
  apply auto[1]
  by (metis fdomIff lookup_fun_merge1 lookup_fun_merge2)

lemma fun_merge_cont1: "cont (\<lambda> x. x f++ m::('a::type f\<rightharpoonup> 'b::cpo))"
  apply (rule fmap_cont_via_lookupI)
  apply (drule fmap_below_dom, simp)
  apply (case_tac "x \<in> fdom m")
  apply (auto simp add: assms)
  done

lemma fun_merge_cont2: "cont (\<lambda> x. m f++ x::('a::type f\<rightharpoonup> 'b::cpo))"
  apply (rule fmap_cont_via_lookupI)
  apply (drule fmap_below_dom, simp)
  apply (subst lookup_fun_merge_eq)
  apply (rule cont_if_fdom)
  apply simp_all
  done

lemma fun_merge_cont2cont[simp, cont2cont]:
  assumes "cont f"
  assumes "cont g"
  shows "cont (\<lambda> x. f x f++ (g x :: 'a f\<rightharpoonup> 'b::cpo))"
by (rule cont_apply[OF assms(1) fun_merge_cont1 cont_compose[OF fun_merge_cont2 assms(2)]])

lemma fun_merge_mono:
  assumes "x1 \<sqsubseteq> (x2 :: ('a::type f\<rightharpoonup> 'b::cpo))"
  assumes "y1 \<sqsubseteq> y2"
  shows "x1 f++ y1 \<sqsubseteq> x2 f++ y2"
by (rule below_trans[OF cont2monofunE[OF fun_merge_cont1 assms(1)] cont2monofunE[OF fun_merge_cont2 assms(2)]])

lemma fmap_upd_belowI:
  assumes "fdom \<rho>' = insert x (fdom \<rho>)"
  assumes "\<And> z . z \<in> fdom \<rho> \<Longrightarrow> z \<noteq> x \<Longrightarrow> \<rho> f! z \<sqsubseteq> \<rho>' f! z"
  assumes "y \<sqsubseteq> \<rho>' f! x"
  shows  "\<rho>(x f\<mapsto> y) \<sqsubseteq> \<rho>'"
  apply (rule fmap_belowI)
  using assms apply simp
  using assms
  apply (case_tac "xa = x")
  apply auto
  done

lemma fmap_upd_below_fmap_deleteI:
  assumes "fdom \<rho>' = insert x (fdom \<rho>)"
  assumes "\<rho> \<sqsubseteq> fmap_delete x \<rho>'"
  assumes "y \<sqsubseteq> \<rho>' f! x"
  shows  "\<rho>(x f\<mapsto> y) \<sqsubseteq> \<rho>'"
  by (rule fmap_upd_belowI[OF assms(1) below_trans[OF fmap_belowE[OF assms(2)] eq_imp_below] assms(3)], simp)

lemma fmap_upd_belowI2:
  assumes "fdom \<rho> = insert x (fdom \<rho>')"
  assumes "\<And> z . z \<in> fdom \<rho> \<Longrightarrow> z \<noteq> x \<Longrightarrow> \<rho> f! z \<sqsubseteq> \<rho>' f! z"
  assumes "\<rho> f! x \<sqsubseteq> y"
  shows  "\<rho> \<sqsubseteq> \<rho>'(x f\<mapsto> y)"
  apply (rule fmap_belowI)
  using assms apply simp
  using assms
  apply (case_tac "xa = x")
  apply auto
  done

lemma fmap_restr_belowI:
  assumes  "\<And> x. x \<in> S \<Longrightarrow> (fmap_restr S m1) f! x \<sqsubseteq> (fmap_restr S m2) f! x"
  and "fdom m1 = fdom m2"
  shows "fmap_restr S m1 \<sqsubseteq> fmap_restr S m2"
  apply (rule fmap_belowI)
  apply (simp add: `fdom m1 = fdom m2`)
  by (metis Int_iff assms(1) fdom_fmap_restr)

lemma fmap_restr_cont:  "cont (fmap_restr S)"
  apply (rule fmap_cont_via_lookupI)
  apply (drule fmap_below_dom, simp)
  apply (case_tac "x \<in> S")
  apply (auto simp add: assms)
  done

lemma fmap_restr_fdom_cont'[simp, cont2cont]:
  assumes "cont f"
  assumes "cont g"
  shows "cont (\<lambda> x. fmap_restr (S (fdom (f x))) (g x))"
  apply (rule fmap_cont_via_lookupI)
  apply (frule fmap_below_dom[OF cont2monofunE[OF `cont f`]])
  apply (frule fmap_below_dom[OF cont2monofunE[OF `cont g`]])
  apply simp
  apply (subst lookup_fmap_restr_eq)
  apply (rule cont_if_fdom)
  apply (simp_all add: assms)
  done

lemmas fmap_restr_cont2cont[simp,cont2cont] = cont_compose[OF fmap_restr_cont]

lemma adm_less_fmap [simp]:
  "[|cont (\<lambda>x. u x); cont (\<lambda>x. v x)|] ==> adm (\<lambda>x. u x \<le> ((v x)::'a::type f\<rightharpoonup> 'b::pcpo))"
  apply (subst fmap_less_restrict)
  apply (intro adm_lemmas, assumption+)
  apply (rule contI)
  apply (subst chain_fdom(1)[OF ch2ch_cont[of u]], assumption+)
  apply (subst cont2contlubE[of u], assumption+)
  apply (subst chain_fdom(2)[OF ch2ch_cont[of u]], assumption+)
  apply (rule contE)
  apply auto
  done

lemma fmap_lift_rel_adm:
  assumes "adm (\<lambda> x. P (fst x) (snd x))"
  shows "adm (\<lambda> m. fmap_lift_rel P (fst m) (snd m))"
proof (rule admI)
  case (goal1 Y)
    have "fdom (fst (Y 0)) = fdom (snd (Y 0))" using goal1(2) by auto
    hence "fdom (fst (\<Squnion> i. Y i)) = fdom (snd (\<Squnion> i. Y i))"
     by (metis cont2contlubE[OF cont_fst `chain Y`]  chain_fdom(2)[OF ch2ch_fst[OF `chain Y`]]
               cont2contlubE[OF cont_snd `chain Y`]  chain_fdom(2)[OF ch2ch_snd[OF `chain Y`]])
    thus ?case
    apply (rule fmap_lift_relI)
    apply (rule admD[OF adm_subst[where t = "\<lambda>p . (fst p f! x, snd p f! x)", standard, OF _ assms, simplified] `chain Y`])
    apply (rule fmap_lift_rel.cases[OF spec[OF goal1(2)]])
    by (metis below_fmap_def fmap_lift_rel.cases fst_monofun goal1(1) goal1(2) is_ub_thelub)
qed

subsubsection {* Lookup defaulting to bottom *}

lift_definition fmap_lookup_bot :: "'a f\<rightharpoonup> 'b::pcpo \<Rightarrow> 'a \<Rightarrow> 'b"  (infix "f!\<^sub>\<bottom>" 55) is "\<lambda> m k. case m k of Some v \<Rightarrow> v | Nothing \<Rightarrow> \<bottom>"..

lemma fmap_lookup_bot_simps[simp]:
  "x \<in> fdom m \<Longrightarrow> m f!\<^sub>\<bottom> x = m f! x"
  "lookup m x = Some e \<Longrightarrow> m f!\<^sub>\<bottom> x = m f! x"
  "x \<notin> fdom m \<Longrightarrow> m f!\<^sub>\<bottom> x = \<bottom>"
  by (transfer, auto simp add: dom_def)+

lemma fmap_lookup_bot_eq:
  "m f!\<^sub>\<bottom> x = (if x \<in> fdom m then m f! x else \<bottom>)"
  by (transfer, auto simp add: dom_def)

lemma fmap_lookup_bot_fmap_upd_other[simp]: "x' \<noteq> x \<Longrightarrow> h(x f\<mapsto> v) f!\<^sub>\<bottom> x' = h f!\<^sub>\<bottom> x'"
  by (transfer, auto)

lemma fmap_lookup_bot_fmap_upd_eq: "h (x f\<mapsto> v) f!\<^sub>\<bottom>  x' = (if x = x' then v else h f!\<^sub>\<bottom> x')"
  by (transfer, auto)

lemma fmap_lookup_bot_fmap_delete_other[simp]: "x' \<noteq> x \<Longrightarrow> (fmap_delete x h) f!\<^sub>\<bottom> x' = h f!\<^sub>\<bottom> x'"
  by (transfer, auto)

lemma fmap_lookup_bot_fun_merge_other[simp]: "x \<notin> fdom \<rho>' \<Longrightarrow> (\<rho> f++ \<rho>') f!\<^sub>\<bottom> x = \<rho> f!\<^sub>\<bottom> x"
  by (transfer, auto split:option.split)

lemma fmap_lookup_bot_fmap_restr[simp]: "x \<in> S \<Longrightarrow> m f|` S f!\<^sub>\<bottom> x = m f!\<^sub>\<bottom> x"
  by (transfer, auto)

lemma fmap_lookup_bot_restr_not_there[simp]: "x \<notin> S \<Longrightarrow> m f|` S f!\<^sub>\<bottom> x = \<bottom>"
  by (transfer, auto)

lemma fmap_lookup_bot_fmap_restr_eq: "m f|` S f!\<^sub>\<bottom> x = (if x \<in> S then m f!\<^sub>\<bottom> x else \<bottom>)"
  by (transfer, auto)

lemma cont2cont_fmap_lookup_bot[simp,cont2cont]:
  fixes f :: "'a::cpo \<Rightarrow> 'b::type f\<rightharpoonup> 'c::pcpo"
  assumes "cont f"
  shows "cont (\<lambda>p. (f p) f!\<^sub>\<bottom> x)"
  apply (subst fmap_lookup_bot_eq)
  apply (rule cont_if_fdom)
  apply (simp_all add: assms)
  done

lemma adm_fmap_lookup_bot[simp, intro]: "adm f \<Longrightarrow> adm (\<lambda> \<rho>. f (\<rho> f!\<^sub>\<bottom> x))"
  by (erule adm_subst[OF cont2cont_fmap_lookup_bot[OF cont_id]])

lemma fmap_lookup_bot_cont:
  "cont (op f!\<^sub>\<bottom>)"
  by (rule cont2cont_lambda[OF cont2cont_fmap_lookup_bot[OF cont_id]])

subsubsection {* Expanding the domain of finite maps *}

lift_definition fmap_expand :: "'a f\<rightharpoonup> 'b::pcpo \<Rightarrow> 'a set  \<Rightarrow> 'a f\<rightharpoonup> 'b" ("_\<^bsub>[_]\<^esub>" [90, 60] 90)
  is "\<lambda> m1 S. (if finite S then (\<lambda> x. if x \<in> S then Some (case m1 x of (Some x) => x | None => \<bottom>) else None) else empty)"
  apply (case_tac "finite set")
  apply (rule_tac B = "dom fun \<union> set" in   finite_subset)
  apply auto
  done

lemma fmap_expand_nonfinite:
  "\<not> finite S \<Longrightarrow> m\<^bsub>[S]\<^esub> = f\<emptyset>"
  by (transfer, simp)

lemma fmap_restr_fmap_expand:
  "finite d2 \<Longrightarrow> fmap_restr d1 (m\<^bsub>[d2]\<^esub>) = fmap_restr d1 (m\<^bsub>[d1 \<inter> d2]\<^esub>)"
  by transfer (auto simp add: restrict_map_def)

lemma fmap_restr_fmap_expand2:
  "finite d2 \<Longrightarrow> d1 \<subseteq> d2 \<Longrightarrow> fmap_restr d1 (m\<^bsub>[d2]\<^esub>) = m\<^bsub>[d1]\<^esub>"
  apply(cases "finite d1")
  apply transfer
  apply (auto simp add: restrict_map_def split:option.split)
  apply (metis set_mp)
  by (metis rev_finite_subset)

lemma fdom_fmap_expand[simp]:
  "finite S \<Longrightarrow> fdom (m\<^bsub>[S]\<^esub>) = S"
  by (transfer, auto split:if_splits)

lemma fmap_expand_noop[simp]:
  "S = fdom \<rho> \<Longrightarrow> \<rho>\<^bsub>[S]\<^esub> = \<rho>"
  by (transfer, auto split: option.split)

lemma fmap_expand_idem:
  "finite S2 \<Longrightarrow> fdom \<rho> \<subseteq> S1 \<Longrightarrow> S1 \<subseteq> S2 \<Longrightarrow> (\<rho>\<^bsub>[S1]\<^esub>)\<^bsub>[S2]\<^esub> = \<rho>\<^bsub>[S2]\<^esub>"
  apply (transfer)
  apply (auto split:option.split simp add: split_if_eq1 split_if_eq2)
  apply (rule ext)
  apply (auto split:option.split simp add: split_if_eq1 split_if_eq2)
  by (metis finite_subset)

lemma lookup_fmap_expand1[simp]:
  "finite S \<Longrightarrow> x \<in> S \<Longrightarrow> x \<in> fdom m \<Longrightarrow> lookup (m\<^bsub>[S]\<^esub>) x = lookup m x"
  by (transfer, auto)

lemma lookup_fmap_expand2[simp]:
  "finite S \<Longrightarrow> x \<in> S \<Longrightarrow> x \<notin> fdom m \<Longrightarrow> lookup (m\<^bsub>[S]\<^esub>) x = Some \<bottom>"
  by (transfer, auto split:option.split)

lemma lookup_fmap_expand3[simp]:
  "finite S \<Longrightarrow> x \<notin> S \<Longrightarrow> lookup (m\<^bsub>[S]\<^esub>) x = None"
 by (transfer, auto split:option.split)

lemma lookup_fmap_expand_eq:
  "finite S \<Longrightarrow> lookup (m\<^bsub>[S]\<^esub>) x = (if x \<in> S then Some (m f!\<^sub>\<bottom> x) else None)"
 by (transfer, auto split:option.split)

lemma fmap_lookup_bot_fmap_expand_eq:
  "finite S \<Longrightarrow> m\<^bsub>[S]\<^esub> f!\<^sub>\<bottom> x = (if x \<in> S then m f!\<^sub>\<bottom> x else  \<bottom>)"
 by (transfer, auto)

lemma fmap_lookup_bot_fmap_expand1[simp]:
  "finite S \<Longrightarrow> x \<notin> fdom m \<Longrightarrow>  m\<^bsub>[S]\<^esub> f!\<^sub>\<bottom> x = \<bottom>"
 by (transfer, auto)

lemma fmap_lookup_bot_fmap_expand2[simp]:
  "finite S \<Longrightarrow> x \<in> S \<Longrightarrow>  m\<^bsub>[S]\<^esub> f!\<^sub>\<bottom> x = m f!\<^sub>\<bottom> x"
 by (transfer, auto)

lemma fmap_lookup_bot_fmap_expand3[simp]:
  "finite S \<Longrightarrow> fdom m \<subseteq> S \<Longrightarrow>  m\<^bsub>[S]\<^esub> f!\<^sub>\<bottom> x = m f!\<^sub>\<bottom> x"
 by (cases "x \<in> fdom m", auto)

lemma fmap_expand_fdom[simp]: "\<rho>\<^bsub>[fdom \<rho>]\<^esub> = \<rho>"
  by (transfer, auto split:option.split)

lemma the_lookup_bot_fmap_expand_subset:
  "finite S \<Longrightarrow> fdom \<rho> \<subseteq> S \<Longrightarrow> op f!\<^sub>\<bottom> (\<rho>\<^bsub>[S]\<^esub>) = op f!\<^sub>\<bottom> \<rho>"
by (rule) auto

lemma fmap_expand_belowI:
  assumes "fdom \<rho>' = S"
  assumes "\<And> x. x \<in> fdom \<rho> \<Longrightarrow> x \<in> S \<Longrightarrow> \<rho> f! x \<sqsubseteq> \<rho>' f! x"
  shows "\<rho>\<^bsub>[S]\<^esub> \<sqsubseteq> \<rho>'"
  apply (rule fmap_belowI)
  apply (metis assms(1) fdom_fmap_expand finite_fdom)
  apply (case_tac "x \<in> fdom \<rho>")
  apply (metis assms(1) assms(2) finite_fdom lookup_fmap_expand1)
  apply (metis assms(1) finite_fdom lookup_fmap_expand2 minimal the.simps)
  done

lemma fmap_expand_fmap_restr_below:
  assumes [simp]:"fdom x = S2"
  shows "(fmap_restr S1 x)\<^bsub>[S2]\<^esub> \<sqsubseteq> x"
  by (rule fmap_expand_belowI[OF assms(1)])
     (auto simp add: lookup_fmap_restr_eq)

lemma fmap_expand_cont:
  "cont (\<lambda> m. m\<^bsub>[S]\<^esub>)"
  apply (cases "finite S")
  apply (rule fmap_cont_via_lookupI)
  apply (drule fmap_below_dom, simp)
  find_theorems fmap_expand lookup
  apply (subst lookup_fmap_expand_eq, assumption)
  apply (rule cont_if_fdom[OF _ _ cont_id])
  apply simp_all[2]
  apply (subst fmap_expand_nonfinite, assumption)
  apply simp
  done

lemmas cont2cont_fmap_expand[simp, cont2cont] = cont_compose[OF fmap_expand_cont]

lemma fmap_upd_expand:
  "finite S \<Longrightarrow>
   x \<in> S \<Longrightarrow>
   \<rho>(x f\<mapsto> y)\<^bsub>[S]\<^esub> = (\<rho>\<^bsub>[S - {x}]\<^esub>)(x f\<mapsto> y)"
   apply (rule fmap_eqI, auto)
   apply (case_tac "xa \<in> fdom (\<rho>(x f\<mapsto> y))", auto)
   apply (case_tac "xa = x", auto)
   done

lemma less_fmap_expand:
  "finite S \<Longrightarrow> fdom \<rho> \<subseteq> S \<Longrightarrow> \<rho> \<le> \<rho>\<^bsub>[S]\<^esub>"
  unfolding less_eq_fmap_def by auto

lemma fmap_expand_less:
  "finite S \<Longrightarrow> S \<subseteq> fdom \<rho> \<Longrightarrow> \<rho>\<^bsub>[S]\<^esub> \<le> \<rho>"
  unfolding less_eq_fmap_def by auto

subsubsection {* Bottoms *}

lemma fmap_bottom_below[simp]:
  "S = fdom \<rho> \<Longrightarrow> f\<emptyset>\<^bsub>[S]\<^esub> \<sqsubseteq> \<rho>"
 by(rule fmap_belowI, auto)

lemma fmap_bottom_below_iff[iff]:
  "finite S \<Longrightarrow> f\<emptyset>\<^bsub>[S]\<^esub> \<sqsubseteq> \<rho> \<longleftrightarrow> fdom \<rho> = S"
  by (metis fdom_fmap_expand fmap_below_dom fmap_bottom_below)

lemma fmap_bottom_inj[iff]: "finite x \<Longrightarrow> finite y \<Longrightarrow> f\<emptyset>\<^bsub>[x]\<^esub> = f\<emptyset>\<^bsub>[y]\<^esub> \<longleftrightarrow> x = y"
  by (metis below.r_refl fmap_bottom_below_iff)

lemma fmap_expand_fmap_bottom[simp]: "f\<emptyset>\<^bsub>[S']\<^esub>\<^bsub>[S]\<^esub> = f\<emptyset>\<^bsub>[S]\<^esub>"
  by (transfer, auto)

lemma fmap_restr_fmap_bottom[simp]:
  "finite S \<Longrightarrow> finite S2 \<Longrightarrow> fmap_restr S (f\<emptyset>\<^bsub>[S2]\<^esub>) = f\<emptyset>\<^bsub>[S \<inter> S2]\<^esub>"
  by auto

lemma fmap_bottom_insert:
  "finite S \<Longrightarrow>
  f\<emptyset>\<^bsub>[insert x S]\<^esub> = (f\<emptyset>\<^bsub>[S]\<^esub>)(x f\<mapsto> \<bottom>)"
  apply (rule fmap_eqI)
  apply auto[1]
  apply (case_tac "xa = x", auto)
  done

lemma fmap_bottom_less[simp]:
  "finite S2 \<Longrightarrow> S1 \<subseteq> S2 \<Longrightarrow> f\<emptyset>\<^bsub>[S1]\<^esub> \<le> f\<emptyset>\<^bsub>[S2]\<^esub>"
  apply (subgoal_tac "finite S1")
  apply (rule fmap_less_eqI)
  apply simp
  apply simp
  by (rule rev_finite_subset)

subsubsection {* A setup for defining a fixed point of finite maps iteratively *}

lemma fdom_fix_on:
  assumes "fix_on_cond S b F"
  shows  "fdom (fix_on' b F) = fdom b"
proof-
  have "fix_on' b F \<in> S"
    by (rule fix_on_there[OF assms])
  hence "b \<sqsubseteq> fix_on' b F"
    by (metis assms bottom_of_subpcpo_bot_minimal fix_on_cond.simps subpcpo_is_subpcpo_bot)
  thus ?thesis
    by (metis fmap_below_dom)
qed

locale iterative =
  fixes \<rho> :: "'a::type f\<rightharpoonup> 'b::pcpo"
   and e1 :: "'a f\<rightharpoonup> 'b \<Rightarrow> 'a f\<rightharpoonup> 'b"
   and e2 :: "'a f\<rightharpoonup> 'b \<Rightarrow> 'b"
   and S :: "'a set" and x :: 'a
   and D
  defines "D \<equiv> insert x (fdom \<rho> \<union> S)"
  assumes cont_e1 [simp]:"cont e1"
  assumes cont_e2 [simp]:"cont e2"
  assumes dom[simp]: "\<And> \<rho>. fdom (e1 \<rho>) = S"
  assumes ne:"x \<notin> S"

sublocale iterative < subpcpo "{x. f\<emptyset>\<^bsub>[D]\<^esub> \<sqsubseteq> x}" by (rule subpcpo_cone_above)

context iterative
begin

  abbreviation "cpo == {x. f\<emptyset>\<^bsub>[D]\<^esub> \<sqsubseteq> x}"
  abbreviation "b == f\<emptyset>\<^bsub>[D]\<^esub>"

  abbreviation "L == (\<lambda> \<rho>'. (\<rho> f++ e1 \<rho>')(x f\<mapsto> e2 \<rho>'))"
  abbreviation "H == (\<lambda> \<rho>' \<rho>''. \<rho>' f++ e1 \<rho>'')"
  abbreviation "R == (\<lambda> \<rho>'. (\<rho> f++ fmap_restr S (fix_on' b (H \<rho>')))(x f\<mapsto> e2 \<rho>'))"
  abbreviation "R' == (\<lambda> \<rho>'. (\<rho> f++ fmap_restr S (fix_on' b (H \<rho>')))(x f\<mapsto> e2 (fix_on' b (H \<rho>'))))"

  lemma condL: "fix_on_cond cpo b L"
    apply (rule fix_on_condI)
    apply (rule subpcpo_cone_above)
    apply (rule bottom_of_cone_above)
    apply (rule closed_onI)
      apply (simp add: D_def)
    apply (rule cont_is_cont_on)
      apply simp
    done
  lemmas [simp] = fdom_fix_on[OF condL]

  lemma condH: "\<And> \<rho>'. \<rho>' \<in> cpo \<Longrightarrow> fix_on_cond cpo b (H \<rho>')"
    apply (rule fix_on_condI)
    apply (rule subpcpo_cone_above)
    apply (rule bottom_of_cone_above)
    apply (rule closed_onI)
      apply (auto simp add: D_def)[1]
    apply (rule cont_is_cont_on)
      apply simp
    done
  lemmas [simp] = fdom_fix_on[OF condH]

  lemma condR: "fix_on_cond cpo b R"
    apply (rule fix_on_condI)
    apply (rule subpcpo_cone_above)
    apply (rule bottom_of_cone_above)
    apply (rule closed_onI)
      using fdom_fix_on[OF condH]  apply (auto simp add: D_def)[1]
    apply (rule cont_comp_cont_on2[OF cont2cont_lambda[OF fmap_upd_cont[OF cont_id cont_const]]
                fmap_upd_cont[OF cont_const cont_id]
                _
                cont_is_cont_on[OF cont_e2]])
    apply (rule cont_comp_cont_on2[OF cont2cont_lambda[OF fun_merge_cont1]
                fun_merge_cont2
                cont_is_cont_on[OF cont_const]
                ])
    apply (rule cont_comp_cont_on[OF fmap_restr_cont])
    apply (rule cont_onI2)
      apply (rule monofun_onI)
      apply (erule (1) fix_on_mono[OF condH condH])
      apply (erule cont2monofunE[OF fun_merge_cont1])

    apply (rule eq_imp_below)
    apply (rule fix_on_cont[OF chain_on_is_chain condH[OF chain_on_is_on]])
      apply assumption
      apply assumption
    apply (rule cont2cont_lambda[OF fun_merge_cont1])
    done
  lemmas [simp] = fdom_fix_on[OF condR]

  lemma cont_on_fix_H: "cont_on (\<lambda> \<rho>'. fix_on' b (H \<rho>'))"
    apply (rule cont_onI2)
      apply (rule monofun_onI)
      apply (erule (1) fix_on_mono[OF condH condH])
      apply (erule cont2monofunE[OF fun_merge_cont1])

    apply (rule eq_imp_below)
    apply (rule fix_on_cont[OF chain_on_is_chain condH[OF chain_on_is_on]])
      apply assumption
      apply assumption
    apply (rule cont2cont_lambda[OF fun_merge_cont1])
    done

  lemma condR': "fix_on_cond cpo b R'"
    apply (rule fix_on_condI)
    apply (rule subpcpo_cone_above)
    apply (rule bottom_of_cone_above)
    apply (rule closed_onI)
      using fdom_fix_on[OF condH]  apply (auto simp add: D_def)[1]
    apply (rule cont_comp_cont_on2[OF cont2cont_lambda[OF fmap_upd_cont[OF cont_id cont_const]]
                fmap_upd_cont[OF cont_const cont_id]
                _
                cont_comp_cont_on[OF cont_e2 cont_on_fix_H]])
    apply (rule cont_comp_cont_on2[OF cont2cont_lambda[OF fun_merge_cont1]
                fun_merge_cont2
                cont_is_cont_on[OF cont_const]
                ])
    apply (rule cont_comp_cont_on[OF fmap_restr_cont cont_on_fix_H])
    done
  lemmas [simp] = fdom_fix_on[OF condR']

  lemmas fix_eq_R = fix_on_eq[OF condR]
  lemmas fix_eq_R' = fix_on_eq[OF condR']
  lemmas fix_eq_L = fix_on_eq[OF condL]
  lemmas fix_eq_HL = fix_on_eq[OF condH[OF fix_on_there[OF condL]]]
  lemmas fix_eq_HR = fix_on_eq[OF condH[OF fix_on_there[OF condR]]]
  lemmas fix_eq_HR' = fix_on_eq[OF condH[OF fix_on_there[OF condR']]]

  lemma [simp]: "D \<inter> S = S"
      by (auto simp add: D_def)

  lemma HR_not_S[simp]: "\<And> x. x \<notin> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b R))) x = lookup (fix_on' b R) x"
      apply (subst fix_eq_HR) by simp

  lemma HR_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b R))) y = lookup (e1 (fix_on' b (H (fix_on' b R)))) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst fix_eq_HR)
    apply simp
    using ne by metis

  lemma L_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b L) y = lookup (e1 (fix_on' b L)) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst (1) fix_eq_L)
    apply simp
    using ne by metis

  lemma L_x2[simp]: "(fix_on' b L) f! x = e2 (fix_on' b L)"
    by (subst (1) fix_eq_L, simp)

  lemma L_not_S_x2[simp]: "\<And> y. y \<notin> S \<Longrightarrow> y \<noteq> x \<Longrightarrow> lookup (fix_on' b L) y = lookup \<rho> y"
    by (subst (1) fix_eq_L, simp)

  lemma R_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b R) y = lookup (e1 (fix_on' b (H (fix_on' b R)))) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst fix_eq_R)
    apply simp
    using ne by metis

  lemma R_x2[simp]: "(fix_on' b R) f! x = e2 (fix_on' b R)"
    by (subst fix_eq_R, simp)

  lemma R_not_S[simp]: "\<And> y. y \<notin> S \<Longrightarrow> y \<noteq> x \<Longrightarrow> lookup (fix_on' b R) y = lookup \<rho> y"
    by (subst fix_eq_R, simp)

  lemma HR_is_R[simp]: "fix_on' b (H (fix_on' b R)) = fix_on' b R"
    apply (rule fmap_eqI)
    apply simp
    apply (case_tac "xa \<in> S")
    apply simp_all
    done

  lemma HL_not_S[simp]: "\<And> x. x \<notin> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b L))) x = lookup (fix_on' b L) x"
    apply (subst fix_eq_HL) by simp

  lemma HR'_not_S[simp]: "\<And> x. x \<notin> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b R'))) x = lookup (fix_on' b R') x"
    apply (subst fix_eq_HR') by simp

  lemma HR'_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b R'))) y = lookup (e1 (fix_on' b (H (fix_on' b R')))) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst fix_eq_HR')
    apply simp
    using ne by metis

  lemma HL_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b (H (fix_on' b L))) y = lookup (e1 (fix_on' b (H (fix_on' b L)))) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst fix_eq_HL)
    apply simp
    using ne by metis

  lemma R'_S[simp]: "\<And> y. y \<in> S \<Longrightarrow> lookup (fix_on' b R') y = lookup (e1 (fix_on' b (H (fix_on' b R')))) y"
    apply (subgoal_tac "y \<noteq> x")
    apply (subst fix_eq_R')
    apply simp
    using ne by metis

  lemma R'_x2[simp]: "(fix_on' b R') f! x = e2 (fix_on' b (H (fix_on' b R')))"
    by (subst fix_eq_R', simp)

  lemma R'_not_S[simp]: "\<And> y. y \<notin> S \<Longrightarrow> y \<noteq> x \<Longrightarrow> lookup (fix_on' b R') y = lookup \<rho> y"
    by (subst fix_eq_R', simp)

  lemma HR'_is_R'[simp]: "fix_on' b (H (fix_on' b R')) = fix_on' b R'"
    apply (rule fmap_eqI)
    apply simp
    apply (case_tac "xa \<in> S")
    apply simp_all
    done

  lemma H_noop:
    fixes \<rho>' \<rho>''
    assumes there: "(\<rho>' :: 'a f\<rightharpoonup> 'b) \<in> cpo"
    assumes "\<And> x. x \<in> S \<Longrightarrow> (e1 \<rho>'') f! x \<sqsubseteq> \<rho>' f! x"
    shows "H \<rho>' \<rho>'' \<sqsubseteq> \<rho>'"
      using assms
      apply -
      apply (rule fmap_belowI)
      using there apply (auto simp add: D_def)[1]
      apply (case_tac "x \<in> fdom (e1 \<rho>')")
      apply simp
      apply simp
      done

  lemma HL_is_L[simp]: "fix_on' b (H (fix_on' b L)) = fix_on' b L"
  proof (rule below_antisym)
    show "fix_on' b (H (fix_on' b L)) \<sqsubseteq> fix_on' b L"
      apply (rule fix_on_least_below[OF condH[OF fix_on_there[OF condL]] fix_on_there[OF condL]])
      apply (rule H_noop[OF fix_on_there[OF condL]])
      apply simp
    done

    show "fix_on' b L \<sqsubseteq> fix_on' b (H (fix_on' b L))"
    apply (rule fix_on_least_below[OF condL fix_on_there[OF condH[OF fix_on_there[OF condL]]]])
    apply (rule fmap_upd_belowI)
    apply simp apply (auto simp add: D_def)[1]
    apply (case_tac "z \<in> S")
    apply simp
    apply simp
    apply (simp add: ne)
    apply (rule cont2monofunE[OF cont_e2])
    apply fact
    done
  qed

  lemma iterative_fun_merge:
    shows "fix_on' b L = fix_on' b R"
  proof(rule below_antisym)
    show "fix_on' b R \<sqsubseteq> fix_on' b L"
    proof (rule fix_on_least_below[OF condR])
      show "fix_on' b L \<in> cpo"
        by simp
      show "R (fix_on' b L) \<sqsubseteq> fix_on' b L"
      proof(rule fmap_upd_belowI)
        case goal1 show ?case by (simp, auto simp add: D_def)
        show "e2 (fix_on' b L) \<sqsubseteq> (fix_on' b L) f! x"
          by simp
        case (goal2 y)
        thus "\<rho> f++ fmap_restr S (fix_on' b (H (fix_on' b L))) f! y \<sqsubseteq> (fix_on' b L) f! y"
          by(cases "y \<in> S", simp_all)
      qed
    qed

    show "fix_on' b L \<sqsubseteq> fix_on' b R"
    proof (rule fix_on_least_below[OF condL])
      show "fix_on' b R \<in> cpo"
        by simp
      show "L (fix_on' b R) \<sqsubseteq> fix_on' b R"
        apply (rule  fmap_upd_belowI)
        apply simp apply (auto simp add: D_def)[1]
        apply (case_tac "z \<notin> S")
        apply simp_all
      done
    qed
  qed

  lemma iterative_fun_merge':
    shows "fix_on' b L = fix_on' b R'"
  proof(rule below_antisym)
    show "fix_on' b R' \<sqsubseteq> fix_on' b L"
    proof (rule fix_on_least_below[OF condR'])
      show "fix_on' b L \<in> cpo"
        by simp
      show "R' (fix_on' b L) \<sqsubseteq> fix_on' b L"
      proof(rule fmap_upd_belowI)
        case goal1 show ?case by (simp, auto simp add: D_def)
        show "e2 (fix_on' b (H (fix_on' b L))) \<sqsubseteq> (fix_on' b L) f! x"
          by simp
        case (goal2 y)
          thus "\<rho> f++ fmap_restr S (fix_on' b (H (fix_on' b L))) f! y \<sqsubseteq> fix_on' b L f! y"
            by (cases "y \<in> S", simp_all)
      qed
    qed

    show "fix_on' b L \<sqsubseteq> fix_on' b R'"
    proof (rule fix_on_least_below[OF condL])
      show "fix_on' b R' \<in> cpo"
        by simp
      show "L (fix_on' b R') \<sqsubseteq> fix_on' b R'"
        apply (rule  fmap_upd_belowI)
        apply simp apply (auto simp add: D_def)[1]
        apply (case_tac "z \<notin> S")
        apply simp_all
      done
    qed
  qed
end

subsubsection {* Finite maps can be partitioned in pcpo's *}

instantiation fmap :: (type, pcpo) subpcpo_partition
begin
  definition "to_bot x = f\<emptyset>\<^bsub>[fdom x]\<^esub>"
  lemma [simp]:"fdom (to_bot x) = fdom x"
    unfolding to_bot_fmap_def by auto

  lemma to_bot_vimage_cone:"to_bot -` {to_bot x} = {z. f\<emptyset>\<^bsub>[fdom x]\<^esub> \<sqsubseteq> z}"
    by (auto simp add:to_bot_fmap_def)

  instance
  apply default
  apply (subst to_bot_vimage_cone)
  apply (rule subpcpo_cone_above)
  apply (simp add: to_bot_fmap_def fmap_below_dom)
  apply (simp add: to_bot_fmap_def)
  done
end

subsection {* Mapping *}

lemma fmap_map_lookup[simp]: "v \<in> fdom \<rho> \<Longrightarrow> fmap_map f \<rho> f! v = f (\<rho> f! v)"
  apply auto
  by (metis fdomIff option.exhaust option_map_Some the.simps)

lemma fmap_map_lookup_not_there[simp]: "v \<notin> fdom \<rho> \<Longrightarrow> lookup (fmap_map f \<rho>) v = None"
  apply auto
  by (metis fdomIff)

lemma fmap_map_lookup_eq: "fmap_map f \<rho> f! v = (if v \<in> fdom \<rho> then f (\<rho> f! v) else the None)"
  by (simp del: lookup_fmap_map)

lemma fmap_map_lookup_bot[simp]: "f \<bottom> = \<bottom> \<Longrightarrow> fmap_map f \<rho> f!\<^sub>\<bottom> v = f (\<rho> f!\<^sub>\<bottom> v)"
  apply (cases "v \<in> fdom \<rho>")
  apply auto
  by (metis fdomIff option.exhaust option_map_Some the.simps)

lemma cont2cont_fmap_map [simp, cont2cont]:
  assumes "cont f"
  assumes "\<And> x. cont (f x)"
  assumes "cont g"
  shows "cont (\<lambda> x. fmap_map (f x) (g x))"
  apply (rule fmap_cont_via_lookupI)
  apply (drule fmap_below_dom[OF cont2monofunE[OF `cont g`]], simp)
  apply (simp del: lookup_fmap_map add: fmap_map_lookup_eq)
  apply (intro cont2cont cont_if_fdom `cont g` `cont f` cont_compose2[OF assms(1,2)])
  done

definition fmap_cmap :: "('a::cpo \<rightarrow> 'b::cpo) \<rightarrow> 'c::type f\<rightharpoonup> 'a \<rightarrow> 'c::type f\<rightharpoonup> 'b"
  where  "fmap_cmap = (\<Lambda> f \<rho>. fmap_map (\<lambda> x. f\<cdot>x) \<rho>)"

lemma [simp]: "fdom (fmap_cmap\<cdot>f\<cdot>\<rho>) = fdom \<rho>"
  unfolding fmap_cmap_def by simp

lemma [simp]: "fmap_cmap\<cdot>f\<cdot>(\<rho>(x f\<mapsto> v)) = fmap_cmap\<cdot>f\<cdot>\<rho>(x f\<mapsto> f\<cdot>v)"
  unfolding fmap_cmap_def by simp

lemma [simp]: "x \<in> fdom \<rho> \<Longrightarrow> fmap_cmap\<cdot>f\<cdot>\<rho> f! x = f\<cdot>(\<rho> f! x )"
  unfolding fmap_cmap_def by (simp del: lookup_fmap_map)

lemma [simp]: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> fmap_cmap\<cdot>f\<cdot>\<rho> f!\<^sub>\<bottom> x = f\<cdot>(\<rho> f!\<^sub>\<bottom> x )"
  unfolding fmap_cmap_def by (simp del: lookup_fmap_map)

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

subsection {* Invariant 2 *}

text {*
  The second invariant is split into three main conjuncts called
  $Inv2a$, $Inv2b$, and $Inv2c$. The main difficulty is in proving
  the preservation of the first conjunct.
*}

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

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

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

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

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

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

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

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

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

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

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

subsubsection {* Proofs of Invariant 2 a *}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

subsubsection {* Proofs of Invariant 2 b *}

text{*
Invariant 2b is proved automatically, given that
we expand the definitions involved.
*}

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

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

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

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

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

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

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

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

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

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

subsubsection {* Proofs of Invariant 2 c *}

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

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

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

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

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

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

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

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

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

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

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

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

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

text{* $HInv1 \wedge HInv2$ is an invariant of $HNext$. *}

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

end