(*section {* Verification Component Based on Bi-Semigroups *}*)

theory R_Semigroup
  imports H_Semigroup

begin

class R_monoid = H_monoid +
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes star_iso: "x \<preceq> y \<Longrightarrow> x\<^sup>\<star> \<preceq> y\<^sup>\<star>"
  and R1: "H p (R p q) q"
  and R2: "H p x q \<Longrightarrow> x \<preceq> R p q"

begin

lemma R_skip: "p \<preceq> q \<Longrightarrow> 1 \<preceq> R p q"
  by (simp add: H_def R2)

lemma R_cons: "p \<preceq> p' \<Longrightarrow> q' \<preceq> q \<Longrightarrow> R p' q' \<preceq> R p q"
  using H_cons R1 R2 by blast

lemma R_seq: "(R p r) \<cdot> (R r q) \<preceq> R p q"
  using H_seq R1 R2 by blast

lemma R_loop: "H p q (p \<cdot> q) \<Longrightarrow> H p r (p \<cdot> r) \<Longrightarrow> (q \<cdot> R (p \<cdot> q) p)\<^sup>\<star> \<cdot> r \<preceq> R p (p \<cdot> r)"
  by (simp add: H_loopi R1 R2 preo_refl)

lemma R_cond:
assumes "\<And>x y. p \<cdot> (x + y) \<preceq> p \<cdot> x + p \<cdot> y" and "\<And>x y. x \<cdot> q + y \<cdot> q \<preceq> (x + y) \<cdot> q"
shows "H p v (p \<cdot> v) \<Longrightarrow> H p w (p \<cdot> w) \<Longrightarrow> v \<cdot> R (p \<cdot> v) q + w \<cdot> R (p \<cdot> w) q \<preceq> R p q"
  by (simp add: assms H_cond R1 R2)

end

definition "rel_R P Q = \<Union>{X. rel_hm.H P X Q}"

interpretation rel_rm: R_monoid Id "op ;" "op \<union>" "op \<subseteq>" rtrancl rel_R
  by (standard, auto simp: rtrancl_mono rel_R_def rel_hm.H_def, blast)

lemma R_assign: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (simp add: H_assign rel_rm.R2)

lemma R_assignr: "(\<forall>s. Q' s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (rel_R \<lceil>P\<rceil> \<lceil>Q'\<rceil>) ; (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (metis H_assign rel_hm.H_seq rel_rm.R1 rel_rm.R2)

lemma R_assignl: "(\<forall>s. P s \<longrightarrow> P' (s (v := e s))) \<Longrightarrow> (v ::= e) ; (rel_R \<lceil>P'\<rceil> \<lceil>Q\<rceil>) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (metis H_assign rel_hm.H_seq rel_rm.R1 rel_rm.R2)

lemma if_then_else_ref: "X \<subseteq> X' \<Longrightarrow> Y \<subseteq> Y' \<Longrightarrow> if P then X else Y fi \<subseteq> if P then X' else Y' fi"
  by (auto simp: if_then_else_def)

lemma while_ref: "X \<subseteq> X' \<Longrightarrow> (while P do X od) \<subseteq> (while P do X' od)"
  by (simp add: while_def rel_hm.mult_isol rel_hm.mult_isor rel_rm.star_iso)

lemma euclid1: "rel_R \<lceil>\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y\<rceil> \<lceil>\<lambda>s. s ''x'' = gcd x y\<rceil>
   \<supseteq> rel_R \<lceil>\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y\<rceil> \<lceil>\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y \<and> \<not> s ''y'' \<noteq> 0\<rceil>"
  by (intro rel_rm.R_cons, auto simp: p2r_def)

abbreviation "P x y \<equiv> \<lceil>\<lambda>s::nat store. gcd (s ''x'') (s ''y'') = gcd x y \<and> s ''y'' \<noteq> 0\<rceil>"

lemma euclid2: "rel_R \<lceil>\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y\<rceil> \<lceil>\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y \<and> \<not> s ''y'' \<noteq> 0\<rceil>
    \<supseteq> while (\<lambda>s. s ''y'' \<noteq> 0) do rel_R (P x y) \<lceil>\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y\<rceil> od"
  apply (simp only: while_def p2r_mult_hom[symmetric]) by (intro rel_rm.R_loop, auto simp: p2r_def rel_hm.H_def)

lemma euclid3: "rel_R (P x y) \<lceil>\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y\<rceil>
    \<supseteq> rel_R (P x y) \<lceil>\<lambda>s. gcd (s ''z'') (s ''y'') = gcd x y\<rceil> ; (''x'' ::= (\<lambda>s. s ''z''))"
  by (intro R_assignr, simp)

lemma euclid4: "rel_R (P x y) \<lceil>\<lambda>s. gcd (s ''z'') (s ''y'') = gcd x y\<rceil>
    \<supseteq> rel_R (P x y) \<lceil>\<lambda>s. gcd (s ''z'') (s ''x'' mod s ''y'') = gcd x y\<rceil> ; (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''))"
  by (intro R_assignr, simp)

lemma euclid5: "rel_R (P x y) \<lceil>\<lambda>s. gcd (s ''z'') (s ''x'' mod s ''y'') = gcd x y\<rceil>
    \<supseteq> (''z'' ::= (\<lambda>s. s ''y''))"
  by (intro R_assign, auto simp: gcd_non_0_nat)

lemma euclid_ref: "rel_R \<lceil>\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y\<rceil> \<lceil>\<lambda>s. s ''x'' = gcd x y\<rceil>
    \<supseteq>
  while (\<lambda>s. s ''y'' \<noteq> 0)
    do
      (''z'' ::= (\<lambda>s. s ''y''));
      (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
      (''x'' ::= (\<lambda>s. s ''z''))
    od"
  apply (rule dual_order.trans, subst euclid1, simp, rule dual_order.trans, subst euclid2, simp)
  apply (intro while_ref) using euclid3 euclid4 euclid5 by fast

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
 * Contributions by:
 *   2012 Lars Noschinski <noschinl@in.tum.de>
 *     Option monad while loop formalisation.
 *)

theory OptionMonad (* FIXME: this is really a Reader_Option_Monad *)
  imports
    "../Lib" (* FIXME: reduce dependencies *)
    "Less_Monad_Syntax"
begin

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

text \<open>Similar to map_option but the second function returns option as well\<close>
definition
  opt_map :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> ('s,'b) lookup" (infixl "|>" 54)
where
  "f |> g \<equiv> \<lambda>s. case f s of None \<Rightarrow> None | Some x \<Rightarrow> g x"

abbreviation opt_map_Some :: "('s \<rightharpoonup> 'a) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 's \<rightharpoonup> 'b" (infixl "||>" 54) where
  "f ||> g \<equiv> f |> (Some \<circ> g)"
lemmas opt_map_Some_def = opt_map_def

lemma opt_map_cong [fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s. f s = Some v \<Longrightarrow> g v = g' v\<rbrakk> \<Longrightarrow> f |> g = f' |> g'"
  by (rule ext) (simp add: opt_map_def split: option.splits)

lemma in_opt_map_eq:
  "((f |> g) s = Some v) = (\<exists>v'. f s = Some v' \<and> g v' = Some v)"
  by (simp add: opt_map_def split: option.splits)

lemma opt_mapE:
  "\<lbrakk> (f |> g) s = Some v; \<And>v'. \<lbrakk>f s = Some v'; g v' = Some v \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (auto simp: in_opt_map_eq)

lemma opt_map_upd_None:
  "f(x := None) |> g = (f |> g)(x := None)"
  by (auto simp: opt_map_def)

lemma opt_map_upd_Some:
  "f(x \<mapsto> v) |> g = (f |> g)(x := g v)"
  by (auto simp: opt_map_def)

lemmas opt_map_upd[simp] = opt_map_upd_None opt_map_upd_Some

declare None_upd_eq[simp]

(* None_upd_eq[simp] so that this pattern is by simp. Hopefully not too much slowdown. *)
lemma "\<lbrakk> (f |> g) x = None; g v = None \<rbrakk> \<Longrightarrow> f(x \<mapsto> v) |> g = f |> g"
  by simp

definition
  obind :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> ('s,'b) lookup) \<Rightarrow> ('s,'b) lookup" (infixl "|>>" 53)
where
  "f |>> g \<equiv> \<lambda>s. case f s of None \<Rightarrow> None | Some x \<Rightarrow> g x s"

(* Enable "do { .. }" syntax *)
adhoc_overloading
  Monad_Syntax.bind obind

definition
  "ofail = K None"

definition
  "oreturn = K o Some"

definition
  "oassert P \<equiv> if P then oreturn () else ofail"

definition oapply :: "'a \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> 'b option"
  where
  "oapply x \<equiv> \<lambda>s. s x"

text \<open>
  If the result can be an exception.
  Corresponding bindE would be analogous to lifting in NonDetMonad.
\<close>

definition
  "oreturnOk x = K (Some (Inr x))"

definition
  "othrow e = K (Some (Inl e))"

definition
  "oguard G \<equiv> (\<lambda>s. if G s then Some () else None)"

definition
  "ocondition c L R \<equiv> (\<lambda>s. if c s then L s else R s)"

definition
  "oskip \<equiv> oreturn ()"

text \<open>Monad laws\<close>
lemma oreturn_bind [simp]: "(oreturn x |>> f) = f x"
  by (auto simp add: oreturn_def obind_def K_def)

lemma obind_return [simp]: "(m |>> oreturn) = m"
  by (auto simp add: oreturn_def obind_def K_def split: option.splits)

lemma obind_assoc:
  "(m |>> f) |>> g  =  m |>> (\<lambda>x. f x |>> g)"
  by (auto simp add: oreturn_def obind_def K_def split: option.splits)

text \<open>Binding fail\<close>

lemma obind_fail [simp]:
  "f |>> (\<lambda>_. ofail) = ofail"
  by (auto simp add: ofail_def obind_def K_def split: option.splits)

lemma ofail_bind [simp]:
  "ofail |>> m = ofail"
  by (auto simp add: ofail_def obind_def K_def split: option.splits)

text \<open>Function package setup\<close>
lemma opt_bind_cong [fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s. f' s = Some v \<Longrightarrow> g v s = g' v s \<rbrakk> \<Longrightarrow> f |>> g = f' |>> g'"
  by (rule ext) (simp add: obind_def split: option.splits)

lemma opt_bind_cong_apply [fundef_cong]:
  "\<lbrakk> f s = f' s; \<And>v. f' s = Some v \<Longrightarrow> g v s = g' v s \<rbrakk> \<Longrightarrow> (f |>> g) s = (f' |>> g') s"
  by (simp add: obind_def split: option.splits)

lemma oassert_bind_cong [fundef_cong]:
  "\<lbrakk> P = P'; P' \<Longrightarrow> m = m' \<rbrakk> \<Longrightarrow> oassert P |>> m = oassert P' |>> m'"
  by (auto simp: oassert_def)

lemma oassert_bind_cong_apply [fundef_cong]:
  "\<lbrakk> P = P'; P' \<Longrightarrow> m () s = m' () s \<rbrakk> \<Longrightarrow> (oassert P |>> m) s = (oassert P' |>> m') s"
  by (auto simp: oassert_def)

lemma oreturn_bind_cong [fundef_cong]:
  "\<lbrakk> x = x'; m x' = m' x' \<rbrakk> \<Longrightarrow> oreturn x |>> m = oreturn x' |>> m'"
  by simp

lemma oreturn_bind_cong_apply [fundef_cong]:
  "\<lbrakk> x = x'; m x' s = m' x' s \<rbrakk> \<Longrightarrow> (oreturn x |>> m) s = (oreturn x' |>> m') s"
  by simp

lemma oreturn_bind_cong2 [fundef_cong]:
  "\<lbrakk> x = x'; m x' = m' x' \<rbrakk> \<Longrightarrow> (oreturn $ x) |>> m = (oreturn $ x') |>> m'"
  by simp

lemma oreturn_bind_cong2_apply [fundef_cong]:
  "\<lbrakk> x = x'; m x' s = m' x' s \<rbrakk> \<Longrightarrow> ((oreturn $ x) |>> m) s = ((oreturn $ x') |>> m') s"
  by simp

lemma ocondition_cong [fundef_cong]:
"\<lbrakk>c = c'; \<And>s. c' s \<Longrightarrow> l s = l' s; \<And>s. \<not>c' s \<Longrightarrow> r s = r' s\<rbrakk>
  \<Longrightarrow> ocondition c l r = ocondition c' l' r'"
  by (auto simp: ocondition_def)

text \<open>Decomposition\<close>

lemma ocondition_K_true [simp]:
  "ocondition (\<lambda>_. True) T F = T"
  by (simp add: ocondition_def)

lemma ocondition_K_false [simp]:
  "ocondition (\<lambda>_. False) T F = F"
  by (simp add: ocondition_def)

lemma ocondition_False:
    "\<lbrakk> \<And>s. \<not> P s \<rbrakk> \<Longrightarrow> ocondition P L R = R"
  by (rule ext, clarsimp simp: ocondition_def)

lemma ocondition_True:
    "\<lbrakk> \<And>s. P s \<rbrakk> \<Longrightarrow> ocondition P L R = L"
  by (rule ext, clarsimp simp: ocondition_def)

lemma in_oreturn [simp]:
  "(oreturn x s = Some v) = (v = x)"
  by (auto simp: oreturn_def K_def)

lemma oreturnE:
  "\<lbrakk>oreturn x s = Some v; v = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemma in_ofail [simp]:
  "ofail s \<noteq> Some v"
  by (auto simp: ofail_def K_def)

lemma ofailE:
  "ofail s = Some v \<Longrightarrow> P"
  by simp

lemma in_oassert_eq [simp]:
  "(oassert P s = Some v) = P"
  by (simp add: oassert_def)

lemma oassert_True [simp]:
  "oassert True = oreturn ()"
  by (simp add: oassert_def)

lemma oassert_False [simp]:
  "oassert False = ofail"
  by (simp add: oassert_def)

lemma oassertE:
  "\<lbrakk> oassert P s = Some v; P \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by simp

lemma in_obind_eq:
  "((f |>> g) s = Some v) = (\<exists>v'. f s = Some v' \<and> g v' s = Some v)"
  by (simp add: obind_def split: option.splits)

lemma obind_eqI:
  "\<lbrakk> f s = f s' ; \<And>x. f s = Some x \<Longrightarrow> g x s = g' x s' \<rbrakk> \<Longrightarrow> obind f g s = obind f g' s'"
  by (simp add: obind_def split: option.splits)

(* full form of obind_eqI; the second equality makes more sense flipped here, as we end up
   with "f s = Some x ; f s' = f s" preventing "Some x = ..." *)
lemma obind_eqI_full:
  "\<lbrakk> f s = f s' ; \<And>x. \<lbrakk> f s = Some x; f s' = f s \<rbrakk> \<Longrightarrow> g x s = g' x s' \<rbrakk>
   \<Longrightarrow> obind f g s = obind f g' s'"
  by (drule sym[where s="f s"]) (* prevent looping *)
     (clarsimp simp: obind_def split: option.splits)

lemma obindE:
  "\<lbrakk> (f |>> g) s = Some v;
     \<And>v'. \<lbrakk>f s = Some v'; g v' s = Some v\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (auto simp: in_obind_eq)

lemma in_othrow_eq [simp]:
  "(othrow e s = Some v) = (v = Inl e)"
  by (auto simp: othrow_def K_def)

lemma othrowE:
  "\<lbrakk>othrow e s = Some v; v = Inl e \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemma in_oreturnOk_eq [simp]:
  "(oreturnOk x s = Some v) = (v = Inr x)"
  by (auto simp: oreturnOk_def K_def)

lemma oreturnOkE:
  "\<lbrakk>oreturnOk x s = Some v; v = Inr x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemmas omonadE [elim!] =
  opt_mapE obindE oreturnE ofailE othrowE oreturnOkE oassertE

lemma in_opt_map_Some_eq:
  "((f ||> g) x = Some y) = (\<exists>v. f x = Some v \<and> g v = y)"
  by (simp add: in_opt_map_eq)

lemma in_opt_map_None_eq[simp]:
  "((f ||> g) x = None) = (f x = None)"
  by (simp add: opt_map_def split: option.splits)

lemma oreturn_comp[simp]:
  "oreturn x \<circ> f = oreturn x"
  by (simp add: oreturn_def K_def o_def)

lemma ofail_comp[simp]:
  "ofail \<circ> f = ofail"
  by (auto simp: ofail_def K_def)

lemma oassert_comp[simp]:
  "oassert P \<circ> f = oassert P"
  by (simp add: oassert_def)

lemma fail_apply[simp]:
  "ofail s = None"
  by (simp add: ofail_def K_def)

lemma oassert_apply[simp]:
  "oassert P s = (if P then Some () else None)"
  by (simp add: oassert_def)

lemma oreturn_apply[simp]:
  "oreturn x s = Some x"
  by simp

lemma oapply_apply[simp]:
  "oapply x s = s x"
  by (simp add: oapply_def)

lemma obind_comp_dist:
  "obind f g o h = obind (f o h) (\<lambda>x. g x o h)"
  by (auto simp: obind_def split: option.splits)

lemma if_comp_dist:
  "(if P then f else g) o h = (if P then f o h else g o h)"
  by auto

section \<open>"While" loops over option monad.\<close>

text \<open>
  This is an inductive definition of a while loop over the plain option monad
  (without passing through a state)
\<close>

inductive_set
  option_while' :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a option) \<Rightarrow> 'a option rel"
  for C B
where
    final: "\<not> C r \<Longrightarrow> (Some r, Some r) \<in> option_while' C B"
  | fail: "\<lbrakk> C r; B r = None \<rbrakk> \<Longrightarrow> (Some r, None) \<in> option_while' C B"
  | step: "\<lbrakk> C r;  B r = Some r'; (Some r', sr'') \<in> option_while' C B \<rbrakk>
           \<Longrightarrow> (Some r, sr'') \<in> option_while' C B"

definition
  "option_while C B r \<equiv>
    (if (\<exists>s. (Some r, s) \<in> option_while' C B) then
      (THE s. (Some r, s) \<in> option_while' C B) else None)"

lemma option_while'_inj:
  assumes "(s,s') \<in> option_while' C B" "(s, s'') \<in> option_while' C B"
  shows "s' = s''"
  using assms by (induct rule: option_while'.induct) (auto elim: option_while'.cases)

lemma option_while'_THE:
  assumes "(Some r, sr') \<in> option_while' C B"
  shows "(THE s. (Some r, s) \<in> option_while' C B) = sr'"
  using assms by (blast dest: option_while'_inj)

lemma option_while_simps:
  "\<not> C s \<Longrightarrow> option_while C B s = Some s"
  "C s \<Longrightarrow> B s = None \<Longrightarrow> option_while C B s = None"
  "C s \<Longrightarrow> B s = Some s' \<Longrightarrow> option_while C B s = option_while C B s'"
  "(Some s, ss') \<in> option_while' C B \<Longrightarrow> option_while C B s = ss'"
  using option_while'_inj_step[of C s B s']
  by (auto simp: option_while_def option_while'_THE
      intro: option_while'.intros
      dest: option_while'_inj
      elim: option_while'.cases)

lemma option_while_rule:
  assumes "option_while C B s = Some s'"
  assumes "I s"
  assumes istep: "\<And>s s'. C s \<Longrightarrow> I s \<Longrightarrow> B s = Some s' \<Longrightarrow> I s'"
  shows "I s' \<and> \<not> C s'"
proof -
  { fix ss ss' assume "(ss, ss') \<in> option_while' C B" "ss = Some s" "ss' = Some s'"
    then have ?thesis using \<open>I s\<close>
      by (induct arbitrary: s) (auto intro: istep) }
  then show ?thesis using assms(1)
    by (auto simp: option_while_def option_while'_THE split: if_split_asm)
qed

lemma option_while'_term:
  assumes "I r"
  assumes "wf M"
  assumes step_less: "\<And>r r'. \<lbrakk>I r; C r; B r = Some r'\<rbrakk> \<Longrightarrow> (r',r) \<in> M"
  assumes step_I: "\<And>r r'. \<lbrakk>I r; C r; B r = Some r'\<rbrakk> \<Longrightarrow> I r'"
  obtains sr' where "(Some r, sr') \<in> option_while' C B"
  apply atomize_elim
  using assms(2,1)
proof induct
  case (less r)
  show ?case
  proof (cases "C r" "B r" rule: bool.exhaust[case_product option.exhaust])
    case (True_Some r')
    then have "(r',r) \<in> M" "I r'"
      by (auto intro: less step_less step_I)
    then obtain sr' where "(Some r', sr') \<in> option_while' C B"
      by atomize_elim (rule less)
    then have "(Some r, sr') \<in> option_while' C B"
      using True_Some by (auto intro: option_while'.intros)
    then show ?thesis ..
  qed (auto intro: option_while'.intros)
qed

lemma option_while_rule':
  assumes "option_while C B s = ss'"
  assumes "wf M"
  assumes "I (Some s)"
  assumes less: "\<And>s s'. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = Some s' \<Longrightarrow> (s', s) \<in> M"
  assumes step: "\<And>s s'. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = Some s' \<Longrightarrow> I (Some s')"
  assumes final: "\<And>s. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = None \<Longrightarrow> I None"
  shows "I ss' \<and> (case ss' of Some s' \<Rightarrow> \<not> C s' | _ \<Rightarrow> True)"
proof -
  define ss where "ss \<equiv> Some s"
  obtain ss1' where "(Some s, ss1') \<in> option_while' C B"
    using assms(3,2,4,5) by (rule option_while'_term)
  then have *: "(ss, ss') \<in> option_while' C B" using \<open>option_while C B s = ss'\<close>
    by (auto simp: option_while_simps ss_def)
  show ?thesis
  proof (cases ss')
    case (Some s') with * ss_def show ?thesis using \<open>I _\<close>
      by (induct arbitrary:s) (auto intro: step)
  next
    case None with * ss_def show ?thesis using \<open>I _\<close>
      by (induct arbitrary:s) (auto intro: step final)
  qed
qed

section \<open>Lift @{term option_while} to the @{typ "('a,'s) lookup"} monad\<close>

definition
  owhile :: "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('s,'a) lookup) \<Rightarrow> 'a \<Rightarrow> ('s,'a) lookup"
where
 "owhile c b a \<equiv> \<lambda>s. option_while (\<lambda>a. c a s) (\<lambda>a. b a s) a"

lemma owhile_unroll:
  "owhile C B r = ocondition (C r) (B r |>> owhile C B) (oreturn r)"
  by (auto simp: ocondition_def obind_def oreturn_def owhile_def
           option_while_simps K_def split: option.split)

text \<open>rule for terminating loops\<close>

lemma owhile_rule:
  assumes "I r s"
  assumes "wf M"
  assumes less: "\<And>r r'. \<lbrakk>I r s; C r s; B r s = Some r'\<rbrakk> \<Longrightarrow> (r',r) \<in> M"
  assumes step: "\<And>r r'. \<lbrakk>I r s; C r s; B r s = Some r'\<rbrakk> \<Longrightarrow> I r' s"
  assumes fail: "\<And>r. \<lbrakk>I r s; C r s; B r s = None\<rbrakk> \<Longrightarrow> Q None"
  assumes final: "\<And>r. \<lbrakk>I r s; \<not>C r s\<rbrakk> \<Longrightarrow> Q (Some r)"
  shows "Q (owhile C B r s)"
proof -
  let ?rs' = "owhile C B r s"
  have "(case ?rs' of Some r \<Rightarrow> I r s | _ \<Rightarrow> Q None)
      \<and> (case ?rs' of Some r' \<Rightarrow> \<not> C r' s | _ \<Rightarrow> True)"
    by (rule option_while_rule'[where B="\<lambda>r. B r s" and s=r, OF _ \<open>wf _\<close>])
       (auto simp: owhile_def intro: assms)
  then show ?thesis by (auto intro: final split: option.split_asm)
qed

end


theory SimpleFMI
  imports
    "UTP-Time.utp_time_rel"
    "UTP-Hybrid.utp_hybrid"
begin

purge_notation Sublist.parallel (infixl "\<parallel>" 50)

record '\<alpha> fmu =
  fmiInstantiate :: "'\<alpha> hrel"
  fmiDoStep      :: "'\<alpha> trel"

text {* A Master Algorithm is a set of possible time steps the FMI network can make at a given
  instant. *}

type_synonym master_algorithm = "real pos set"

definition fmu_single ("FMU[_, _]") where
[upred_defs]: "fmu_single a fmu =
  \<lparr> fmiInstantiate = a:[fmiInstantiate fmu]\<^sup>+
  , fmiDoStep      = a:[fmiDoStep fmu]\<^sub>r\<^sup>+ \<rparr>"

definition fmu_comp :: "'\<alpha> trel \<Rightarrow> '\<alpha> trel \<Rightarrow> '\<alpha> trel" (infixr "\<parallel>" 85) where
[upred_defs]: "fmu_comp P Q = (P \<and> Q)"

definition TimeConstraint :: "(real pos) set \<Rightarrow> (real pos, 'a) hrel_rp" where
[upred_defs]: "TimeConstraint T = R1(&tt \<in>\<^sub>u \<guillemotleft>T\<guillemotright>)"

lemma TimeConstraint_RR [closure]: "TimeConstraint(T) is RR"
  by (rel_auto)

abbreviation Instantiate_FMUs :: "'\<alpha> fmu list \<Rightarrow> '\<alpha> trel"
where "Instantiate_FMUs FMUs \<equiv> [foldr (;;) (map fmiInstantiate FMUs) II]\<^sub>S"

text {* We make the assumption that the FMUs operate on separate state spaces and thus the order
  of execution is irrelevant. *}

definition Step :: "real pos \<Rightarrow> '\<alpha> fmu \<Rightarrow> '\<alpha> trel" where
[upred_defs]: "Step t FMU = ((fmiDoStep FMU \<and> $time\<acute> >\<^sub>u $time)\<lbrakk>\<guillemotleft>t\<guillemotright>/&tt\<rbrakk> \<and> $time\<acute> =\<^sub>u $time)"

lemma Step_RR_lemma:
  assumes "P is RR"
  shows "((P \<and> $time\<acute> >\<^sub>u $time)\<lbrakk>\<guillemotleft>t\<guillemotright>/&tt\<rbrakk> \<and> $time\<acute> =\<^sub>u $time) is RR"
proof -
  have "((RR P \<and> $time\<acute> >\<^sub>u $time)\<lbrakk>\<guillemotleft>t\<guillemotright>/&tt\<rbrakk> \<and> $time\<acute> =\<^sub>u $time) is RR"
    by (rel_auto)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma Step_RR [closure]: "fmiDoStep FMU is RR \<Longrightarrow> Step t FMU is RR"
  by (simp add: Step_def Step_RR_lemma)

lemma Step_fmu_single [simp]: "Step t (FMU[a, P]) = a:[Step t P]\<^sub>r\<^sup>+"
  by (simp add: Step_def fmu_single_def, rel_auto)

definition Step_FMUs :: "'\<alpha> fmu list \<Rightarrow> master_algorithm \<Rightarrow> '\<alpha> trel"
  where "Step_FMUs FMUs MA = (\<Sqinter> t\<in>MA \<bullet> (;; f : FMUs \<bullet> Step t f) ;; wait\<^sub>r(\<guillemotleft>t\<guillemotright>))"

lemma Step_FMUs_RR_closed [closure]:
  assumes "MA \<noteq> {}" "FMUs \<noteq> []" "\<And> f. f\<in>set(map fmiDoStep FMUs) \<Longrightarrow> f is RR"
  shows "Step_FMUs FMUs MA is RR"
  by (simp add: Step_FMUs_def closure assms)

definition FMI :: "('\<alpha> \<Rightarrow> '\<alpha>) \<Rightarrow> '\<alpha> fmu list \<Rightarrow> master_algorithm \<Rightarrow> ('\<alpha> \<Rightarrow> '\<alpha>) \<Rightarrow> '\<alpha> trel" where
[upred_defs]: "FMI Init FMUs MA Wiring =
                 Instantiate_FMUs FMUs ;;
                 \<langle>Init\<rangle>\<^sub>r ;;
                 (\<langle>Wiring\<rangle>\<^sub>r ;; Step_FMUs FMUs MA)\<^sup>\<star>\<^sup>r"

lemma FMI_hoare_rp [hoare_safe]:
  assumes
    "\<lbrace>true\<rbrace> Instantiate_FMUs FMUs ;; \<langle>Init\<rangle>\<^sub>r \<lbrace>I\<rbrace>\<^sub>r"
    "\<lbrace>I\<rbrace> \<langle>Wiring\<rangle>\<^sub>r ;; Step_FMUs FMUs MA \<lbrace>I\<rbrace>\<^sub>r"
  shows "\<lbrace>true\<rbrace>FMI Init FMUs MA Wiring\<lbrace>I\<rbrace>\<^sub>r"
proof -
  have 1:"FMI Init FMUs MA Wiring =
          (Instantiate_FMUs FMUs ;; \<langle>Init\<rangle>\<^sub>r) ;;
          (\<langle>Wiring\<rangle>\<^sub>r ;; Step_FMUs FMUs MA)\<^sup>\<star>\<^sup>r"
    by (simp add: FMI_def, simp add: seqr_assoc)
  show ?thesis
    by (simp add: 1 hoare_safe assms)
qed

definition ArbStep :: "master_algorithm" where
[upred_defs]: "ArbStep = UNIV"

definition FixedStep :: "real pos \<Rightarrow> master_algorithm" where
[upred_defs]: "FixedStep t = {t}"

named_theorems step_simps

method fmi_hoare_split uses defs =
  (rule FMI_hoare_rp,
   simp_all add:step_simps Step_FMUs_def FixedStep_def HyStep_cond HyStep_hEvolves' closure continuous_intros defs,
   simp_all add: frame alpha usubst unrest rpred closure);
   ((uexpr_simp simps:pos_transfer rpred));
   (simp add: rpred closure unrest usubst cond_st_distr)?

method fmi_hoare uses defs =
  fmi_hoare_split defs: defs ; hoare_auto

lemma fmi_instantiatiate_FMU [simp]:
  "fmiInstantiate(FMU[a, P]) = a:[fmiInstantiate P]\<^sup>+"
  by (simp add: fmu_single_def)

(*
lemma fmu_hoare_rp [hoare_safe]:
  "\<lbrakk> x \<natural> p; \<lbrace>p\<restriction>\<^sub>px\<rbrace>Q\<lbrace>p\<restriction>\<^sub>px\<rbrace>\<^sub>r \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>FMU[x, Q]\<lbrace>p\<rbrace>\<^sub>r"
  apply (rel_simp, auto simp add: des_vars.defs rp_vars.defs)
  apply (rename_tac ok wait tr st ok' wait' tr' st')
  apply (drule_tac x="ok" in spec)
  apply (drule_tac x="wait" in spec)
  apply (drule_tac x="tr" in spec)
  apply (drule_tac x="get\<^bsub>x\<^esub> st" in spec)
  apply (drule_tac x="ok'" in spec)
  apply (drule_tac x="wait'" in spec)
  apply (drule_tac x="tr'" in spec)
  apply (drule_tac x="get\<^bsub>x\<^esub> st'" in spec)
  apply (auto)
done

lemma fmi_hoare_rp:
  assumes "\<lbrace>true\<rbrace>\<langle>Init\<rangle>\<^sub>r ;; \<langle>Wiring\<rangle>\<^sub>r\<lbrace>p\<rbrace>\<^sub>r" "\<And> fmu. fmu \<in> set(FMUs) \<Longrightarrow> \<lbrace>p\<rbrace>\<langle>Wiring\<rangle>\<^sub>r ;; fmu\<lbrace>p\<rbrace>\<^sub>r"
  shows "\<lbrace>true\<rbrace>FMI Init FMUs MA Wiring\<lbrace>p\<rbrace>\<^sub>r"
oops
*)

definition Modelica_FMU :: "(unit, '\<alpha>::t2_space) hyrel \<Rightarrow> '\<alpha> fmu" where
[upred_defs]: "Modelica_FMU P = \<lparr> fmiInstantiate = II, fmiDoStep = H2T(P) \<rparr>"

lemma fmiInstantiate_Modelica_FMU [simp]: "fmiInstantiate (Modelica_FMU hr) = II"
  by (simp add: Modelica_FMU_def)

lemma fmiDoStep_Modelica_FMU [simp]: "fmiDoStep (Modelica_FMU hr) = H2T(hr)"
  by (simp add: Modelica_FMU_def)

lemma Step_Modelica_lemma:
  "t > 0 \<Longrightarrow> (((\<Sqinter> t \<bullet> wait\<^sub>r \<guillemotleft>t\<guillemotright> ;; [P]\<^sub>S) \<and> $time <\<^sub>u $time\<acute>)\<lbrakk>\<guillemotleft>t\<guillemotright>/&tt\<rbrakk> \<and> $time\<acute> =\<^sub>u $time) = [P]\<^sub>S"
  by (rel_auto)

lemma Step_Modelica_FMU [step_simps]:
  "Step t (Modelica_FMU P) = (false \<triangleleft> \<guillemotleft>t = 0\<guillemotright> \<triangleright>\<^sub>R [HyStep[t](P)]\<^sub>S)"
  apply (cases "t > 0")
  apply (simp add: Step_def hyrel2trel_alt_def)
  apply (rel_auto)
  apply (subgoal_tac "t = 0")
  apply (simp, unliteralise, simp add: Step_def rpred, rel_auto)
  using neq_zero_impl_greater apply blast
done

end


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

chapter \<open>Implementation of bit operations on int by target language operations\<close>

theory Code_Target_Bits_Int
imports
  Bits_Integer
  "HOL-Library.Code_Target_Int"
begin

declare [[code drop:
  "(AND) :: int \<Rightarrow> _" "(OR) :: int \<Rightarrow> _" "(XOR) :: int \<Rightarrow> _" "(NOT) :: int \<Rightarrow> _"
  "lsb :: int \<Rightarrow> _" "set_bit :: int \<Rightarrow> _" "bit :: int \<Rightarrow> _"
  "push_bit :: _ \<Rightarrow> int \<Rightarrow> _" "drop_bit :: _ \<Rightarrow> int \<Rightarrow> _"
  int_of_integer_symbolic
  ]]

declare bitval_bin_last [code_unfold]

lemma [code_unfold]:
  \<open>bit x n \<longleftrightarrow> x AND (push_bit n 1) \<noteq> 0\<close> for x :: int
  by (fact bit_iff_and_push_bit_not_eq_0)

context
includes integer.lifting
begin

lemma bit_int_code [code]:
  "bit (int_of_integer x) n = bit x n"
  by transfer simp

lemma and_int_code [code]:
  "int_of_integer i AND int_of_integer j = int_of_integer (i AND j)"
  by transfer simp

lemma or_int_code [code]:
  "int_of_integer i OR int_of_integer j = int_of_integer (i OR j)"
  by transfer simp

lemma xor_int_code [code]:
  "int_of_integer i XOR int_of_integer j = int_of_integer (i XOR j)"
  by transfer simp

lemma not_int_code [code]:
  "NOT (int_of_integer i) = int_of_integer (NOT i)"
  by transfer simp

lemma push_bit_int_code [code]:
  \<open>push_bit n (int_of_integer x) = int_of_integer (push_bit n x)\<close>
  by transfer simp

lemma drop_bit_int_code [code]:
  \<open>drop_bit n (int_of_integer x) = int_of_integer (drop_bit n x)\<close>
  by transfer simp

lemma take_bit_int_code [code]:
  \<open>take_bit n (int_of_integer x) = int_of_integer (take_bit n x)\<close>
  by transfer simp

lemma lsb_int_code [code]:
  "lsb (int_of_integer x) = lsb x"
  by transfer simp

lemma set_bit_int_code [code]:
  "set_bit (int_of_integer x) n b = int_of_integer (set_bit x n b)"
  by transfer simp

lemma int_of_integer_symbolic_code [code]:
  "int_of_integer_symbolic = int_of_integer"
  by (simp add: int_of_integer_symbolic_def)

context
begin

qualified definition even :: \<open>int \<Rightarrow> bool\<close>
  where [code_abbrev]: \<open>even = Parity.even\<close>

end

lemma bin_rest_code:
  "int_of_integer i div 2 = int_of_integer (bin_rest_integer i)"
  by transfer simp

end

end


theory SASP_Checker
imports SASP_Semantics
  "HOL-Library.Code_Target_Nat"
begin

section \<open>An Executable Checker for Multi-Valued Planning Problem Solutions\<close>

  subsection \<open>Auxiliary Lemmas\<close>
  lemma map_of_leI:
    assumes "distinct (map fst l)"
    assumes "\<And>k v. (k,v)\<in>set l \<Longrightarrow> m k = Some v"
    shows "map_of l \<subseteq>\<^sub>m m"
    using assms
    by (metis (no_types, hide_lams) domIff map_le_def map_of_SomeD not_Some_eq)

  subsection \<open>Well-formedness Check\<close>
  lemmas wf_code_thms =
      ast_problem.astDom_def ast_problem.astI_def ast_problem.astG_def ast_problem.ast\<delta>_def
      ast_problem.numVars_def ast_problem.numVals_def
      ast_problem.wf_partial_state_def ast_problem.wf_operator_def ast_problem.well_formed_def

  declare wf_code_thms[code]

  export_code ast_problem.well_formed in SML

  subsection \<open>Execution\<close>

  definition match_pre :: "ast_precond \<Rightarrow> state \<Rightarrow> bool" where
    "match_pre \<equiv> \<lambda>(x,v) s. s x = Some v"

  definition match_pres :: "ast_precond list \<Rightarrow> state \<Rightarrow> bool" where
    "match_pres pres s \<equiv> \<forall>pre\<in>set pres. match_pre pre s"

  definition match_implicit_pres :: "ast_effect list \<Rightarrow> state \<Rightarrow> bool" where
    "match_implicit_pres effs s \<equiv> \<forall>(_,x,vp,_)\<in>set effs.
      (case vp of None \<Rightarrow> True | Some v \<Rightarrow> s x = Some v)"

  definition enabled_opr' :: "ast_operator \<Rightarrow> state \<Rightarrow> bool" where
    "enabled_opr' \<equiv> \<lambda>(name,pres,effs,cost) s. match_pres pres s \<and> match_implicit_pres effs s"

  definition eff_enabled' :: "state \<Rightarrow> ast_effect \<Rightarrow> bool" where
    "eff_enabled' s \<equiv> \<lambda>(pres,_,_,_). match_pres pres s"

  definition "execute_opr' \<equiv> \<lambda>(name,_,effs,_) s.
    let effs = filter (eff_enabled' s) effs
    in fold (\<lambda>(_,x,_,v) s. s(x\<mapsto>v)) effs s
  "

  definition lookup_operator' :: "ast_problem \<Rightarrow> name \<rightharpoonup> ast_operator"
    where "lookup_operator' \<equiv> \<lambda>(D,I,G,\<delta>) name. find (\<lambda>(n,_,_,_). n=name) \<delta>"

  definition enabled' :: "ast_problem \<Rightarrow> name \<Rightarrow> state \<Rightarrow> bool" where
    "enabled' problem name s \<equiv>
      case lookup_operator' problem name of
        Some \<pi> \<Rightarrow> enabled_opr' \<pi> s
      | None \<Rightarrow> False"

  definition execute' :: "ast_problem \<Rightarrow> name \<Rightarrow> state \<Rightarrow> state" where
    "execute' problem name s \<equiv>
      case lookup_operator' problem name of
        Some \<pi> \<Rightarrow> execute_opr' \<pi> s
      | None \<Rightarrow> undefined"

  context wf_ast_problem begin

    lemma match_pres_correct:
      assumes D: "distinct (map fst pres)"
      assumes "s\<in>valid_states"
      shows "match_pres pres s \<longleftrightarrow> s\<in>subsuming_states (map_of pres)"
    proof -
      have "match_pres pres s \<longleftrightarrow> map_of pres \<subseteq>\<^sub>m s"
        unfolding match_pres_def match_pre_def
        apply (auto split: prod.splits)
        using map_le_def map_of_SomeD apply fastforce
        by (metis (full_types) D domIff map_le_def map_of_eq_Some_iff option.simps(3))

      with assms show ?thesis
        unfolding subsuming_states_def
        by auto
    qed

    lemma match_implicit_pres_correct:
      assumes D: "distinct (map (\<lambda>(_, v, _, _). v) effs)"
      assumes "s\<in>valid_states"
      shows "match_implicit_pres effs s \<longleftrightarrow> s\<in>subsuming_states (map_of (implicit_pres effs))"
    proof -
      from assms show ?thesis
        unfolding subsuming_states_def
        unfolding match_implicit_pres_def implicit_pres_def
        apply (auto
            split: prod.splits option.splits
            simp: distinct_map_filter
            intro!: map_of_leI)
        apply (force simp: distinct_map_filter split: prod.split elim: map_mp)
        done
    qed

    lemma enabled_opr'_correct:
      assumes V: "s\<in>valid_states"
      assumes "lookup_operator name = Some \<pi>"
      shows "enabled_opr' \<pi> s \<longleftrightarrow> enabled name s"
      using lookup_operator_wf[OF assms(2)] assms
      unfolding enabled_opr'_def enabled_def wf_operator_def
      by (auto
          simp: match_pres_correct[OF _ V] match_implicit_pres_correct[OF _ V]
          simp: wf_partial_state_def
          split: option.split
          )

    lemma eff_enabled'_correct:
      assumes V: "s\<in>valid_states"
      assumes "case eff of (pres,_,_,_) \<Rightarrow> wf_partial_state pres"
      shows "eff_enabled' s eff \<longleftrightarrow> eff_enabled s eff"
      using assms
      unfolding eff_enabled'_def eff_enabled_def wf_partial_state_def
      by (auto simp: match_pres_correct)

    lemma execute_opr'_correct:
      assumes V: "s\<in>valid_states"
      assumes LO: "lookup_operator name = Some \<pi>"
      shows "execute_opr' \<pi> s = execute name s"
    proof (cases \<pi>)
      case [simp]: (fields name pres effs)

      have [simp]: "filter (eff_enabled' s) effs = filter (eff_enabled s) effs"
        apply (rule filter_cong[OF refl])
        apply (rule eff_enabled'_correct[OF V])
        using lookup_operator_wf[OF LO]
        unfolding wf_operator_def by auto

      have X1: "distinct (map fst (map (\<lambda>(_, x, _, y). (x, y)) (filter (eff_enabled s) effs)))"
        using lookup_operator_wf[OF LO]
        unfolding wf_operator_def
        by (auto simp: distinct_map_filter)

      term "filter (eff_enabled s) effs"

      have [simp]:
        "fold (\<lambda>(_, x, _, v) s. s(x \<mapsto> v)) l s =
         fold (\<lambda>(k, v) m. m(k \<mapsto> v)) (map (\<lambda>(_, x, _, y). (x, y)) l) s"
        for l :: "ast_effect list"
        by (induction l arbitrary: s) auto

      show ?thesis
        unfolding execute_opr'_def execute_def using LO
        by (auto simp: map_add_map_of_fold[OF X1])
    qed

    lemma lookup_operator'_correct:
      "lookup_operator' problem name = lookup_operator name"
      unfolding lookup_operator'_def lookup_operator_def
      unfolding ast\<delta>_def
      by (auto split: prod.split)

    lemma enabled'_correct:
      assumes V: "s\<in>valid_states"
      shows "enabled' problem name s = enabled name s"
      unfolding enabled'_def
      using enabled_opr'_correct[OF V]
      by (auto split: option.splits simp: enabled_def lookup_operator'_correct)

    lemma execute'_correct:
      assumes V: "s\<in>valid_states"
      assumes "enabled name s"      (* Intentionally put this here, also we could resolve non-enabled case by reflexivity (undefined=undefined) *)
      shows "execute' problem name s = execute name s"
      unfolding execute'_def
      using execute_opr'_correct[OF V] \<open>enabled name s\<close>
      by (auto split: option.splits simp: enabled_def lookup_operator'_correct)

  end

  context ast_problem
  begin

    fun simulate_plan :: "plan \<Rightarrow> state \<rightharpoonup> state" where
      "simulate_plan [] s = Some s"
    | "simulate_plan (\<pi>#\<pi>s) s = (
        if enabled \<pi> s then
          let s' = execute \<pi> s in
          simulate_plan \<pi>s s'
        else
          None
      )"

    lemma simulate_plan_correct: "simulate_plan \<pi>s s = Some s' \<longleftrightarrow> path_to s \<pi>s s'"
      by (induction s \<pi>s s' rule: path_to.induct) auto

    definition check_plan :: "plan \<Rightarrow> bool" where
      "check_plan \<pi>s = (
        case simulate_plan \<pi>s I of
          None \<Rightarrow> False
        | Some s' \<Rightarrow> s' \<in> G)"

    lemma check_plan_correct: "check_plan \<pi>s \<longleftrightarrow> valid_plan \<pi>s"
      unfolding check_plan_def valid_plan_def
      by (auto split: option.split simp: simulate_plan_correct[symmetric])

  end

  fun simulate_plan' :: "ast_problem \<Rightarrow> plan \<Rightarrow> state \<rightharpoonup> state" where
    "simulate_plan' problem [] s = Some s"
  | "simulate_plan' problem (\<pi>#\<pi>s) s = (
      if enabled' problem \<pi> s then
        let s = execute' problem \<pi> s in
        simulate_plan' problem \<pi>s s
      else
        None
    )"

  text \<open>Avoiding duplicate lookup.\<close>
  (*[code]  *)
  lemma simulate_plan'_code[code]:
    "simulate_plan' problem [] s = Some s"
    "simulate_plan' problem (\<pi>#\<pi>s) s = (
      case lookup_operator' problem \<pi> of
        None \<Rightarrow> None
      | Some \<pi> \<Rightarrow>
          if enabled_opr' \<pi> s then
            simulate_plan' problem \<pi>s (execute_opr' \<pi> s)
          else None
    )"
    by (auto simp: enabled'_def execute'_def split: option.split)

  definition initial_state' :: "ast_problem \<Rightarrow> state" where
    "initial_state' problem \<equiv> let astI = ast_problem.astI problem in (
       \<lambda>v. if v<length astI then Some (astI!v) else None
     )"

  definition check_plan' :: "ast_problem \<Rightarrow> plan \<Rightarrow> bool" where
    "check_plan' problem \<pi>s = (
      case simulate_plan' problem \<pi>s (initial_state' problem) of
        None \<Rightarrow> False
      | Some s' \<Rightarrow> match_pres (ast_problem.astG problem) s')"

  context wf_ast_problem
  begin

    lemma simulate_plan'_correct:
      assumes "s\<in>valid_states"
      shows "simulate_plan' problem \<pi>s s = simulate_plan \<pi>s s"
      using assms
      apply (induction \<pi>s s rule: simulate_plan.induct)
      apply (auto simp: enabled'_correct execute'_correct execute_preserves_valid)
      done

    lemma simulate_plan'_correct_paper: (* For presentation in paper.
        Summarizing intermediate refinement step. *)
      assumes "s\<in>valid_states"
      shows "simulate_plan' problem \<pi>s s = Some s'
            \<longleftrightarrow> path_to s \<pi>s s'"
      using simulate_plan'_correct[OF assms] simulate_plan_correct by simp

    lemma initial_state'_correct:
      "initial_state' problem = I"
      unfolding initial_state'_def I_def by (auto simp: Let_def)

    lemma check_plan'_correct:
      "check_plan' problem \<pi>s = check_plan \<pi>s"
    proof -
      have D: "distinct (map fst astG)" using wf_goal unfolding wf_partial_state_def by auto

      have S'V: "s'\<in>valid_states" if "simulate_plan \<pi>s I = Some s'" for s'
        using that by (auto simp: simulate_plan_correct path_to_pres_valid[OF I_valid])

      show ?thesis
        unfolding check_plan'_def check_plan_def
        by (auto
            split: option.splits
            simp: initial_state'_correct simulate_plan'_correct[OF I_valid]
            simp: match_pres_correct[OF D S'V] G_def
            )
    qed

  end

  (* Overall checker *)

  definition verify_plan :: "ast_problem \<Rightarrow> plan \<Rightarrow> String.literal + unit" where
    "verify_plan problem \<pi>s = (
      if ast_problem.well_formed problem then
        if check_plan' problem \<pi>s then Inr () else Inl (STR ''Invalid plan'')
      else Inl (STR ''Problem not well formed'')
    )"

  lemma verify_plan_correct:
    "verify_plan problem \<pi>s = Inr ()
    \<longleftrightarrow> ast_problem.well_formed problem \<and> ast_problem.valid_plan problem \<pi>s"
  proof -
    {
      assume "ast_problem.well_formed problem"
      then interpret wf_ast_problem by unfold_locales

      from check_plan'_correct check_plan_correct
      have "check_plan' problem \<pi>s = valid_plan \<pi>s" by simp
    }
    then show ?thesis
      unfolding verify_plan_def
      by auto
  qed

  definition nat_opt_of_integer :: "integer \<Rightarrow> nat option" where
       "nat_opt_of_integer i = (if (i \<ge> 0) then Some (nat_of_integer i) else None)"

  (*Export functions, which includes constructors*)
  export_code verify_plan nat_of_integer integer_of_nat nat_opt_of_integer Inl Inr String.explode String.implode
    in SML
    module_name SASP_Checker_Exported
    file "code/SASP_Checker_Exported.sml"

end


(*  Title:      HOL/HOLCF/IOA/Asig.thy
    Author:     Olaf Müller, Tobias Nipkow & Konrad Slind
*)

section \<open>Action signatures\<close>

theory Asig
imports MainRLT
begin

type_synonym 'a signature = "'a set \<times> 'a set \<times> 'a set"

definition inputs :: "'action signature \<Rightarrow> 'action set"
  where asig_inputs_def: "inputs = fst"

definition outputs :: "'action signature \<Rightarrow> 'action set"
  where asig_outputs_def: "outputs = fst \<circ> snd"

definition internals :: "'action signature \<Rightarrow> 'action set"
  where asig_internals_def: "internals = snd \<circ> snd"

definition actions :: "'action signature \<Rightarrow> 'action set"
  where "actions asig = inputs asig \<union> outputs asig \<union> internals asig"

definition externals :: "'action signature \<Rightarrow> 'action set"
  where "externals asig = inputs asig \<union> outputs asig"

definition locals :: "'action signature \<Rightarrow> 'action set"
  where "locals asig = internals asig \<union> outputs asig"

definition is_asig :: "'action signature \<Rightarrow> bool"
  where "is_asig triple \<longleftrightarrow>
    inputs triple \<inter> outputs triple = {} \<and>
    outputs triple \<inter> internals triple = {} \<and>
    inputs triple \<inter> internals triple = {}"

definition mk_ext_asig :: "'action signature \<Rightarrow> 'action signature"
  where "mk_ext_asig triple = (inputs triple, outputs triple, {})"

lemmas asig_projections = asig_inputs_def asig_outputs_def asig_internals_def

lemma asig_triple_proj:
  "outputs (a, b, c) = b \<and>
   inputs (a, b, c) = a \<and>
   internals (a, b, c) = c"
  by (simp add: asig_projections)

lemma int_and_ext_is_act: "a \<notin> internals S \<Longrightarrow> a \<notin> externals S \<Longrightarrow> a \<notin> actions S"
  by (simp add: externals_def actions_def)

lemma ext_is_act: "a \<in> externals S \<Longrightarrow> a \<in> actions S"
  by (simp add: externals_def actions_def)

lemma int_is_act: "a \<in> internals S \<Longrightarrow> a \<in> actions S"
  by (simp add: asig_internals_def actions_def)

lemma inp_is_act: "a \<in> inputs S \<Longrightarrow> a \<in> actions S"
  by (simp add: asig_inputs_def actions_def)

lemma out_is_act: "a \<in> outputs S \<Longrightarrow> a \<in> actions S"
  by (simp add: asig_outputs_def actions_def)

lemma ext_and_act: "x \<in> actions S \<and> x \<in> externals S \<longleftrightarrow> x \<in> externals S"
  by (fast intro!: ext_is_act)

lemma not_ext_is_int: "is_asig S \<Longrightarrow> x \<in> actions S \<Longrightarrow> x \<notin> externals S \<longleftrightarrow> x \<in> internals S"
  by (auto simp add: actions_def is_asig_def externals_def)

lemma not_ext_is_int_or_not_act: "is_asig S \<Longrightarrow> x \<notin> externals S \<longleftrightarrow> x \<in> internals S \<or> x \<notin> actions S"
  by (auto simp add: actions_def is_asig_def externals_def)

lemma int_is_not_ext:"is_asig S \<Longrightarrow> x \<in> internals S \<Longrightarrow> x \<notin> externals S"
  by (auto simp add: externals_def actions_def is_asig_def)

end


theory Impl_List_Playground
imports "../TopoS_Impl"
begin

text{*The executbale models and the composition theory. We can build examples here*}

definition testGraph :: "string list_graph" where
  "testGraph \<equiv> \<lparr> nodesL = [''Master'', ''Slave1'', ''Slave2'', ''other1'', ''other2''],
                 edgesL = [(''Master'', ''Slave1'')] \<rparr>"

lemma "wf_list_graph testGraph" by eval

definition req1 ::"(string SecurityInvariant)" where
  "req1 \<equiv> new_configured_list_SecurityInvariant SINVAR_SecGwExt_impl.SINVAR_LIB_PolEnforcePointExtended \<lparr>
      node_properties = [''Master'' \<mapsto> PolEnforcePoint,
                         ''Slave1'' \<mapsto> DomainMember,
                         ''Slave2'' \<mapsto> DomainMember]
      \<rparr> ''req1''"

definition "req2 \<equiv> new_configured_list_SecurityInvariant SINVAR_NoRefl_impl.SINVAR_LIB_NoRefl \<lparr>
      node_properties = [''Master'' \<mapsto> Refl,
                         ''other1'' \<mapsto> Refl,
                         ''other2'' \<mapsto> Refl]
      \<rparr> ''req2''"

definition "reqs = [req1, req2]"

definition "max_network = generate_valid_topology reqs
      \<lparr>nodesL = nodesL testGraph, edgesL = List.product (nodesL testGraph) (nodesL testGraph) \<rparr>"

value "max_network"

ML{*
visualize_graph @{context} @{term "reqs"} @{term "max_network"};
*}

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_Chosen imports DiskPaxos_Inv5 begin

subsection \<open>Lemma I2f\<close>

text \<open>
  To prove the final conjunct we will use the predicate $valueChosen(v)$.
  This predicate is true if $v$ is the only possible value that can be
  chosen as output. It also asserts that, for every disk $d$ in $D$, if $q$
  has already read $disk s d p$, then it has read a block with $bal$ field
  at least $b$.
\<close>

definition valueChosen :: "state \<Rightarrow> InputsOrNi \<Rightarrow> bool"
where
  "valueChosen s v =
  (\<exists>b\<in> (UN p. Ballot p).
         maxBalInp s b v
      \<and> (\<exists>p. \<exists>D\<in>MajoritySet.(\<forall>d\<in>D.  b \<le> bal(disk s d p)
                                   \<and>(\<forall>q.(   phase s q = 1
                                          \<and> b \<le>mbal(dblock s q)
                                          \<and> hasRead s q d p
                                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br))
                             ))))"

lemma HEndPhase1_valueChosen_inp:
  assumes act: "HEndPhase1 s s' q"
  and inv2a: "Inv2a s"
  and asm1: "b \<in> (UN p. Ballot p)"
  and bk_blocksOf: "bk\<in>blocksOf s r"
  and bk: "bk\<in> blocksSeen s q"
  and b_bal: "b \<le> bal bk"
  and asm3: "maxBalInp s b v"
  and inv1: "Inv1 s"
  shows "inp(dblock s' q) = v"
proof -
  from bk_blocksOf inv2a
  have inv2a_bk: "Inv2a_innermost s r bk"
    by(auto simp add: Inv2a_def Inv2a_inner_def)
  from Ballot_nzero asm1
  have "0 < b " by auto
  with b_bal
  have "0< bal bk" by auto
  with inv2a_bk
  have "inp bk \<noteq> NotAnInput"
    by(auto simp add: Inv2a_innermost_def)
  with bk InputsOrNi
  have bk_noninit: "bk \<in> nonInitBlks s q"
    by(auto simp add: nonInitBlks_def blocksSeen_def
                      allBlocksRead_def allRdBlks_def)
  with maxBlk_in_nonInitBlks[OF this inv1] b_bal
  have maxBlk_b: "b \<le> bal (maxBlk s q)"
    by auto
  from maxBlk_in_nonInitBlks[OF bk_noninit inv1]
  have "\<exists>p d. maxBlk s q \<in> blocksSeen s p"
    by(auto simp add: nonInitBlks_def blocksSeen_def)
  hence "\<exists>p. maxBlk s q \<in> blocksOf s p"
    by(auto simp add: blocksOf_def blocksSeen_def
      allBlocksRead_def allRdBlks_def rdBy_def, force)
  with maxBlk_b asm3
  have "inp(maxBlk s q) = v"
    by(auto simp add: maxBalInp_def allBlocks_def)
  with bk_noninit act
  show ?thesis
    by(auto simp add: EndPhase1_def)
qed

lemma HEndPhase1_maxBalInp:
  assumes act: "HEndPhase1 s s' q"
    and asm1: "b \<in> (UN p. Ballot p)"
    and asm2: "D\<in>MajoritySet"
    and asm3: "maxBalInp s b v"
    and asm4: "\<forall>d\<in>D.  b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))"

  and inv1: "Inv1 s"
  and inv2a: "Inv2a s"
  and inv2b: "Inv2b s"
  shows "maxBalInp s' b v"
proof(cases "b \<le> mbal(dblock s q)")
  case True
  show ?thesis
  proof(cases "p\<noteq>q")
    assume pnq: "p\<noteq>q"
    have "\<exists>d\<in>D. hasRead s q d p"
    proof -
      from act
      have "IsMajority({d. d\<in> disksWritten s q \<and> (\<forall>r\<in>UNIV-{q}. hasRead s q d r)})" (is "IsMajority(?M)")
        by(auto simp add: EndPhase1_def)
      with majorities_intersect asm2
      have "D \<inter> ?M \<noteq> {}"
        by(auto simp add: MajoritySet_def)
      hence "\<exists>d\<in>D. (\<forall>r\<in>UNIV-{q}. hasRead s q d r)"
        by auto
      with pnq
      show ?thesis
        by auto
    qed
    then obtain d where p41: "d\<in>D \<and> hasRead s q d p" by auto
    with asm4 asm3 act True
    have p42: "\<exists>br\<in>blocksRead s q d. b\<le> bal(block br)"
      by(auto simp add: EndPhase1_def)
    from True act
    have thesis_L: "b\<le>bal (dblock s' q)"
      by(auto simp add: EndPhase1_def)
    from p42
    have "inp(dblock s' q) = v"
    proof auto
      fix br
      assume br: "br \<in> blocksRead s q d"
        and b_bal: " b \<le> bal (block br)"
      hence br_rdBy: "br \<in> (UN q d. rdBy s (proc br) q d)"
        by(auto simp add:  rdBy_def)
      hence br_blksof: "block br \<in> blocksOf s (proc br)"
        by(auto simp add: blocksOf_def)
      from br have br_bseen: "block br\<in> blocksSeen s q"
        by(auto simp add: blocksSeen_def allBlocksRead_def allRdBlks_def)
      from HEndPhase1_valueChosen_inp[OF act inv2a asm1 br_blksof br_bseen b_bal asm3 inv1]
      show ?thesis .
    qed
    with asm3 HEndPhase1_allBlocks[OF act]
    show ?thesis
      by(auto simp add: maxBalInp_def)
  next
    case False
    from asm4
    have p41: "\<forall>d\<in>D. b \<le> bal(disk s d p)"
      by auto
    have p42: "\<exists>d\<in>D. disk s d p = dblock s p"
    proof -
      from act
      have "IsMajority {d. d\<in>disksWritten s q \<and> (\<forall>p\<in>UNIV-{q}. hasRead s q d p)}" (is "IsMajority ?S")
        by(auto simp add: EndPhase1_def)
      with majorities_intersect asm2
      have "D \<inter> ?S \<noteq> {}"
        by(auto simp add: MajoritySet_def)
      hence "\<exists>d\<in>D. d\<in>disksWritten s q"
        by auto
      with inv2b False
      show ?thesis
        by(auto simp add: Inv2b_def Inv2b_inner_def)
    qed
    have "inp(dblock s' q) = v"
    proof -
      from p42 p41 False
      have b_bal: "b \<le> bal(dblock s q)" by auto
      have db_blksof: "(dblock s q) \<in> blocksOf s q"
        by(auto simp add: blocksOf_def)
      have db_bseen: "(dblock s q) \<in> blocksSeen s q"
        by(auto simp add: blocksSeen_def)
      from HEndPhase1_valueChosen_inp[OF act inv2a asm1 db_blksof db_bseen b_bal asm3 inv1]
      show ?thesis .
    qed
    with asm3 HEndPhase1_allBlocks[OF act]
    show ?thesis
      by(auto simp add: maxBalInp_def)
  qed
next
  case False
  have "dblock s' q \<in> allBlocks s'"
    by(auto simp add: allBlocks_def blocksOf_def)
  show ?thesis
  proof(auto simp add: maxBalInp_def)
    fix bk
    assume bk: "bk \<in> allBlocks s'"
      and b_bal: "b \<le> bal bk"
    from subsetD[OF HEndPhase1_allBlocks[OF act] bk]
    show "inp bk = v"
    proof
      assume bk: "bk \<in> allBlocks s"
      with asm3 b_bal
      show ?thesis
        by(auto simp add: maxBalInp_def)
    next
      assume bk: "bk \<in>  {dblock s' q}"
      from act False
      have " \<not> b \<le> bal (dblock s' q)"
        by(auto simp add: EndPhase1_def)
      with bk b_bal
      show ?thesis
        by(auto)
    qed
  qed
qed

lemma HEndPhase1_valueChosen2:
  assumes act: "HEndPhase1 s s' q"
    and asm4: "\<forall>d\<in>D.   b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))" (is "?P s")
  shows "?P s'"
proof(auto)
  fix d
  assume d: "d\<in>D"
  with act asm4
  show "b \<le> bal (disk s' d p)"
    by(auto simp add: EndPhase1_def)
  fix d q
  assume d: "d\<in>D"
    and phase': "phase s' q = Suc 0"
    and dblk_mbal: "b \<le> mbal (dblock s' q)"
  with act
  have p31: "phase s q = 1"
    and p32: "dblock s' q = dblock s q"
    by(auto simp add: EndPhase1_def split: if_split_asm)
  with dblk_mbal
  have "b\<le>mbal(dblock s q)" by auto
  moreover
  assume hasRead: "hasRead s' q d p"
  with act
  have "hasRead s q d p"
    by(auto simp add: EndPhase1_def InitializePhase_def
      hasRead_def split: if_split_asm)
  ultimately
  have "\<exists>br\<in>blocksRead s q d. b\<le> bal(block br)"
    using p31 asm4 d
    by blast
  with act hasRead
  show "\<exists>br\<in>blocksRead s' q d. b\<le> bal(block br)"
    by(auto simp add: EndPhase1_def InitializePhase_def hasRead_def)
qed

theorem HEndPhase1_valueChosen:
  assumes act: "HEndPhase1 s s' q"
  and vc: "valueChosen s v"
  and inv1: "Inv1 s"
  and inv2a: "Inv2a s"
  and inv2b: "Inv2b s"
  and v_input: "v \<in> Inputs"
  shows "valueChosen s' v"
proof -
  from vc
  obtain b p D where
        asm1: "b \<in> (UN p. Ballot p)"
    and asm2: "D\<in>MajoritySet"
    and asm3: "maxBalInp s b v"
    and asm4: "\<forall>d\<in>D.  b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))"
    by(auto simp add: valueChosen_def)
  from HEndPhase1_maxBalInp[OF act asm1 asm2 asm3 asm4 inv1 inv2a inv2b]
  have "maxBalInp s' b v" .
  with HEndPhase1_valueChosen2[OF act asm4] asm1 asm2
  show ?thesis
    by(auto simp add: valueChosen_def)
qed

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

lemma HStartBallot_valueChosen2:
  assumes act: "HStartBallot s s' q"
    and asm4: "\<forall>d\<in>D.   b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))" (is "?P s")
  shows "?P s'"
proof(auto)
  fix d
  assume d: "d\<in>D"
  with act asm4
  show "b \<le> bal (disk s' d p)"
    by(auto simp add: StartBallot_def)
  fix d q
  assume d: "d\<in>D"
    and phase': "phase s' q = Suc 0"
    and dblk_mbal: "b \<le> mbal (dblock s' q)"
    and hasRead: "hasRead s' q d p"
  from phase' act hasRead
  have p31: "phase s q = 1"
   and p32: "dblock s' q = dblock s q"
    by(auto simp add: StartBallot_def InitializePhase_def
                 hasRead_def split : if_split_asm)
  with dblk_mbal
  have "b\<le>mbal(dblock s q)" by auto
  moreover
  from act hasRead
  have "hasRead s q d p"
    by(auto simp add: StartBallot_def InitializePhase_def
      hasRead_def split: if_split_asm)
  ultimately
  have "\<exists>br\<in>blocksRead s q d. b\<le> bal(block br)"
    using p31 asm4 d
    by blast
  with act hasRead
  show "\<exists>br\<in>blocksRead s' q d. b\<le> bal(block br)"
    by(auto simp add: StartBallot_def InitializePhase_def
                      hasRead_def)
qed

theorem HStartBallot_valueChosen:
  assumes act: "HStartBallot s s' q"
  and vc: "valueChosen s v"
  and v_input: "v \<in> Inputs"
  shows "valueChosen s' v"
proof -
  from vc
  obtain b p D where
        asm1: "b \<in> (UN p. Ballot p)"
    and asm2: "D\<in>MajoritySet"
    and asm3: "maxBalInp s b v"
    and asm4: "\<forall>d\<in>D.  b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))"
    by(auto simp add: valueChosen_def)
  from HStartBallot_maxBalInp[OF act asm3]
  have "maxBalInp s' b v" .
  with HStartBallot_valueChosen2[OF act asm4] asm1 asm2
  show ?thesis
    by(auto simp add: valueChosen_def)
qed

lemma HPhase1or2Write_maxBalInp:
  assumes act: "HPhase1or2Write s s' q d"
    and asm3: "maxBalInp s b v"
  shows "maxBalInp s' b v"
proof(auto simp add: maxBalInp_def)
  fix bk
  assume bk: "bk \<in> allBlocks s'"
    and b_bal: "b\<le> bal bk"
  from subsetD[OF HPhase1or2Write_allBlocks[OF act] bk] asm3 b_bal
  show "inp bk = v"
    by(auto simp add: maxBalInp_def)
qed

lemma HPhase1or2Write_valueChosen2:
  assumes act: "HPhase1or2Write s s' pp d"
    and asm2: "D\<in>MajoritySet"
    and asm4: "\<forall>d\<in>D.   b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))" (is "?P s")
    and inv4: "HInv4a s pp"
  shows "?P s'"
proof(auto)
  fix d1
  assume d: "d1\<in>D"
  show "b \<le> bal (disk s' d1 p)"
  proof(cases "d1=d\<and>pp=p")
    case True
    with inv4 act
    have "HInv4a2 s p"
      by(auto simp add: Phase1or2Write_def HInv4a_def)
    with asm2 majorities_intersect
    have "\<exists>dd\<in>D. bal(disk s dd p)\<le>bal(dblock s p)"
      by(auto simp add: HInv4a2_def MajoritySet_def)
    then obtain dd where p41: "dd\<in>D \<and> bal(disk s dd p)\<le>bal(dblock s p)"
      by auto
    from asm4 p41
    have "b\<le> bal(disk s dd p)"
      by auto
    with p41
    have p42: "b \<le> bal(dblock s p)"
      by auto
    from act True
    have "dblock s p = disk s' d p"
      by(auto simp add: Phase1or2Write_def)
    with p42 True
    show ?thesis
      by auto
  next
    case False
    with act asm4 d
    show ?thesis
      by(auto simp add: Phase1or2Write_def)
  qed
next
  fix d q
  assume d: "d\<in>D"
    and phase': "phase s' q = Suc 0"
    and dblk_mbal: "b \<le> mbal (dblock s' q)"
    and hasRead: "hasRead s' q d p"
  from phase' act hasRead
  have p31: "phase s q = 1"
   and p32: "dblock s' q = dblock s q"
    by(auto simp add: Phase1or2Write_def InitializePhase_def
                      hasRead_def split : if_split_asm)
  with dblk_mbal
  have "b\<le>mbal(dblock s q)" by auto
  moreover
  from act hasRead
  have "hasRead s q d p"
    by(auto simp add: Phase1or2Write_def InitializePhase_def
      hasRead_def split: if_split_asm)
  ultimately
  have "\<exists>br\<in>blocksRead s q d. b\<le> bal(block br)"
    using p31 asm4 d
    by blast
  with act hasRead
  show "\<exists>br\<in>blocksRead s' q d. b\<le> bal(block br)"
    by(auto simp add: Phase1or2Write_def InitializePhase_def
                      hasRead_def)
qed

theorem HPhase1or2Write_valueChosen:
  assumes act: "HPhase1or2Write s s' q d"
  and vc: "valueChosen s v"
  and v_input: "v \<in> Inputs"
  and inv4: "HInv4a s q"
  shows "valueChosen s' v"
proof -
  from vc
  obtain b p D where
        asm1: "b \<in> (UN p. Ballot p)"
    and asm2: "D\<in>MajoritySet"
    and asm3: "maxBalInp s b v"
    and asm4: "\<forall>d\<in>D.  b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))"
    by(auto simp add: valueChosen_def)
  from HPhase1or2Write_maxBalInp[OF act asm3]
  have "maxBalInp s' b v" .
  with HPhase1or2Write_valueChosen2[OF act asm2 asm4 inv4] asm1 asm2
  show ?thesis
    by(auto simp add: valueChosen_def)
qed

lemma HPhase1or2ReadThen_maxBalInp:
  assumes act: "HPhase1or2ReadThen s s' q d p"
    and asm3: "maxBalInp s b v"
  shows "maxBalInp s' b v"
proof(auto simp add: maxBalInp_def)
  fix bk
  assume bk: "bk \<in> allBlocks s'"
    and b_bal: "b\<le> bal bk"
  from subsetD[OF HPhase1or2ReadThen_allBlocks[OF act] bk] asm3 b_bal
  show "inp bk = v"
    by(auto simp add: maxBalInp_def)
qed

theorem HPhase1or2ReadThen_valueChosen:
  assumes act: "HPhase1or2ReadThen s s' q d p"
  and vc: "valueChosen s v"
  and v_input: "v \<in> Inputs"
  shows "valueChosen s' v"
proof -
  from vc
  obtain b p D where
        asm1: "b \<in> (UN p. Ballot p)"
    and asm2: "D\<in>MajoritySet"
    and asm3: "maxBalInp s b v"
    and asm4: "\<forall>d\<in>D.  b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))"
    by(auto simp add: valueChosen_def)
  from HPhase1or2ReadThen_maxBalInp[OF act asm3]
  have "maxBalInp s' b v" .
  with HPhase1or2ReadThen_valueChosen2[OF act asm4] asm1 asm2
  show ?thesis
    by(auto simp add: valueChosen_def)
qed

theorem HPhase1or2ReadElse_valueChosen:
  "\<lbrakk> HPhase1or2ReadElse s s' p d r; valueChosen s v; v\<in> Inputs  \<rbrakk>
     \<Longrightarrow> valueChosen s' v"
  using HStartBallot_valueChosen
  by(auto simp add: Phase1or2ReadElse_def)

lemma HEndPhase2_maxBalInp:
  assumes act: "HEndPhase2 s s' q"
    and asm3: "maxBalInp s b v"
  shows "maxBalInp s' b v"
proof(auto simp add: maxBalInp_def)
  fix bk
  assume bk: "bk \<in> allBlocks s'"
    and b_bal: "b\<le> bal bk"
  from subsetD[OF HEndPhase2_allBlocks[OF act] bk] asm3 b_bal
  show "inp bk = v"
    by(auto simp add: maxBalInp_def)
qed

lemma HEndPhase2_valueChosen2:
  assumes act: "HEndPhase2 s s' q"
    and asm4: "\<forall>d\<in>D.   b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))" (is "?P s")
  shows "?P s'"
proof(auto)
  fix d
  assume d: "d\<in>D"
  with act asm4
  show "b \<le> bal (disk s' d p)"
    by(auto simp add: EndPhase2_def)
  fix d q
  assume d: "d\<in>D"
    and phase': "phase s' q = Suc 0"
    and dblk_mbal: "b \<le> mbal (dblock s' q)"
    and hasRead: "hasRead s' q d p"
  from phase' act hasRead
  have p31: "phase s q = 1"
   and p32: "dblock s' q = dblock s q"
    by(auto simp add: EndPhase2_def InitializePhase_def
                      hasRead_def split : if_split_asm)
  with dblk_mbal
  have "b\<le>mbal(dblock s q)" by auto
  moreover
  from act hasRead
  have "hasRead s q d p"
    by(auto simp add: EndPhase2_def InitializePhase_def
      hasRead_def split: if_split_asm)
  ultimately
  have "\<exists>br\<in>blocksRead s q d. b\<le> bal(block br)"
    using p31 asm4 d
    by blast
  with act hasRead
  show "\<exists>br\<in>blocksRead s' q d. b\<le> bal(block br)"
    by(auto simp add: EndPhase2_def InitializePhase_def
                      hasRead_def)
qed

theorem HEndPhase2_valueChosen:
  assumes act: "HEndPhase2 s s' q"
  and vc: "valueChosen s v"
  and v_input: "v \<in> Inputs"
  shows "valueChosen s' v"
proof -
  from vc
  obtain b p D where
        asm1: "b \<in> (UN p. Ballot p)"
    and asm2: "D\<in>MajoritySet"
    and asm3: "maxBalInp s b v"
    and asm4: "\<forall>d\<in>D.  b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))"
    by(auto simp add: valueChosen_def)
  from HEndPhase2_maxBalInp[OF act asm3]
  have "maxBalInp s' b v" .
  with HEndPhase2_valueChosen2[OF act asm4] asm1 asm2
  show ?thesis
    by(auto simp add: valueChosen_def)
qed

lemma HFail_maxBalInp:
  assumes act: "HFail s s' q"
    and asm1: "b \<in> (UN p. Ballot p)"
    and asm3: "maxBalInp s b v"
  shows "maxBalInp s' b v"
proof(auto simp add: maxBalInp_def)
  fix bk
  assume bk: "bk \<in> allBlocks s'"
    and b_bal: "b\<le> bal bk"
  from subsetD[OF HFail_allBlocks[OF act] bk]
  show "inp bk = v"
  proof
    assume bk: "bk\<in>allBlocks s"
    with asm3 b_bal
    show ?thesis
      by(auto simp add: maxBalInp_def)
  next
    assume bk: "bk\<in>{dblock s' q}"
    with act
    have "bal bk = 0"
      by(auto simp add: Fail_def InitDB_def)
    moreover
    from Ballot_nzero asm1
    have "0 < b"
      by auto
    ultimately
    show ?thesis
      using b_bal
      by auto
  qed
qed

lemma HFail_valueChosen2:
  assumes act: "HFail s s' q"
    and asm4: "\<forall>d\<in>D.   b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))" (is "?P s")
  shows "?P s'"
proof(auto)
  fix d
  assume d: "d\<in>D"
  with act asm4
  show "b \<le> bal (disk s' d p)"
    by(auto simp add: Fail_def)
  fix d q
  assume d: "d\<in>D"
    and phase': "phase s' q = Suc 0"
    and dblk_mbal: "b \<le> mbal (dblock s' q)"
    and hasRead: "hasRead s' q d p"
  from phase' act hasRead
  have p31: "phase s q = 1"
   and p32: "dblock s' q = dblock s q"
    by(auto simp add: Fail_def InitializePhase_def
                  hasRead_def split : if_split_asm)
  with dblk_mbal
  have "b\<le>mbal(dblock s q)" by auto
  moreover
  from act hasRead
  have "hasRead s q d p"
    by(auto simp add: Fail_def InitializePhase_def
      hasRead_def split: if_split_asm)
  ultimately
  have "\<exists>br\<in>blocksRead s q d. b\<le> bal(block br)"
    using p31 asm4 d
    by blast
  with act hasRead
  show "\<exists>br\<in>blocksRead s' q d. b\<le> bal(block br)"
    by(auto simp add: Fail_def InitializePhase_def hasRead_def)
qed

theorem HFail_valueChosen:
  assumes act: "HFail s s' q"
  and vc: "valueChosen s v"
  and v_input: "v \<in> Inputs"
  shows "valueChosen s' v"
proof -
  from vc
  obtain b p D where
        asm1: "b \<in> (UN p. Ballot p)"
    and asm2: "D\<in>MajoritySet"
    and asm3: "maxBalInp s b v"
    and asm4: "\<forall>d\<in>D.  b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))"
    by(auto simp add: valueChosen_def)
  from HFail_maxBalInp[OF act asm1 asm3]
  have "maxBalInp s' b v" .
  with HFail_valueChosen2[OF act asm4] asm1 asm2
  show ?thesis
    by(auto simp add: valueChosen_def)
qed

lemma HPhase0Read_maxBalInp:
  assumes act: "HPhase0Read s s' q d"
    and asm3: "maxBalInp s b v"
  shows "maxBalInp s' b v"
proof(auto simp add: maxBalInp_def)
  fix bk
  assume bk: "bk \<in> allBlocks s'"
    and b_bal: "b\<le> bal bk"
  from subsetD[OF HPhase0Read_allBlocks[OF act] bk] asm3 b_bal
  show "inp bk = v"
    by(auto simp add: maxBalInp_def)
qed

lemma HPhase0Read_valueChosen2:
  assumes act: "HPhase0Read s s' qq dd"
    and asm4: "\<forall>d\<in>D.   b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))" (is "?P s")
  shows "?P s'"
proof(auto)
  fix d
  assume d: "d\<in>D"
  with act asm4
  show "b \<le> bal (disk s' d p)"
    by(auto simp add: Phase0Read_def)
next
  fix d q
  assume d: "d\<in>D"
    and phase': "phase s' q = Suc 0"
    and dblk_mbal: "b \<le> mbal (dblock s' q)"
    and hasRead: "hasRead s' q d p"
  from phase' act
  have qqnq: "qq\<noteq>q"
    by(auto simp add: Phase0Read_def)
  show "\<exists>br\<in>blocksRead s' q d. b \<le> bal (block br)"
  proof -
    from phase' act hasRead
    have p31: "phase s q = 1"
      and p32: "dblock s' q = dblock s q"
      by(auto simp add: Phase0Read_def hasRead_def)
    with dblk_mbal
    have "b\<le>mbal(dblock s q)" by auto
    moreover
    from act hasRead qqnq
    have "hasRead s q d p"
      by(auto simp add: Phase0Read_def hasRead_def
                 split: if_split_asm)
    ultimately
    have "\<exists>br\<in>blocksRead s q d. b\<le> bal(block br)"
      using p31 asm4 d
      by blast
    with act hasRead
    show "\<exists>br\<in>blocksRead s' q d. b\<le> bal(block br)"
      by(auto simp add: Phase0Read_def InitializePhase_def
                        hasRead_def)
  qed
qed

theorem HPhase0Read_valueChosen:
  assumes act: "HPhase0Read s s' q d"
  and vc: "valueChosen s v"
  and v_input: "v \<in> Inputs"
  shows "valueChosen s' v"
proof -
  from vc
  obtain b p D where
        asm1: "b \<in> (UN p. Ballot p)"
    and asm2: "D\<in>MajoritySet"
    and asm3: "maxBalInp s b v"
    and asm4: "\<forall>d\<in>D.  b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))"
    by(auto simp add: valueChosen_def)
  from HPhase0Read_maxBalInp[OF act asm3]
  have "maxBalInp s' b v" .
  with HPhase0Read_valueChosen2[OF act asm4] asm1 asm2
  show ?thesis
    by(auto simp add: valueChosen_def)
qed

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

lemma HEndPhase0_valueChosen2:
  assumes act: "HEndPhase0 s s' q"
    and asm4: "\<forall>d\<in>D.   b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))" (is "?P s")
  shows "?P s'"
proof(auto)
  fix d
  assume d: "d\<in>D"
  with act asm4
  show "b \<le> bal (disk s' d p)"
    by(auto simp add: EndPhase0_def)
  fix d q
  assume d: "d\<in>D"
    and phase': "phase s' q = Suc 0"
    and dblk_mbal: "b \<le> mbal (dblock s' q)"
    and hasRead: "hasRead s' q d p"
  from phase' act hasRead
  have p31: "phase s q = 1"
   and p32: "dblock s' q = dblock s q"
    by(auto simp add: EndPhase0_def InitializePhase_def
                       hasRead_def split : if_split_asm)
  with dblk_mbal
  have "b\<le>mbal(dblock s q)" by auto
  moreover
  from act hasRead
  have "hasRead s q d p"
    by(auto simp add: EndPhase0_def InitializePhase_def
      hasRead_def split: if_split_asm)
  ultimately
  have "\<exists>br\<in>blocksRead s q d. b\<le> bal(block br)"
    using p31 asm4 d
    by blast
  with act hasRead
  show "\<exists>br\<in>blocksRead s' q d. b\<le> bal(block br)"
    by(auto simp add: EndPhase0_def InitializePhase_def
                      hasRead_def)
qed

theorem HEndPhase0_valueChosen:
  assumes act: "HEndPhase0 s s' q"
  and vc: "valueChosen s v"
  and v_input: "v \<in> Inputs"
  and inv1: "Inv1 s"
  shows "valueChosen s' v"
proof -
  from vc
  obtain b p D where
        asm1: "b \<in> (UN p. Ballot p)"
    and asm2: "D\<in>MajoritySet"
    and asm3: "maxBalInp s b v"
    and asm4: "\<forall>d\<in>D.  b \<le> bal(disk s d p)
                   \<and>(\<forall>q.(   phase s q = 1
                          \<and> b \<le>mbal(dblock s q)
                          \<and> hasRead s q d p
                         ) \<longrightarrow> (\<exists>br\<in>blocksRead s q d. b \<le> bal(block br)))"
    by(auto simp add: valueChosen_def)
  from HEndPhase0_maxBalInp[OF act asm3 inv1]
  have "maxBalInp s' b v" .
  with HEndPhase0_valueChosen2[OF act asm4] asm1 asm2
  show ?thesis
    by(auto simp add: valueChosen_def)
qed

end


theory Dining_Cryptographers_example
  imports Main "~~/src/HOL/Library/LaTeXsugar" "Shadow_Semantics" "Utils" "Cream_Cake_example"
begin

section \<open>Dining Cryptographers\<close>

(*
For this interpretation I want to say that REVEAL "a XOR b XOR c" is the same as
declaring 3 new (extra) hidden variables, (x, y, z) and then REVEALING:
a XOR x XOR y
b XOR y XOR z
c XOR z XOR x
*)

lemma dining_help:
  assumes "G={True,False}"
  shows
"
REVEAL {
        {
         (a,b,c)| a b c. a\<in>G \<and> b\<in>G \<and> c\<in>G \<and>
          (g = (XOR (XOR a b) c))
        }
         |g. g\<in>G
       } (A\<times>B\<times>C)
=
       {
        {
         (a,b,c)| a b c. a\<in>A \<and> b\<in>B \<and> c\<in>C \<and>
          (g = (XOR (XOR a b) c))
        }
         |g. g\<in>G
       }
"
  unfolding REVEAL_def XOR_def
  apply safe
  apply (rule_tac x="g" in exI)
  using assms apply blast
  apply (rule_tac x="{(a, b, c) |a b c. a \<in> G \<and> b \<in> G \<and> c \<in> G \<and> g = (((a \<or> b) \<and> (\<not> a \<or> \<not> b) \<or> c) \<and> (\<not> ((a \<or> b) \<and> (\<not> a \<or> \<not> b)) \<or> \<not> c))}" in exI)
  using assms by blast

lemma dining_help1:
"
CHOOSE (\<lambda>(_, a, b, c). {((x, y, z), a, b, c) |x y z. x \<in> G \<and> y \<in> G \<and> z \<in> G}) ({t} \<times> A \<times> B \<times> C)
=
{(G\<times>G\<times>G)\<times>A\<times>B\<times>C}
"
  unfolding CHOOSE_def
  by blast

lemma dining_help2:
"
REVEAL {{((x, y, z), a, b, c) |x y z a b c.
                               x \<in> G \<and> y \<in> G \<and> z \<in> G \<and> a \<in> G \<and> b \<in> G \<and> c \<in> G \<and> g = XOR (XOR a x) y \<and> k = XOR (XOR b y) z \<and> m = XOR (XOR c z) x}
                                  |g k m. g \<in> G \<and> k \<in> G \<and> m \<in> G} `
             {(G \<times> G \<times> G) \<times> A \<times> B \<times> C}
=
{
REVEAL {{((x, y, z), a, b, c) |x y z a b c.
                               x \<in> G \<and> y \<in> G \<and> z \<in> G \<and> a \<in> G \<and> b \<in> G \<and> c \<in> G \<and> g = XOR (XOR a x) y \<and> k = XOR (XOR b y) z \<and> m = XOR (XOR c z) x}
                                  |g k m. g \<in> G \<and> k \<in> G \<and> m \<in> G}
             ((G \<times> G \<times> G) \<times> A \<times> B \<times> C)
}
"
  by blast

lemma dining_help3:
  assumes "G={True,False}"
  shows
"
{
REVEAL {{((x, y, z), a, b, c) |x y z a b c.
                               x \<in> G \<and> y \<in> G \<and> z \<in> G \<and> a \<in> G \<and> b \<in> G \<and> c \<in> G \<and> g = XOR (XOR a x) y \<and> k = XOR (XOR b y) z \<and> m = XOR (XOR c z) x}
                                  |g k m. g \<in> G \<and> k \<in> G \<and> m \<in> G}
             ((G \<times> G \<times> G) \<times> A \<times> B \<times> C)
}
=
{
{{((x, y, z), a, b, c) |x y z a b c.
                               x \<in> G \<and> y \<in> G \<and> z \<in> G \<and> a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> g = XOR (XOR a x) y \<and> k = XOR (XOR b y) z \<and> m = XOR (XOR c z) x}
                                  |g k m. g \<in> G \<and> k \<in> G \<and> m \<in> G}
}
"
  unfolding REVEAL_def
  apply safe
  apply (rule_tac x="g" in exI)
  apply (rule_tac x="k" in exI)
  apply (rule_tac x="m" in exI)
  apply (unfold XOR_def)[1]
  using assms apply simp
  apply blast
  apply (rule_tac x="{((x, y, z), a, b, c) |x y z a b c. x \<in> G \<and> y \<in> G \<and> z \<in> G \<and> a \<in> G \<and> b \<in> G \<and> c \<in> G \<and> g = XOR (XOR a x) y \<and> k = XOR (XOR b y) z \<and> m = XOR (XOR c z) x}" in exI)
  using assms apply simp
  by blast

lemma dining_help4:
  assumes "G={True,False}"
  and     "A \<subseteq> G"
  and     "B \<subseteq> G"
  and     "C \<subseteq> G"
  and     "X \<subseteq> G"
  and     "Y \<subseteq> G"
  and     "Z \<subseteq> G"
  shows
"
{
  {snd h |h. h \<in> s} |s.
     s \<in> {
           {((x, y, z), a, b, c)
               |x y z a b c.
                x \<in> G \<and> y \<in> G \<and> z \<in> G \<and> a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> g = XOR (XOR a x) y \<and> k = XOR (XOR b y) z \<and> m = XOR (XOR c z) x
           } |g k m.
           g \<in> G \<and> k \<in> G \<and> m \<in> G
         }
}
=
{
           {(a, b, c)
               |x y z a b c.
                x \<in> G \<and> y \<in> G \<and> z \<in> G \<and> a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> g = XOR (XOR a x) y \<and> k = XOR (XOR b y) z \<and> m = XOR (XOR c z) x
           } |g k m.
           g \<in> G \<and> k \<in> G \<and> m \<in> G
         }
"
  apply safe
  apply simp
  apply blast
  unfolding XOR_def
  using assms apply simp
  apply (rule_tac x="{((x, y, z), a, b, c) |x y z a b c.
                a \<in> A \<and>
                b \<in> B \<and>
                c \<in> C \<and>
                g = (((a \<or> x) \<and> (a \<longrightarrow> \<not> x) \<or> y) \<and> (\<not> a \<and> \<not> x \<or> a \<and> x \<or> \<not> y)) \<and>
                k = (((b \<or> y) \<and> (b \<longrightarrow> \<not> y) \<or> z) \<and> (\<not> b \<and> \<not> y \<or> b \<and> y \<or> \<not> z)) \<and> m = (((c \<or> z) \<and> (c \<longrightarrow> \<not> z) \<or> x) \<and> (\<not> c \<and> \<not> z \<or> c \<and> z \<or> \<not> x))}" in exI)
  by auto

lemma dining_cryptographers:
  assumes "G={True,False}"
  and     "A \<subseteq> G"
  and     "B \<subseteq> G"
  and     "C \<subseteq> G"
  and     "X \<subseteq> G"
  and     "Y \<subseteq> G"
  and     "Z \<subseteq> G"
  shows
"
REVEAL {
        {
         (a,b,c)| a b c. a\<in>G \<and> b\<in>G \<and> c\<in>G \<and>
          (g = (XOR (XOR a b) c))
        }
         |g. g\<in>G
       } (A\<times>B\<times>C)
=
NewVar t (
          CHOOSE (
                  \<lambda>(_,(a,b,c)). {((x,y,z),(a,b,c))|x y z. x\<in>G \<and> y\<in>G \<and> z\<in>G}
                 ) ;;
          REVEAL {
                  {
                   ((x,y,z),(a,b,c))|x y z a b c. x\<in>G \<and> y\<in>G \<and> z\<in>G \<and> a\<in>G \<and> b\<in>G \<and> c\<in>G \<and>
                                      (g = (XOR (XOR a x) y)) \<and>
                                      (k = (XOR (XOR b y) z)) \<and>
                                      (m = (XOR (XOR c z) x))
                  }|g k m. g\<in>G \<and> k\<in>G \<and> m\<in>G
                 }
         ) (A\<times>B\<times>C)
"

  apply (subst dining_help)
  using assms apply simp
  unfolding NewVar_def
  unfolding COMPOSE_def
  apply (subst dining_help1)
  apply (subst dining_help2)
  apply (subst dining_help3)
  using assms apply simp
  apply (subst union_over_singleton)
  apply (subst dining_help4[where X="X" and Y="Y" and Z="Z"])
  using assms apply(simp+)[7]
  apply safe
  using assms apply simp
  apply (rule_tac x="g" in exI)
  apply (rule_tac x="g" in exI)
  apply (rule_tac x="g" in exI)
  apply (unfold XOR_def)[1]
  apply blast
  using assms apply simp
  apply (rule_tac x="XOR (XOR g k) m" in exI)
  unfolding XOR_def
  apply simp
  by blast

section \<open>Proving Algebraic Steps for 3 cryptographers\<close>
(*
   The first part of this in 1001 cryptographers uses the cream cake result
   with a difference that instead of showing reveal (a==b) ;; reveal (a==c) is
   equivalent to reveal (a==b) ;; reveal (b==c) we replace equality with XOR

   So I turn the equality into the exact one used above in equiv_reveals.
*)

lemma XOR_equiv_equality1:
"
 REVEAL {{(a,b,c)|a b c. (XOR a c) = k \<and> b\<in>{True,False}}|k. k\<in>{True,False}}
 =
 REVEAL {{(a,b,c)|a b c. (a = c) = k \<and> b\<in>{True,False}}|k. k\<in>{True,False}}
"
  apply (rule ext)
  unfolding REVEAL_def XOR_def
  apply simp
  apply safe
  apply simp
  apply (rule_tac x="{(a, b, c) |a b c. (a = c) = (\<not>k)}" in exI)
  apply blast
  apply simp
  apply (rule_tac x="{(a, b, c) |a b c. ((a \<or> c) \<and> (a \<longrightarrow> \<not> c)) = (\<not>k)}" in exI)
  by auto

lemma XOR_equiv_equality2:
"
 REVEAL {{(a,b,c)|a b c. (XOR a b) = k \<and> c\<in>{True,False}}|k. k\<in>{True,False}}
 =
 REVEAL {{(a,b,c)|a b c. (a = b) = k \<and> c\<in>{True,False}}|k. k\<in>{True,False}}
"
  apply (rule ext)
  unfolding REVEAL_def XOR_def
  apply simp
  apply safe
  apply simp
  apply (rule_tac x="{z. \<exists>a b. (\<exists>c. z = (a, b, c)) \<and> (a = b) = (\<not>k)}" in exI)
  apply blast
  apply simp
  apply (rule_tac x="{z. \<exists>a b. (\<exists>c. z = (a, b, c)) \<and> ((a \<or> b) \<and> (a \<longrightarrow> \<not> b)) = (\<not>k)}" in exI)
  by auto

lemma XOR_equiv_equality3:
"
  REVEAL {{(a,b,c)|a b c. (XOR c b) = k \<and> a\<in>{True,False}}|k. k\<in>{True,False}}
 =
  REVEAL {{(a,b,c)|a b c. (c = b) = k \<and> a\<in>{True,False}}|k. k\<in>{True,False}}
"
  apply (rule ext)
  unfolding REVEAL_def XOR_def
  apply simp
  apply safe
  apply simp
  apply (rule_tac x="{(a, b, c) |a b c. (c = b) = (\<not>k) }" in exI)
  apply blast
  apply simp
  apply (rule_tac x="{(a, b, c) |a b c. ((c \<or> b) \<and> (c \<longrightarrow> \<not> b)) = (\<not>k) }" in exI)
  by auto

lemma aXORb_aXORc_determines_aXORb_bXORc:
  shows
  "(
    REVEAL {{(a,b,c)|a b c. (XOR a c) = k \<and> b\<in>{True,False}}|k. k\<in>{True,False}} ;;
    REVEAL {{(a,b,c)|a b c. (XOR a b) = k \<and> c\<in>{True,False}}|k. k\<in>{True,False}}
   )
   =
   (
    REVEAL {{(a,b,c)|a b c. (XOR a c) = k \<and> b\<in>{True,False}}|k. k\<in>{True,False}} ;;
    REVEAL {{(a,b,c)|a b c. (XOR c b) = k \<and> a\<in>{True,False}}|k. k\<in>{True,False}}
   )"
  apply (subst XOR_equiv_equality1)+
  apply (subst XOR_equiv_equality2)
  apply (subst XOR_equiv_equality3)
  using equiv_reveals by simp

(*
   Now we have reached (10) in 1001 cryptos

   Next the implementation is constructed and the first step taken uses:

  reveal ((l XOR r) XOR (a XOR b)) ;; reveal ((l XOR r) XOR c)
  =
  reveal ((l XOR r) XOR (a XOR b)) ;; reveal ((a XOR b) XOR c)

  which is the same as something we did before (lemma aXORb_aXORc_determines_aXORb_bXORc)

  obvious if you let x = (l XOR r) and y = (a XOR b):

  reveal (x XOR y) ;; reveal (x XOR c)
  =
  reveal (x XOR y) ;; reveal (y XOR c)

  Isabelle doesn't believe it is true currently as it requires extra variables in the state-space...

*)

(*

   Then the encryption lemma is used with a declaration of two hidden variables l and r.

   We will translate this as declaring a new pair (which is made up of two variables)

   Then we can just use our most general encryption lemma to prove it:

*)

lemma double_encryption_lemma:
  assumes "BB ={(True,True),(True,False),(False,True),(False,False)}"
          "hs \<subseteq> BB"
  shows
"
  SKIP hs
  =
  NewVar t (
             (
               CHOOSE (\<lambda>(_,x). {(lr,x)|lr. lr\<in>BB})
             ) ;;
               REVEAL {{(lr,x)|lr x. lr\<in>BB \<and> x\<in>BB
                               \<and> (XOR
                                      (XOR (fst lr) (snd lr))
                                      (XOR (fst x) (snd x))
                                 ) = k
                       }|k. k\<in>{True,False}
                      }
           )
  hs
"
  apply (subst more_general_encryption_lemma[where K="{True,False}" and H="{(True,True),(True,False),(False,True),(False,False)}"
                               and f="(\<lambda>lra xa. XOR (XOR (fst lra) (snd lra)) (XOR (fst xa) (snd xa)) )"
                               and G="{(True,True),(True,False),(False,True),(False,False)}"
                               and hs="hs" and t="t"])
  unfolding XOR_def
  using assms by simp+

(*
   The final step in 1001 cryptos is just performing a substitution that was proven earlier
   (Cream Cake with the equalities changed to XORs)
*)

(*

Turning back to scope adjustment as that is the last thing left:

*)

(*
  It is not going to be recursive, but
  I need to use pattern matching, therefore
  I cannot use "definition".
  Although, maybe I could use the recursiveness
  on COMPOSE...

definition lift_reveal :: "'h prog \<Rightarrow> ('t\<times>'h) prog"
  where
    "lift_reveal p \<equiv> case p of (REVEAL E) \<Rightarrow> REVEAL {Y\<times>e|e Y. e\<in>E} | p \<Rightarrow> (\<lambda>H. SKIP H)"
*)

(*
  can't seem to define a function even for the specific case of REVEAL,
  so instead we just prove the lemma:
*)

end


(* IsageoCoq2_R1

Tarski_Euclidean_Gupta_Model.thy

Version 2.2.0 IsaGeoCoq2_R1, Port part of GeoCoq 3.4.0
Copyright (C) 2021-2023 Roland Coghetto roland.coghetto ( a t ) cafr-msa2p.be
License: LGPGL

History
Version 1.0.0: IsaGeoCoq
Port part of GeoCoq 3.4.0 (https://geocoq.github.io/GeoCoq/) in Isabelle/Hol (Isabelle2021)

Copyright (C) 2021  Roland Coghetto roland_coghetto (at) hotmail.com

License: LGPL

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
*)
(*<*)
theory Tarski_Euclidean_Gupta_Model

imports
  Gupta
  Tarski_Gupta_Model
  Tarski_Euclidean
  Gupta_Euclidean_Tarski_Model

begin
  (*>*)

context Gupta_euclidean

begin

lemma euclidT:
  assumes "BetG A D T" and
    "BetG B D C" and
    "A \<noteq> D" and
    "\<forall> A B C D T.
     BetG A D T \<and> BetG B D C \<and> A \<noteq> D
\<longrightarrow>
     (\<exists> X Y. BetG A B X \<and> BetG A C Y \<and> BetG X T Y)"
  shows "\<exists> X Y. BetG A B X \<and> BetG A C Y \<and> BetG X T Y"
proof -
  {
    assume "B \<noteq> D"
    {
      assume "ColG A B C"
      {
        assume "BetG A B C"
        {
          assume "A \<noteq> B"
          moreover have "BetG A B C"
            using \<open>BetG A B C\<close> by blast
          moreover have "BetG A B T"
            using assms(1) assms(2) g_between_exchange4
              g_between_inner_transitivity calculation(2) by blast
          moreover have "BetG B C T \<longrightarrow> ?thesis"
            using calculation(3) g_not_bet_distincts by blast
          moreover have "BetG B T C \<longrightarrow> ?thesis"
            using g_not_bet_distincts by blast
          ultimately have ?thesis using g_l5_2 by blast
        }
        hence ?thesis
          using g_between_symmetry g_between_trivial by blast
      }
      moreover have "BetG B C A \<longrightarrow> ?thesis"
        using assms(1) assms(2) assms(3) assms(4) by presburger
      moreover have "BetG C A B \<longrightarrow> ?thesis"
        using assms(1) assms(2) assms(3) assms(4) by presburger
      ultimately have ?thesis
        using ColG_def \<open>ColG A B C\<close> by blast
    }
    moreover
    {
      assume "\<not> ColG A B C"
      {
        {
          assume "D \<noteq> C"
          hence ?thesis
            using assms(1) assms(2) assms(3) assms(4) by blast
        }
        hence ?thesis
          using assms(1) g_not_bet_distincts by blast
      }
      hence ?thesis
        by blast
    }
    ultimately have ?thesis
      by blast
  }
  thus ?thesis
    using assms(1) g_between_symmetry g_between_trivial by blast
qed

lemma lem_euclidG:
  assumes "BetG A D T" and
    "BetG B D C" and
    "A \<noteq> D"
  shows "\<exists> X Y. BetG A B X \<and> BetG A C Y \<and> BetG X T Y"
proof -
  {
    assume "B \<noteq> D" and "D \<noteq> C" and
      "\<not> (BetG A B C \<or> BetG B C A \<or> BetG C A B)"
    hence ?thesis
      using assms(1) assms(2) euclidG by presburger
  }
  moreover
  {
    assume "B = D"
    hence ?thesis
      using assms(1) g_not_bet_distincts by blast
  }
  moreover
  {
    assume "D = C"
    hence ?thesis
      using assms(1) g_between_trivial by blast
  }
  moreover
  {
    assume "BetG A B C \<or> BetG B C A \<or> BetG C A B"
    moreover have "BetG A B C \<longrightarrow> ?thesis"
      by (meson assms(1) assms(2) between_inner_transitivityG g_between_exchange4
          g_not_bet_distincts)
    moreover have "BetG B C A \<longrightarrow> ?thesis"
      by (metis assms(1) assms(2) between_inner_transitivityG between_symmetryG
          g_between_exchange4 g_not_bet_distincts segment_constructionG)
    moreover
    {
      assume "BetG C A B"
      hence "BetG B A D \<or> BetG B D A"
        using assms(1) assms(2) g_l5_3 g_between_symmetry by blast
      moreover
      {
        assume "BetG B A D"
        hence "\<exists> X Y. BetG A B X \<and> BetG A C Y \<and> BetG X T Y"
          using assms(1) assms(2) assms(3) between_symmetryG g_between_exchange4 g_l5_2
            g_not_bet_distincts by metis
      }
      moreover
      {
        assume "BetG B D A"
        hence "\<exists> X Y. BetG A B X \<and> BetG A C Y \<and> BetG X T Y"
          using assms(1) assms(2) assms(3) between_symmetryG g_between_exchange4 g_l5_2
            g_not_bet_distincts by metis
      }
      ultimately have "\<exists> X Y. BetG A B X \<and> BetG A C Y \<and> BetG X T Y"
        by blast
    }
    ultimately have ?thesis
      by blast
  }
  ultimately show ?thesis
    by blast
qed

interpretation Interpretation_Tarski_euclidean : Tarski_Euclidean
  where TPA = GPA and TPB = GPB and TPC = GPC and Bet = BetG and Cong = CongG
proof
  show "\<forall>a b. CongG a b b a"
    by (simp add: cong_pseudo_reflexivityG)
  show "\<forall>a b p q r s. CongG a b p q \<and> CongG a b r s \<longrightarrow> CongG p q r s"
    using cong_inner_transitivityG by blast
  show "\<forall>a b c. CongG a b c c \<longrightarrow> a = b"
    by (simp add: cong_identityG)
  show "\<forall>a b c q. \<exists>x. BetG q a x \<and> CongG a x b c"
    by (simp add: segment_constructionG)
  show "\<forall>a b c d a' b' c' d'. a \<noteq> b \<and> BetG a b c \<and> BetG a' b' c' \<and>
            CongG a b a' b' \<and> CongG b c b' c' \<and> CongG a d a' d' \<and> CongG b d b' d' \<longrightarrow>
       CongG c d c' d'"
    using five_segmentG by blast
  show "\<forall>a b. BetG a b a \<longrightarrow> a = b"
    by (simp add: between_identityT)
  show "\<forall>a b c p q. BetG a p c \<and> BetG b q c \<longrightarrow> (\<exists>x. BetG p x b \<and> BetG q x a)"
    using inner_paschT by blast
  show "\<not> BetG GPA GPB GPC \<and> \<not> BetG GPB GPC GPA \<and> \<not> BetG GPC GPA GPB"
    using lower_dimG by blast
  show "\<forall>A B C D T.
       BetG A D T \<and> BetG B D C \<and> A \<noteq> D \<longrightarrow>
       (\<exists>X Y. BetG A B X \<and> BetG A C Y \<and> BetG X T Y)"
    using lem_euclidG by blast
qed

end
end


section {* Prefixpoints *}

theory Ex4
imports "../LCF"
begin

lemma example:
  assumes asms: "f(p) << p"  "\<And>q. f(q) << q \<Longrightarrow> p << q"
  shows "FIX(f)=p"
  apply (unfold eq_def)
  apply (rule conjI)
  apply (induct f)
  apply (rule minimal)
  apply (intro strip)
  apply (rule less_trans)
  prefer 2
  apply (rule asms)
  apply (erule less_ap_term)
  apply (rule asms)
  apply (rule FIX_eq [THEN eq_imp_less1])
  done

end