theory No_Alias
  imports Simpl.Vcg "Rust-Verification.Rust_Semantics"
begin

record no_alias_env = globals_ram +
  x :: tagged_ref (* locals are represented by owning reference *)
  ref1 :: tagged_ref
  ref2 :: tagged_ref

definition no_alias_body :: "(no_alias_env, 'p, rust_error) com" where
  "no_alias_body ==
    Basic (\<lambda>s. (let (r, s') = heap_new (int_val 100) s in s'\<lparr> x := r \<rparr>));;

    reborrow_stmt Unique x (\<lambda>s r. s\<lparr> ref1 := r \<rparr>);;
    write_imm ref1 (int_val 200);;

    reborrow_stmt Unique x (\<lambda>s r. s\<lparr> ref2 := r \<rparr>);;
    write_imm ref2 (int_val 300)"

(* Termination *)
lemma "\<Gamma> \<turnstile>\<^sub>t {s. wf_heap s} no_alias_body {s. True}"
  unfolding no_alias_body_def
  apply vcg_step
       prefer 2
       apply vcg_step
       apply vcg_step
      apply vcg_step
     apply vcg_step
      prefer 2
      apply vcg_step
      apply vcg_step
     apply vcg_step
    apply vcg_step
     prefer 2
     apply vcg_step
     apply vcg_step
    apply vcg_step
   apply vcg_step
    prefer 2
    apply vcg_step
    apply vcg_step
   apply vcg_step
  apply vcg_step
  apply vcg_step
  by (simp add: Let_def)

(* Termination, by full VCG *)
lemma "\<Gamma> \<turnstile>\<^sub>t {s. wf_heap s} no_alias_body {s. True}"
  unfolding no_alias_body_def
  apply vcg
  by (auto simp: Let_def)

(* Spec of the program *)
lemma "\<Gamma> \<turnstile>\<^sub>t
  {s. wf_heap s}
  no_alias_body
  {s. (let p = the_ptr (pointer (x s)) in
      memory s ! p = int_val 300) \<and>
      writable (x s) s \<and> \<not>writable (ref1 s) s \<and> writable (ref2 s) s}"
  unfolding no_alias_body_def
  apply vcg
  (* This auto takes too long because of the term size *)
  by (auto simp: Let_def)

end


theory utp_fault_designs
imports   "../utp/utp" utp_designs
begin
subsection {*Sequential C-program alphabet*}

text {*In order to record the interaction of a sequential C program with its execution environment,
       we extend the alphabet of UTP by two additional global state variables:
      \begin{itemize}
       \<^item> fault: a variable of type @{typ "'f option"} used to record a fault of a given guard is
         not satisfied.
       \<^item> abrupt: a boolean variable used to
     \end{itemize}

*}

alphabet 'f cp_vars = des_vars +
  abrupt:: bool
  fault :: bool
  stuck :: bool
  fault_tr :: "'f option"

  (*wait :: bool*)

declare cp_vars.splits [alpha_splits]

subsubsection {*Alphabet proofs*}
text {*
  The two locale interpretations below are a technicality to improve automatic
  proof support via the predicate and relational tactics. This is to enable the
  (re-)interpretation of state spaces to remove any occurrences of lens types
  after the proof tactics @{method pred_simp} and @{method rel_simp}, or any
  of their derivatives have been applied. Eventually, it would be desirable to
  automate both interpretations as part of a custom outer command for defining
  alphabets.
*}

interpretation cp_vars:
  lens_interp "\<lambda> (ok, r) . (ok, abrupt\<^sub>v r, fault\<^sub>v r, fault_tr\<^sub>v r, stuck\<^sub>v r, more r)"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

interpretation cp_vars_rel: lens_interp "\<lambda>(ok, ok', r, r').
  (ok, ok', abrupt\<^sub>v r, abrupt\<^sub>v r', fault\<^sub>v r, fault\<^sub>v r', fault_tr\<^sub>v r, fault_tr\<^sub>v r', stuck\<^sub>v r,
   stuck\<^sub>v r',more r, more r')"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

subsubsection {*Type lifting*}

type_synonym ('f, '\<alpha>) cp = "('f, '\<alpha>) cp_vars_scheme des"
type_synonym ('f,'\<alpha>,'\<beta>) rel_cp  = "(('f,'\<alpha>) cp, ('f,'\<beta>) cp) rel"
type_synonym ('f,'\<alpha>) hrel_cp  = "(('f,'\<alpha>) cp) hrel"

subsubsection {*Syntactic type setup*}

translations
  (type) "('f,'\<alpha>) cp" <= (type) "('f, '\<alpha>) cp_vars_scheme des"
  (type) "('f,'\<alpha>) cp" <= (type) "('f, '\<alpha>) cp_vars_ext des"
  (type) "('f,'\<alpha>,'\<beta>) rel_cp" <= (type) "(('f,'\<alpha>) cp, (_,'\<beta>) cp) rel"

notation cp_vars_child_lens\<^sub>a ("\<Sigma>\<^sub>c")
notation cp_vars_child_lens ("\<Sigma>\<^sub>C")

syntax
  "_svid_st_alpha"  :: "svid" ("\<Sigma>\<^sub>C")
  "_svid_st_a"  :: "svid" ("\<Sigma>\<^sub>c")
translations
  "_svid_st_alpha" => "CONST cp_vars_child_lens"
   "_svid_st_a" => "CONST cp_vars_child_lens\<^sub>a"

lemma cvars_ord [usubst]:
  "$ok \<prec>\<^sub>v $ok\<acute>" "$abrupt \<prec>\<^sub>v $abrupt\<acute>" "$fault \<prec>\<^sub>v $fault\<acute>" "$fault_tr \<prec>\<^sub>v $fault_tr\<acute>" "$stuck \<prec>\<^sub>v $stuck\<acute>"
  "$ok \<prec>\<^sub>v $abrupt\<acute>" "$ok \<prec>\<^sub>v $abrupt" "$ok\<acute> \<prec>\<^sub>v $abrupt\<acute>" "$ok\<acute> \<prec>\<^sub>v $abrupt"
  "$ok \<prec>\<^sub>v $fault\<acute>" "$ok \<prec>\<^sub>v $fault" "$ok\<acute> \<prec>\<^sub>v $fault\<acute>" "$ok\<acute> \<prec>\<^sub>v $fault"
  "$ok \<prec>\<^sub>v $fault_tr\<acute>" "$ok \<prec>\<^sub>v $fault_tr" "$ok\<acute> \<prec>\<^sub>v $fault_tr\<acute>" "$ok\<acute> \<prec>\<^sub>v $fault_tr"
  "$ok \<prec>\<^sub>v $stuck\<acute>" "$ok \<prec>\<^sub>v $stuck" "$ok\<acute> \<prec>\<^sub>v $stuck\<acute>" "$ok\<acute> \<prec>\<^sub>v $stuck"
  "$abrupt \<prec>\<^sub>v $fault" "$abrupt \<prec>\<^sub>v $fault\<acute>" "$abrupt\<acute> \<prec>\<^sub>v $fault" "$abrupt\<acute> \<prec>\<^sub>v $fault\<acute>"
  "$abrupt \<prec>\<^sub>v $fault_tr" "$abrupt \<prec>\<^sub>v $fault_tr\<acute>" "$abrupt\<acute> \<prec>\<^sub>v $fault_tr" "$abrupt\<acute> \<prec>\<^sub>v $fault_tr\<acute>"
  "$abrupt \<prec>\<^sub>v $stuck\<acute>" "$abrupt \<prec>\<^sub>v $stuck" "$abrupt\<acute> \<prec>\<^sub>v $stuck\<acute>" "$abrupt\<acute> \<prec>\<^sub>v $stuck"
  "$fault \<prec>\<^sub>v $stuck\<acute>" "$fault \<prec>\<^sub>v $stuck" "$fault\<acute> \<prec>\<^sub>v $stuck\<acute>" "$fault\<acute> \<prec>\<^sub>v $stuck"
  "$fault_tr \<prec>\<^sub>v $stuck\<acute>" "$fault_tr \<prec>\<^sub>v $stuck" "$fault_tr\<acute> \<prec>\<^sub>v $stuck\<acute>" "$fault_tr\<acute> \<prec>\<^sub>v $stuck"
  by (simp_all add: var_name_ord_def)

abbreviation abrupt_f::"('f, '\<alpha>, '\<beta>) rel_cp \<Rightarrow> ('f, '\<alpha>, '\<beta>) rel_cp"
where "abrupt_f R \<equiv> R\<lbrakk>false/$abrupt\<rbrakk>"

abbreviation abrupt_t::"('f, '\<alpha>, '\<beta>) rel_cp \<Rightarrow> ('f, '\<alpha>, '\<beta>) rel_cp"
where "abrupt_t R \<equiv> R\<lbrakk>true/$abrupt\<rbrakk>"

abbreviation fault_f::"('f, '\<alpha>, '\<beta>) rel_cp \<Rightarrow> ('f, '\<alpha>, '\<beta>) rel_cp"
where "fault_f R \<equiv> R\<lbrakk>false/$fault\<rbrakk>"

abbreviation fault_t::"('f, '\<alpha>, '\<beta>) rel_cp \<Rightarrow> ('f, '\<alpha>, '\<beta>) rel_cp"
where "fault_t R \<equiv> R\<lbrakk>true/$fault\<rbrakk>"

abbreviation stuck_f::"('f, '\<alpha>, '\<beta>) rel_cp \<Rightarrow> ('f, '\<alpha>, '\<beta>) rel_cp"
where "stuck_f R \<equiv> R\<lbrakk>false/$stuck\<rbrakk>"

abbreviation stuck_t::"('f, '\<alpha>, '\<beta>) rel_cp \<Rightarrow> ('f, '\<alpha>, '\<beta>) rel_cp"
where "stuck_t R \<equiv> R\<lbrakk>true/$stuck\<rbrakk>"

syntax
  "_abrupt_f"  :: "logic \<Rightarrow> logic" ("_\<^sub>a\<^sub>f" [1000] 1000)
  "_abrupt_t"  :: "logic \<Rightarrow> logic" ("_\<^sub>a\<^sub>t" [1000] 1000)
  "_fault_f"  :: "logic \<Rightarrow> logic" ("_\<^sub>f\<^sub>f" [1000] 1000)
  "_fault_t"  :: "logic \<Rightarrow> logic" ("_\<^sub>f\<^sub>t" [1000] 1000)
  "_stuck_f"  :: "logic \<Rightarrow> logic" ("_\<^sub>s\<^sub>f" [1000] 1000)
  "_stuck_t"  :: "logic \<Rightarrow> logic" ("_\<^sub>s\<^sub>t" [1000] 1000)

translations
  "P \<^sub>a\<^sub>f" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ivar CONST abrupt) false) P"
  "P \<^sub>a\<^sub>t" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ivar CONST abrupt) true) P"
  "P \<^sub>f\<^sub>f" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ivar CONST fault) false) P"
  "P \<^sub>f\<^sub>t" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ivar CONST fault) true) P"
  "P \<^sub>s\<^sub>f" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ivar CONST stuck) false) P"
  "P \<^sub>s\<^sub>t" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ivar CONST stuck) true) P"

subsection {*UTP-Relations lift and drop*}

abbreviation lift_desr ("\<lceil>_\<rceil>\<^sub>C")
where "\<lceil>P\<rceil>\<^sub>C \<equiv> P \<oplus>\<^sub>p (\<Sigma>\<^sub>C \<times>\<^sub>L \<Sigma>\<^sub>C)"

abbreviation lift_pre_desr ("\<lceil>_\<rceil>\<^sub>C\<^sub><")
where "\<lceil>p\<rceil>\<^sub>C\<^sub>< \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub><\<rceil>\<^sub>C"

abbreviation lift_post_desr ("\<lceil>_\<rceil>\<^sub>C\<^sub>>")
where "\<lceil>p\<rceil>\<^sub>C\<^sub>> \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub>>\<rceil>\<^sub>C"

abbreviation drop_desr ("\<lfloor>_\<rfloor>\<^sub>C")
where "\<lfloor>P\<rfloor>\<^sub>C \<equiv> P \<restriction>\<^sub>p (\<Sigma>\<^sub>C \<times>\<^sub>L \<Sigma>\<^sub>C)"

subsection {* Reactive lemmas *}

lemma unrest_ok_lift_rea [unrest]:
  "$ok \<sharp> \<lceil>P\<rceil>\<^sub>C" "$ok\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>C"
  by (pred_auto)+

lemma unrest_abrupt_lift_rea [unrest]:
  "$abrupt \<sharp> \<lceil>P\<rceil>\<^sub>C" "$abrupt\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>C"
  by (pred_auto)+

lemma unrest_fault_lift_rea [unrest]:
  "$fault \<sharp> \<lceil>P\<rceil>\<^sub>C" "$fault\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>C"
  by (pred_auto)+

lemma unrest_stuck_lift_rea [unrest]:
  "$stuck \<sharp> \<lceil>P\<rceil>\<^sub>C" "$stuck\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>C"
  by (pred_auto)+

lemma seqr_abrupt_true [usubst]: "(P ;; Q) \<^sub>a\<^sub>t = (P \<^sub>a\<^sub>t ;; Q)"
  by (rel_auto)

lemma seqr_abrupt_false [usubst]: "(P ;; Q) \<^sub>a\<^sub>f = (P \<^sub>a\<^sub>f ;; Q)"
  by (rel_auto)

lemma seqr_fault_true [usubst]: "(P ;; Q) \<^sub>f\<^sub>t = (P \<^sub>f\<^sub>t ;; Q)"
  by (rel_auto)

lemma seqr_fault_false [usubst]: "(P ;; Q) \<^sub>f\<^sub>f = (P \<^sub>f\<^sub>f ;; Q)"
  by (rel_auto)

lemma seqr_stuck_true [usubst]: "(P ;; Q) \<^sub>s\<^sub>t = (P \<^sub>s\<^sub>t ;; Q)"
  by (rel_auto)

lemma seqr_stuck_false [usubst]: "(P ;; Q) \<^sub>s\<^sub>f = (P \<^sub>s\<^sub>f ;; Q)"
  by (rel_auto)

subsection{*Healthiness conditions*}

text {*Programs in fault or abrupt or stuck state do not progress*}
definition C3_def [upred_defs]:
  "C3(P) = (P \<triangleleft> \<not>$abrupt \<and> \<not>$fault \<and> \<not>$stuck \<and> $fault_tr =\<^sub>u \<guillemotleft>None\<guillemotright> \<triangleright> II)"

subsection{*Control flow statements*}

text{*We introduce the known control-flow statements for C. Our semantics is restricted
      to @{const C3}. In other words It assumes:
     \begin{itemize}
       \<^item>  an execution starting from initial stable state ie,@{term "$ok"},
       \<^item>  terminates a final state ie,@{term "$ok\<acute>"},
       \<^item>  the final state is a normal state ie,
          @{term "\<not>$abrupt"} and @{term "$fault_tr =\<^sub>u \<guillemotleft>None\<guillemotright>"},
     \end{itemize}
    Thus it capture Simpl semantics.
    *}

abbreviation
 "Simpl P \<equiv> C3(\<lceil>true\<rceil>\<^sub>C \<turnstile> (P))"

definition skip_c :: "('f,'\<alpha>) hrel_cp" ("SKIP")
where [urel_defs]:
  "SKIP = Simpl (\<not>$abrupt\<acute> \<and> \<not>$stuck\<acute> \<and> \<not>$fault\<acute> \<and> $fault_tr\<acute> =\<^sub>u \<guillemotleft>None\<guillemotright> \<and> \<lceil>II\<rceil>\<^sub>C)"

definition stuck_c :: "('f,'\<alpha>) hrel_cp" ("STUCK")
where [urel_defs]: "STUCK = C3($stuck\<acute>)"

definition assigns_c :: "'\<alpha> usubst \<Rightarrow> ('f,'\<alpha>) hrel_cp" ("\<langle>_\<rangle>\<^sub>C")
where [urel_defs]:
  "assigns_c \<sigma> =  C3(\<lceil>true\<rceil>\<^sub>C \<turnstile> (\<not>$abrupt\<acute> \<and> \<not>$stuck\<acute> \<and> \<not>$fault\<acute> \<and> $fault_tr\<acute> =\<^sub>u \<guillemotleft>None\<guillemotright> \<and> \<lceil>\<langle>\<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>C))"

subsection{*THROW*}

definition throw_c :: "('f,'\<alpha>) hrel_cp" ("THROW")
where [urel_defs]:
  "THROW = Simpl ($abrupt\<acute> \<and> \<not>$stuck\<acute> \<and> \<not>$fault\<acute> \<and> $fault_tr\<acute> =\<^sub>u \<guillemotleft>None\<guillemotright> \<and> \<lceil>II\<rceil>\<^sub>C)"

subsection{*Conditional*}

abbreviation If_c :: "'\<alpha> cond \<Rightarrow>('f,'\<alpha>) hrel_cp \<Rightarrow> ('f,'\<alpha>) hrel_cp \<Rightarrow> ('f,'\<alpha>) hrel_cp" ("bif (_)/ then (_) else (_) eif")where
  "If_c b P Q \<equiv> (P \<triangleleft> \<lceil>b\<rceil>\<^sub>C\<^sub>< \<triangleright> Q)"

subsection{*GUARD*}

abbreviation guard_c :: "'f \<Rightarrow> '\<alpha> cond \<Rightarrow> ('f,'\<alpha>) hrel_cp"
where "guard_c f b \<equiv>
      (bif b then SKIP else (\<not>$abrupt\<acute> \<and> \<not>$stuck\<acute> \<and> $fault\<acute> \<and> $fault_tr\<acute> =\<^sub>u \<guillemotleft>Some f\<guillemotright> \<and> \<lceil>II\<rceil>\<^sub>C) eif)"

subsection{*assert and assume*}

definition rassume_c :: "'\<alpha> upred \<Rightarrow> ('f,'\<alpha>) hrel_cp" ("_\<^sup>\<top>\<^sup>C" [999] 999) where
[urel_defs]: "rassume_c c = (bif c then SKIP else \<top>\<^sub>D eif)"

definition rassert_c :: "'\<alpha> upred \<Rightarrow> ('f,'\<alpha>) hrel_cp" ("_\<^sub>\<bottom>\<^sub>C" [999] 999) where
[urel_defs]: "rassert_c c = (bif c then SKIP else \<bottom>\<^sub>D eif)"

subsection{*Exceptions*}

abbreviation catch_c :: "('f,'\<alpha>) hrel_cp \<Rightarrow> ('f,'\<alpha>) hrel_cp \<Rightarrow> ('f,'\<alpha>) hrel_cp" ("try (_) catch /(_) end")
where "try P catch Q end \<equiv> (P ;; ((abrupt:== (\<not> &abrupt) ;;Q) \<triangleleft> $abrupt \<triangleright> II))"

subsection{*Scoping*}

definition block_c ("bob INIT (_) BODY /(_) RESTORE /(_) RETURN/(_) eob") where
[urel_defs]:
  "bob INIT init BODY body RESTORE restore RETURN return eob=
    (Abs_uexpr (\<lambda>(s, s').
     \<lbrakk>init ;; body ;; Abs_uexpr (\<lambda>(t, t').
                       \<lbrakk>(abrupt:== (\<not> &abrupt) ;;restore (s, s') (t, t');; THROW) \<triangleleft> $abrupt \<triangleright> II;;
         restore (s, s') (t, t');; return(s, s') (t, t')\<rbrakk>\<^sub>e (t, t'))\<rbrakk>\<^sub>e (s, s')))"

subsection{*Loops*}
purge_notation while ("while\<^sup>\<top> _ do _ od")

definition While :: "'\<alpha> cond \<Rightarrow> ('f,'\<alpha>) hrel_cp \<Rightarrow> ('f,'\<alpha>) hrel_cp" ("while\<^sup>\<top> _ do _ od") where
"While b C = (\<nu> X \<bullet> bif b then (C ;; X) else SKIP eif)"

purge_notation while_top ("while _ do _ od")

abbreviation While_top :: "'\<alpha> cond \<Rightarrow> ('f,'\<alpha>) hrel_cp \<Rightarrow>  ('f,'\<alpha>) hrel_cp" ("while _ do _ od") where
"while b do P od \<equiv> while\<^sup>\<top> b do P od"

purge_notation while_bot ("while\<^sub>\<bottom> _ do _ od")

definition While_bot :: "'\<alpha> cond \<Rightarrow> ('f,'\<alpha>) hrel_cp \<Rightarrow> ('f,'\<alpha>) hrel_cp" ("while\<^sub>\<bottom> _ do _ od") where
"while\<^sub>\<bottom> b do P od =  (\<mu> X \<bullet> bif b then (P ;; X) else SKIP eif)"

subsection{*While-loop inv*}
text {* While loops with invariant decoration *}

purge_notation while_inv ("while _ invr _ do _ od" 70)

definition While_inv :: "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> ('f,'\<alpha>) hrel_cp \<Rightarrow> ('f,'\<alpha>) hrel_cp" ("while _ invr _ do _ od" 70) where
"while b invr p do S od = while b do S od"

declare While_def [urel_defs]
declare While_inv_def [urel_defs]
declare While_bot_def [urel_defs]

syntax
  "_assignmentc" :: "svid_list \<Rightarrow> uexprs \<Rightarrow> logic"  (infixr "\<Midarrow>" 55)

translations
  "_assignmentc xs vs" => "CONST assigns_c (_mk_usubst (CONST id) xs vs)"
  "x \<Midarrow> v" <= "CONST assigns_c (CONST subst_upd (CONST id) (CONST svar x) v)"
  "x \<Midarrow> v" <= "CONST assigns_c (CONST subst_upd (CONST id) x v)"
  "x,y \<Midarrow> u,v" <= "CONST assigns_c (CONST subst_upd (CONST subst_upd (CONST id) (CONST svar x) u) (CONST svar y) v)"

end


section \<open>Equivalence of a Diamond-Shaped Relaying Network and a Cross-Shaped Broadcasting Network\<close>

theory "Network_Equivalences-Diamond-Relaying_Broadcasting"
  imports "Network_Equivalences-Diamond-Foundations"
begin

abbreviation diamond_receiving_and_relaying where
  "diamond_receiving_and_relaying r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<equiv>
    \<comment> \<open>Link 0--1:\<close> l\<^sub>0\<^sub>1 \<Rightarrow> [r\<^sub>1, l\<^sub>1\<^sub>3] \<parallel>
    \<comment> \<open>Link 0--2:\<close> l\<^sub>0\<^sub>2 \<Rightarrow> [r\<^sub>2, l\<^sub>2\<^sub>3] \<parallel>
    \<comment> \<open>Link 1--3:\<close> l\<^sub>1\<^sub>3 \<Rightarrow> [r\<^sub>3, l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Link 2--3:\<close> l\<^sub>2\<^sub>3 \<Rightarrow> [r\<^sub>3, l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Link 3--0:\<close> l\<^sub>3\<^sub>0 \<Rightarrow> [r\<^sub>0, l\<^sub>0\<^sub>1, l\<^sub>0\<^sub>2]"

abbreviation diamond  where
  "diamond s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 \<equiv>
    \<nu> l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0. (
      \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
      diamond_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
      diamond_receiving_and_relaying r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0)
    )"

abbreviation cross where
  "cross s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 \<equiv>
    \<nu> m. (
      \<currency>\<^sup>* (\<box> m) \<parallel>
      cross_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> m) \<parallel>
      cross_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> m)
    )"

lemma untangling:
  shows "
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<currency>\<^sup>*l\<^sub>0\<^sub>1 \<parallel> \<currency>\<^sup>*l\<^sub>0\<^sub>2 \<parallel> \<currency>\<^sup>*l\<^sub>1\<^sub>3 \<parallel> \<currency>\<^sup>*l\<^sub>2\<^sub>3 \<parallel> \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel>
    diamond_receiving_and_relaying r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0
    \<approx>\<^sub>s
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<currency>\<^sup>*l\<^sub>0\<^sub>1 \<parallel> \<currency>\<^sup>*l\<^sub>0\<^sub>2 \<parallel> \<currency>\<^sup>*l\<^sub>1\<^sub>3 \<parallel> \<currency>\<^sup>*l\<^sub>2\<^sub>3 \<parallel> \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel>
    diamond_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<parallel>
    initial_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0"
    (is "?p \<approx>\<^sub>s ?q")
proof -
  have "?p \<approx>\<^sub>s
    \<comment> \<open>Link 0--1:\<close> (\<currency>\<^sup>+l\<^sub>0\<^sub>1 \<parallel> \<Prod>a\<leftarrow>[r\<^sub>1, l\<^sub>1\<^sub>3]. \<currency>\<^sup>?a \<parallel> l\<^sub>0\<^sub>1 \<Rightarrow> [r\<^sub>1, l\<^sub>1\<^sub>3]) \<parallel>
    \<comment> \<open>Link 0--2:\<close> (\<currency>\<^sup>+l\<^sub>0\<^sub>2 \<parallel> \<Prod>a\<leftarrow>[r\<^sub>2, l\<^sub>2\<^sub>3]. \<currency>\<^sup>?a \<parallel> l\<^sub>0\<^sub>2 \<Rightarrow> [r\<^sub>2, l\<^sub>2\<^sub>3]) \<parallel>
    \<comment> \<open>Link 1--3:\<close> (\<currency>\<^sup>+l\<^sub>1\<^sub>3 \<parallel> \<Prod>a\<leftarrow>[r\<^sub>3, l\<^sub>3\<^sub>0]. \<currency>\<^sup>?a \<parallel> l\<^sub>1\<^sub>3 \<Rightarrow> [r\<^sub>3, l\<^sub>3\<^sub>0]) \<parallel>
    \<comment> \<open>Link 2--3:\<close> (\<currency>\<^sup>+l\<^sub>2\<^sub>3 \<parallel> \<Prod>a\<leftarrow>[r\<^sub>3, l\<^sub>3\<^sub>0]. \<currency>\<^sup>?a \<parallel> l\<^sub>2\<^sub>3 \<Rightarrow> [r\<^sub>3, l\<^sub>3\<^sub>0]) \<parallel>
    \<comment> \<open>Link 3--0:\<close> (\<currency>\<^sup>+l\<^sub>3\<^sub>0 \<parallel> \<Prod>a\<leftarrow>[r\<^sub>0, l\<^sub>0\<^sub>1, l\<^sub>0\<^sub>2]. \<currency>\<^sup>?a \<parallel> l\<^sub>3\<^sub>0 \<Rightarrow> [r\<^sub>0, l\<^sub>0\<^sub>1, l\<^sub>0\<^sub>2])"
    unfolding duploss_def and general_parallel.simps using thorn_simps by equivalence
  also have "\<dots> \<approx>\<^sub>s
    \<comment> \<open>Link 0--1:\<close> (\<currency>\<^sup>+l\<^sub>0\<^sub>1 \<parallel> \<Prod>a\<leftarrow>[r\<^sub>1, l\<^sub>1\<^sub>3]. \<currency>\<^sup>?a \<parallel> \<Prod>a\<leftarrow>[r\<^sub>1, l\<^sub>1\<^sub>3]. l\<^sub>0\<^sub>1 \<rightarrow> a) \<parallel>
    \<comment> \<open>Link 0--2:\<close> (\<currency>\<^sup>+l\<^sub>0\<^sub>2 \<parallel> \<Prod>a\<leftarrow>[r\<^sub>2, l\<^sub>2\<^sub>3]. \<currency>\<^sup>?a \<parallel> \<Prod>a\<leftarrow>[r\<^sub>2, l\<^sub>2\<^sub>3]. l\<^sub>0\<^sub>2 \<rightarrow> a) \<parallel>
    \<comment> \<open>Link 1--3:\<close> (\<currency>\<^sup>+l\<^sub>1\<^sub>3 \<parallel> \<Prod>a\<leftarrow>[r\<^sub>3, l\<^sub>3\<^sub>0]. \<currency>\<^sup>?a \<parallel> \<Prod>a\<leftarrow>[r\<^sub>3, l\<^sub>3\<^sub>0]. l\<^sub>1\<^sub>3 \<rightarrow> a) \<parallel>
    \<comment> \<open>Link 2--3:\<close> (\<currency>\<^sup>+l\<^sub>2\<^sub>3 \<parallel> \<Prod>a\<leftarrow>[r\<^sub>3, l\<^sub>3\<^sub>0]. \<currency>\<^sup>?a \<parallel> \<Prod>a\<leftarrow>[r\<^sub>3, l\<^sub>3\<^sub>0]. l\<^sub>2\<^sub>3 \<rightarrow> a) \<parallel>
    \<comment> \<open>Link 3--0:\<close> (\<currency>\<^sup>+l\<^sub>3\<^sub>0 \<parallel> \<Prod>a\<leftarrow>[r\<^sub>0, l\<^sub>0\<^sub>1, l\<^sub>0\<^sub>2]. \<currency>\<^sup>?a \<parallel> \<Prod>a\<leftarrow>[r\<^sub>0, l\<^sub>0\<^sub>1, l\<^sub>0\<^sub>2]. l\<^sub>3\<^sub>0 \<rightarrow> a)"
    using distributor_split by equivalence
  also have "\<dots> \<approx>\<^sub>s ?q"
    unfolding duploss_def and general_parallel.simps using thorn_simps by equivalence
  finally show ?thesis .
qed

theorem diamond_cross_equivalence:
  shows "
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    diamond s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3
    \<approx>\<^sub>s
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    cross s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3"
proof -
  have "
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
      diamond_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
      diamond_receiving_and_relaying r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0)
    )
    \<approx>\<^sub>s
    \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      diamond_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
      (
        \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
      \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
        diamond_receiving_and_relaying r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0)
      )
    )"
    using thorn_simps sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  also have "\<dots> \<approx>\<^sub>s
    \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      diamond_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
      (
        \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
        \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
        diamond_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
        initial_core (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0)
      )
    )"
    using untangling sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
      diamond_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
      diamond_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
      initial_core (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0)
    )"
    using thorn_simps sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
      diamond_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
      diamond_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
      transformed_core (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0)
    )"
    using core_transformation sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
      diamond_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
      (
        transformed_core (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
        diamond_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0)
      )
    )"
    using thorn_simps sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
      diamond_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
      (
        transformed_core (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
        cross_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>3\<^sub>0)
      )
    )"
    using receiving_collapse sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
      cross_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>3\<^sub>0) \<parallel>
      (
        \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
        transformed_core (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
        diamond_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0)
      )
    )"
    using thorn_simps sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
      cross_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>3\<^sub>0) \<parallel>
      (
        \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
        transformed_core (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0) \<parallel>
        cross_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>3\<^sub>0)
      )
    )"
    using sending_collapse sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      cross_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>3\<^sub>0) \<parallel>
      cross_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>3\<^sub>0) \<parallel>
      (
        \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
        \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. (
          \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
          transformed_core (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) (\<box> l\<^sub>3\<^sub>0)
        )
      )
    )"
    using thorn_simps sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      cross_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>3\<^sub>0) \<parallel>
      cross_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>3\<^sub>0) \<parallel>
      \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0)
    )"
    unfolding tagged_new_channel_def using core_collapse sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    \<langle>4\<rangle> \<nu> l\<^sub>3\<^sub>0. (
      \<currency>\<^sup>* (\<box> l\<^sub>3\<^sub>0) \<parallel>
      cross_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 (\<box> l\<^sub>3\<^sub>0) \<parallel>
      cross_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 (\<box> l\<^sub>3\<^sub>0)
    )"
    using thorn_simps sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  finally show ?thesis unfolding tagged_new_channel_def .
qed

end


section \<open>Intuitionistic first-order logic\<close>

theory betterFOL
imports Pure
begin

ML \<open>\<^assert> (not (can ML \<open>open RunCall\<close>))\<close>
ML_file \<open>~~/src/Tools/misc_legacy.ML\<close>
ML_file \<open>~~/src/Provers/splitter.ML\<close>
ML_file \<open>~~/src/Provers/hypsubst.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/zipper.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/isand.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/rw_inst.ML\<close>
ML_file \<open>~~/src/Provers/quantifier1.ML\<close>
ML_file \<open>~~/src/Tools/intuitionistic.ML\<close>
ML_file \<open>~~/src/Tools/project_rule.ML\<close>
ML_file \<open>~~/src/Tools/atomize_elim.ML\<close>

subsection \<open>Syntax and axiomatic basis\<close>

setup Pure_Thy.old_appl_syntax_setup

class "term"
default_sort \<open>term\<close>

typedecl o

judgment
  Trueprop :: \<open>o \<Rightarrow> prop\<close>  (\<open>(_)\<close> 5)

subsubsection \<open>Equality\<close>

axiomatization
  eq :: \<open>['a, 'a] \<Rightarrow> o\<close>  (infixl \<open>=\<close> 50)
where
  refl: \<open>a = a\<close> and
  subst: \<open>a = b \<Longrightarrow> P(a) \<Longrightarrow> P(b)\<close>

subsubsection \<open>Propositional logic\<close>

axiomatization
  False :: \<open>o\<close> and
  conj :: \<open>[o, o] => o\<close>  (infixr \<open>\<and>\<close> 35) and
  disj :: \<open>[o, o] => o\<close>  (infixr \<open>\<or>\<close> 30) and
  imp :: \<open>[o, o] => o\<close>  (infixr \<open>\<longrightarrow>\<close> 25)

axiomatization
where
  mp: \<open>\<lbrakk>P \<longrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q\<close> and
  a1: \<open>A \<longrightarrow> (B \<longrightarrow> A)\<close> and
  a2: \<open>(A \<longrightarrow> (B \<longrightarrow> C))\<longrightarrow>((A \<longrightarrow> B)\<longrightarrow>(A \<longrightarrow> C))\<close>

theorem Ded: \<open>(P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q\<close>

(*

  conjI: \<open>\<lbrakk>P;  Q\<rbrakk> \<Longrightarrow> P \<and> Q\<close> and
  conjunct1: \<open>P \<and> Q \<Longrightarrow> P\<close> and
  conjunct2: \<open>P \<and> Q \<Longrightarrow> Q\<close> and

  disjI1: \<open>P \<Longrightarrow> P \<or> Q\<close> and
  disjI2: \<open>Q \<Longrightarrow> P \<or> Q\<close> and
  disjE: \<open>\<lbrakk>P \<or> Q; P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R\<close> and

  impI: \<open>(P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q\<close> and
  mp: \<open>\<lbrakk>P \<longrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q\<close> and

  FalseE: \<open>False \<Longrightarrow> P\<close>
*)


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

theory signedoverflow
imports "CParser.CTranslation"
begin

external_file "signedoverflow.c"
install_C_file "signedoverflow.c"

context signedoverflow
begin

thm f_body_def

(* painful lemma about sint and word arithmetic results...
lemma j0: "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> Call f_'proc \<lbrace> \<acute>ret__int = 0 \<rbrace>"
apply vcg
apply simp_all
apply auto
*)

thm g_body_def

lemma "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL g(1) \<lbrace> \<acute>ret__int = - 1 \<rbrace>"
apply vcg
apply (simp add: word_sle_def)
done

lemma "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL g(- 2147483648) \<lbrace> \<acute>ret__int = - 1 \<rbrace>"
apply vcg
apply (simp add: word_sle_def)
done

lemma "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL g(- 2147483647) \<lbrace> \<acute>ret__int = 2147483647 \<rbrace>"
apply vcg
apply (simp add: word_sle_def)
done

end (* context *)

end (* theory *)


theory MainHC
imports Main
begin

-- "we need full proof object support to use translate_thm later on"
ML {* proofs := 2 *}

types 'a partial = "'a option"

(* negation of is_none *)
primrec defOp :: "'a partial => bool"
where
"defOp None = False" |
"defOp (Some x) = True"

definition makeTotal :: "'a partial => 'a"
where "makeTotal == the"

definition makePartial :: "'a => 'a partial"
where "makePartial == Some"

(* undefined is predefined *)
definition undefinedOp :: "'a partial"
where "undefinedOp == None"

(* backward compatibility only *)
definition noneOp :: "'a partial"
where "noneOp == undefinedOp"

definition restrictOp :: "'a partial => bool => 'a partial"
where "restrictOp a b == if b then a else undefinedOp"

(* utilities *)
definition flip :: "('a => 'b => 'c) => 'b => 'a => 'c"
where "flip f a b == f b a"

definition uncurryOp :: "('a => 'b => 'c) => 'a * 'b => 'c"
where "uncurryOp f p == f (fst p) (snd p)"

definition curryOp :: "('a * 'b => 'c) => 'a => 'b => 'c"
where "curryOp f a b == f (a, b)"

(* map on pairs *)
definition mapFst :: "('a => 'b) => 'a * 'c => 'b * 'c"
where "mapFst f p == (f (fst p), snd p)"

definition mapSnd :: "('b => 'c) => 'a * 'b => 'a * 'c"
where "mapSnd f p == (fst p, f (snd p))"

(* predefined HasCASL functions *)
definition ifImplOp :: "bool * bool => bool"
where "ifImplOp p == snd p --> fst p"

definition existEqualOp :: "'a partial => 'a partial => bool"
  ("(_ =e=/ _)" [50, 51] 50)
where "existEqualOp a b == defOp a & defOp b & makeTotal a = makeTotal b"

definition exEqualOp :: "'a partial * 'a partial => bool"
where "exEqualOp == uncurryOp existEqualOp"

definition strongEqualOp :: "'a partial => 'a partial => bool"
  ("(_ =s=/ _)" [50, 51] 50)
where "strongEqualOp a b == a = b"

definition whenElseOp :: "('a partial * bool) * 'a partial => 'a partial"
where "whenElseOp t == case t of
    (p, e) => if snd p then fst p else e"

(*resOp :: "'a partial * 'b partial => 'a"
"resOp p == makeTotal (restrictOp (fst p) (defOp (snd p)))"*)

definition resOp :: "'a partial * 'b partial => 'a partial"
where  "resOp p == restrictOp (fst p) (defOp (snd p))"

(* conversions *)
definition lift2partial :: "('a => 'b partial) => 'a partial => 'b partial"
where "lift2partial f s == restrictOp (f (makeTotal s)) (defOp s)"

definition mapPartial :: "('a => 'b) => 'a partial => 'b partial"
where "mapPartial f s == restrictOp (makePartial (f (makeTotal s))) (defOp s)"

definition unpackPartial :: "(('a => 'b) => 'c => 'd partial)
            => ('a => 'b) partial => 'c => 'd partial"
where "unpackPartial c s a == lift2partial (flip c a) s"

definition unpackBool :: "(('a => 'b) => 'c => bool)
            => ('a => 'b) partial => 'c => bool"
where "unpackBool c s a == defOp s & c (makeTotal s) a"

definition unpack2partial :: "(('a => 'b) => 'c => 'd)
            => ('a => 'b) partial => 'c => 'd partial"
where "unpack2partial c s a == mapPartial (flip c a) s"

definition unpack2bool :: "(('a => 'b) => 'c => 'd)
            => ('a => 'b) partial => 'c => bool"
where "unpack2bool c s a == defOp s"

definition bool2partial :: "bool => unit partial"
where "bool2partial b == restrictOp (makePartial ()) b"

definition liftUnit2unit :: "('a => 'b) => bool => bool"
where "liftUnit2unit f b == b"

definition liftUnit2bool :: "(unit => bool) => bool => bool"
where "liftUnit2bool f b == b & f ()"

definition liftUnit2partial :: "(unit => 'a partial) => bool => 'a partial"
where "liftUnit2partial f b == restrictOp (f ()) b"

definition liftUnit :: "(unit => 'a) => bool => 'a partial"
where "liftUnit f b ==restrictOp (makePartial (f ())) b"

definition lift2unit :: "('b => 'c) => ('a partial => bool)"
where "lift2unit f == defOp"

definition lift2bool :: "('a => bool) => 'a partial => bool"
where "lift2bool f s == defOp s & f (makeTotal s)"

(* old stuff *)
primrec app :: "('a => 'b option) option => 'a option => 'b option"
where
  "app None a = None" |
  "app (Some f) x = (case x of
                            None => None
                          | Some x' => f x')"

primrec apt :: "('a => 'b) option => 'a option => 'b option"
where
  "apt None a = None" |
  "apt (Some f) x = (case x of
                            None => None
                          | Some x' => Some (f x'))"

primrec pApp :: "('a => bool) option => 'a option => bool"
where
  "pApp None a = False" |
  "pApp (Some f) x = (case x of
                             None => False
                           | Some y => f y)"

primrec pair :: "'a option => 'b option => ('a * 'b) option"
where
  "pair None a = None" |
  "pair (Some x) z = (case z of
                             None => None
                           | Some y => Some (x,y))"

lemma some_inj : "Some x = Some y ==> x = y"
apply (auto)
done

(* Monad law added by Lutz Schroeder *)

lemma partial_monad_unit1[simp]: "lift2partial f (makePartial a) = f a"
apply (simp add: lift2partial_def makePartial_def restrictOp_def makeTotal_def)
done

lemma partial_monad_unit2[simp]: "lift2partial makePartial m = m"
apply (auto simp add: lift2partial_def makePartial_def restrictOp_def makeTotal_def undefinedOp_def)
apply (case_tac "m")
apply (auto)
apply (case_tac "m")
apply (auto)
done

lemma partial_monad_assoc[simp]:
  "lift2partial g (lift2partial f m) =
  lift2partial (%x. lift2partial g (f x)) m"
apply (simp add: lift2partial_def makePartial_def restrictOp_def makeTotal_def undefinedOp_def)
done

lemma strictness_closure:
  "defOp (lift2partial f a) = (defOp (lift2partial f a) & defOp a)"
apply (simp add: lift2partial_def makePartial_def restrictOp_def makeTotal_def undefinedOp_def)
done

(*
   Identities added by Ewaryst Schulz
*)
(*
lemma defOp_implies_makePartial:
"defOp(x :: 'a partial) ==> (EX (y :: 'a). x = makePartial y)"
-- "for isabelle 2009"
  by (rule Option.option.exhaust [of x], simp, simp add: exI makePartial_def)
-- "for isabelle 2008"
 by (rule Datatype.option.exhaust [of x], simp, simp add: exI makePartial_def)
-- "for both versions:"
  sorry
*)

axioms

defOp_implies_makePartial:
"defOp(x :: 'a partial) ==> (EX (y :: 'a). x = makePartial y)"

-- "need this to expand a term for application of lemmas"
lemma partial_identity: "!!x. makeTotal(makePartial(x)) = x"
  by (simp add: makeTotal_def makePartial_def)

consts preDefOp :: "'a partial => bool"

axioms

preDefOp_atom[simp]: "preDefOp a = defOp a"

preDefOp_lift[simp]:
"preDefOp (lift2partial f a) = (defOp (lift2partial f a) & preDefOp a)"

end


section \<open>Independence of IMAP Commands\<close>

text\<open>In this section we show that two concurrent operations that reference to the same tag must be
identical.\<close>

theory
  "IMAP-proof-independent"
  imports
    "IMAP-def"
    "IMAP-proof-helpers"
begin

lemma (in imap) Broadcast_Expunge_Deliver_prefix_closed:
  assumes "xs @ [Broadcast (i, Expunge e mo i)] prefix of j"
  shows "Deliver (mo, Append mo e) \<in> set xs \<or>
    (\<exists> mo2 . Deliver (mo, Store e mo2 mo) \<in> set xs)"
proof -
  obtain y where "apply_operations xs = Some y"
    using assms broadcast_only_valid_msgs by blast
  moreover hence "mo \<in> snd (y e)"
    using broadcast_only_valid_msgs[of xs "(i, Expunge e mo i)" j]
      valid_behaviours_def[of y "(i, Expunge e mo i)"] assms by auto
  ultimately show ?thesis
    using assms Deliver_added_files apply_operations_added_files by blast
qed

lemma (in imap) Broadcast_Store_Deliver_prefix_closed:
  assumes "xs @ [Broadcast (i, Store e mo i)] prefix of j"
  shows "Deliver (mo, Append mo e) \<in> set xs \<or>
    (\<exists> mo2 . Deliver (mo, Store e mo2 mo) \<in> set xs)"
proof -
  obtain y where "apply_operations xs = Some y"
    using assms broadcast_only_valid_msgs by blast
  moreover hence "mo \<in> snd (y e)"
    using broadcast_only_valid_msgs[of xs "(i, Store e mo i)" j]
      valid_behaviours_def[of y "(i, Store e mo i)"] assms by auto
  ultimately show ?thesis
    using assms Deliver_added_files apply_operations_added_files by blast
qed

lemma (in imap) Deliver_added_ids:
  assumes "xs prefix of j"
    and "i \<in> set (added_ids xs e)"
  shows "Deliver (i, Create i e) \<in> set xs \<or>
    (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set xs)"
  using assms proof (induct xs rule: rev_induct, clarsimp)
  case (snoc x xs) thus ?case
  proof (cases x, force)
    case X: (Deliver e')
    moreover obtain a b where "e' = (a, b)" by force
    ultimately show ?thesis
      using snoc apply (case_tac b; clarify)
          apply (simp, metis added_ids_Deliver_Create_diff_collapse
          added_ids_Deliver_Create_same_collapse empty_iff list.set(1) set_ConsD create_id_valid
          in_set_conv_decomp prefix_of_appendD, force)
      using append_id_valid apply (simp, metis (no_types, lifting)  prefix_of_appendD, simp, metis
          Un_iff added_ids_Deliver_Expunge_diff_collapse added_ids_Deliver_Expunge_same_collapse
          empty_iff expunge_id_valid list.set(1) list.set_intros(1) prefix_of_appendD set_ConsD
          set_append)
      by (simp, blast)
  qed
qed

lemma (in imap) Broadcast_Deliver_prefix_closed:
  assumes "xs @ [Broadcast (r, Delete ix e)] prefix of j"
    and "i \<in> ix"
  shows "Deliver (i, Create i e) \<in> set xs \<or>
    Deliver (i, Append i e) \<in> set xs \<or>
    (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set xs) \<or>
    (\<exists> mo . Deliver (i, Store e mo i) \<in> set xs)"
proof -
  obtain y where "apply_operations xs = Some y"
    using assms broadcast_only_valid_msgs by blast
  moreover hence "ix = fst (y e) \<union> snd (y e)"
    by (metis (mono_tags, lifting) assms(1) broadcast_only_valid_msgs operation.case(2)
        option.simps(1) valid_behaviours_def case_prodD)
  ultimately show ?thesis
    using assms Deliver_added_ids apply_operations_added_ids
    by (metis Deliver_added_files Un_iff apply_operations_added_files le_iff_sup prefix_of_appendD)
qed

lemma (in imap) concurrent_create_delete_independent_technical:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Create i e) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Create i e) (ir, Delete is e)"
proof -
  have f1: "Deliver (i, Create i e) \<in> set (history j)"
    using assms prefix_msg_in_history by blast
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f2: "Deliver (i, Create i e) \<in> set pre \<or>
                  Deliver (i, Append i e) \<in> set pre \<or>
                  (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set pre) \<or>
                  (\<exists> mo . Deliver (i, Store e mo i) \<in> set pre)"
    using Broadcast_Deliver_prefix_closed assms by auto
  have f3: "Deliver (i, Append i e) \<notin> set pre" using f1 P
    by (metis (full_types) Pair_inject fst_conv network.delivery_has_a_cause network.msg_id_unique
        network_axioms operation.simps(9) prefix_elem_to_carriers prefix_of_appendD)
  have f4: "\<forall> mo . Deliver (i, Expunge e mo i) \<notin> set pre" using f1 P
    by (metis delivery_has_a_cause fst_conv msg_id_unique old.prod.inject operation.simps(11)
        prefix_elem_to_carriers prefix_of_appendD)
  have "\<forall> mo . Deliver (i, Store e mo i) \<notin> set pre" using f1 P
    by (metis delivery_has_a_cause fst_conv msg_id_unique old.prod.inject operation.simps(13)
        prefix_elem_to_carriers prefix_of_appendD)
  thus ?thesis using f2 f3 f4  P events_in_local_order hb_deliver by blast
qed

lemma (in imap) concurrent_store_expunge_independent_technical:
  assumes "xs prefix of j"
    and "(i, Store e mo i) \<in> set (node_deliver_messages xs)"
    and "(r, Expunge e i r) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Store e mo i) (r, Expunge e i r)"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Expunge e i r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence f1: "Deliver (i, Append i e) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (i, Store e mo2 i) \<in> set pre)"
    using Broadcast_Expunge_Deliver_prefix_closed assms(1) by auto
  hence f2: "Deliver (i, Append i e) \<notin> set (history k)"
    by (metis Pair_inject assms(1) assms(2) fst_conv msg_id_unique network.delivery_has_a_cause
        network_axioms operation.distinct(17) prefix_msg_in_history)
  from f1 obtain mo2 :: 'a where
    "Deliver (i, Store e mo2 i) \<in> set (history k)" using f2
    using P prefix_elem_to_carriers by blast
  hence "Deliver (i, Store e mo i) \<in> set (history k)" using assms f1 f2 P
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms
        prefix_msg_in_history)
  then show ?thesis
    using hb.intros(2) events_in_local_order f1 f2 P
    by (metis delivery_has_a_cause fst_conv msg_id_unique node_histories.prefix_of_appendD
        node_histories_axioms prefix_elem_to_carriers)
qed

lemma (in imap) concurrent_store_expunge_independent_technical2:
  assumes "xs prefix of j"
    and "(i, Store e1 mo2 i) \<in> set (node_deliver_messages xs)"
    and "(r, Expunge e mo r) \<in> set (node_deliver_messages xs)"
  shows "mo2 \<noteq> r"
proof -
  obtain oid :: "'a \<times> ('a, 'b) operation \<Rightarrow> nat" where
    oid: "\<forall>p n. Deliver p \<notin> set (history n) \<or> Broadcast p \<in> set (history (oid p))"
    by (metis (no_types) delivery_has_a_cause)
  hence f1: "Broadcast (r, Expunge e mo r) \<in> set (history (oid (r, Expunge e mo r)))"
    using assms(1) assms(3) prefix_msg_in_history by blast
  obtain k :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<times> ('a, 'b) operation) event list \<Rightarrow> 'a" where k:
    "\<forall>i e pre. (\<exists>mo. Deliver (i, Store e mo i) \<in> set pre) =
    (Deliver (i, Store e (k i e pre) i) \<in> set pre)"
    by moura
  obtain pre :: "nat \<Rightarrow> ('a \<times> ('a, 'b) operation) event \<Rightarrow> ('a \<times> ('a, 'b) operation) event list"
    where pre: "\<forall>k op1. (\<exists>op2. op2 @ [op1] prefix of k) = (pre k op1 @ [op1] prefix of k)"
    by moura
  hence f2: "\<forall>e n. e \<notin> set (history n) \<or> pre n e @ [e] prefix of n"
    using events_before_exist by simp
  hence f3: "pre (oid (i, Store e1 mo2 i)) (Broadcast (i, Store e1 mo2 i))
  prefix of oid (i, Store e1 mo2 i)"
    using oid  assms(1) assms(2) prefix_msg_in_history by blast
  have f4: "Deliver (r, Append r e1) \<notin> set (history (oid (i, Store e1 mo2 i)))"
    by (metis (no_types) oid f1 fst_conv msg_id_unique old.prod.inject operation.distinct(15))
  have "Deliver (r, Store e1 (k r e1 (pre (oid (i, Store e1 mo2 i))
  (Broadcast (i, Store e1 mo2 i)))) r) \<notin> set (history (oid (i, Store e1 mo2 i)))"
    by (metis (no_types) oid f1 fst_conv msg_id_unique old.prod.inject operation.distinct(19))
  thus ?thesis using oid k f2 f3 f4 assms
    by (metis (no_types, lifting) Broadcast_Store_Deliver_prefix_closed
        network.prefix_msg_in_history network_axioms prefix_elem_to_carriers)
qed

lemma (in imap) concurrent_store_delete_independent_technical:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Store e mo i) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Store e mo i) (ir, Delete is e)"
proof -
  have f1: "Deliver (i, Store e mo i) \<in> set (history j)" using assms prefix_msg_in_history by auto
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f2: "Deliver (i, Create i e) \<in> set pre \<or>
  Deliver (i, Append i e) \<in> set pre \<or>
  (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set pre) \<or>
  (\<exists> mo . Deliver (i, Store e mo i) \<in> set pre)"
    using Broadcast_Deliver_prefix_closed assms(1) by auto
  have f3: "Deliver (i, Create i e) \<notin> set pre" using f1 P
    by (metis Pair_inject delivery_has_a_cause fst_conv msg_id_unique operation.distinct(7)
        prefix_elem_to_carriers prefix_of_appendD)
  have f4: "Deliver (i, Append i e) \<notin> set pre" using f1 P
    by (metis delivery_has_a_cause fst_conv msg_id_unique operation.distinct(17)
        prefix_elem_to_carriers prefix_of_appendD prod.inject)
  have "\<forall> mo . Deliver (i, Expunge e mo i) \<notin> set pre" using f1 P
    by (metis Pair_inject delivery_has_a_cause fst_conv msg_id_unique operation.simps(25)
        prefix_elem_to_carriers prefix_of_appendD)
  hence "Deliver (i, Store e mo i) \<in> set pre" using f1 f2 f3 f4 P
    by (metis delivery_has_a_cause fst_conv msg_id_unique node_histories.prefix_of_appendD
        node_histories_axioms prefix_elem_to_carriers)
  thus ?thesis using P events_in_local_order hb_deliver by blast
qed

lemma (in imap) concurrent_append_delete_independent_technical:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Append i e) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Append i e) (ir, Delete is e)"
proof -
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f1: "Deliver (i, Create i e) \<in> set pre \<or>
  Deliver (i, Append i e) \<in> set pre \<or>
  (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set pre) \<or>
  (\<exists> mo . Deliver (i, Store e mo i) \<in> set pre)"
    using Broadcast_Deliver_prefix_closed assms(1) by auto
  hence "Deliver (i, Append i e) \<in> set pre" using assms P f1
    by (metis (no_types, hide_lams) delivery_has_a_cause events_in_local_order fst_conv
        hb_broadcast_exists1 hb_deliver msg_id_unique prefix_msg_in_history)
  thus ?thesis using P events_in_local_order hb_deliver by blast
qed

lemma (in imap) concurrent_append_expunge_independent_technical:
  assumes "i = mo"
    and "xs prefix of j"
    and "(i, Append i e) \<in> set (node_deliver_messages xs)"
    and "(r, Expunge e mo r) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Append i e) (r, Expunge e mo r)"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Expunge e mo r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f1: "Deliver (mo, Append mo e) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (mo, Store e mo2 mo) \<in> set pre)"
    using Broadcast_Expunge_Deliver_prefix_closed assms(1) by auto
  hence "(\<forall> mo2 . Deliver (mo, Store e mo2 mo) \<notin> set pre)" using P assms
  proof -
    have "Deliver (mo, Append mo e) \<in> set (history j)"
      using assms(1) assms(2) assms(3) prefix_msg_in_history by blast
    thus ?thesis
      by (metis (no_types) P Pair_inject delivery_has_a_cause fst_conv msg_id_unique
          operation.simps(23) prefix_elem_to_carriers prefix_of_appendD)
  qed
  thus ?thesis
    using hb.intros(2) events_in_local_order assms(1) P f1 by blast
qed

lemma (in imap) concurrent_append_store_independent_technical:
  assumes "i = mo"
    and "xs prefix of j"
    and "(i, Append i e) \<in> set (node_deliver_messages xs)"
    and "(r, Store e mo r) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Append i e) (r, Store e mo r)"
proof -
  obtain pre k where pre: "pre@[Broadcast (r, Store e mo r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence f1: "Deliver (mo, Append mo e) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (mo, Store e mo2 mo) \<in> set pre)"
    using Broadcast_Store_Deliver_prefix_closed assms(1) by auto
  have f2: "Deliver (i, Append i e) \<in> set (history j)"
    by (meson assms network.prefix_msg_in_history network_axioms)
  then show ?thesis using assms f1
    by (metis  pre delivery_has_a_cause events_in_local_order fst_conv hb_deliver
        msg_id_unique node_histories.prefix_of_appendD node_histories_axioms
        prefix_elem_to_carriers)
qed

lemma (in imap) concurrent_expunge_delete_independent_technical:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Expunge e mo i) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Expunge e mo i) (ir, Delete is e)"
proof -
  obtain pre k where pre: "pre@[Broadcast (ir, Delete is e)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence A: "Deliver (i, Create i e) \<in> set pre \<or>
  Deliver (i, Append i e) \<in> set pre \<or>
  (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set pre) \<or>
  (\<exists> mo . Deliver (i, Store e mo i) \<in> set pre)"
    using Broadcast_Deliver_prefix_closed assms(1) by auto
  hence "Deliver (i, Expunge e mo i) \<in> set pre" using assms
  proof -
    have f1: "\<And>e. e \<notin> set pre \<or> e \<in> set (history k)"
      using pre prefix_elem_to_carriers by blast
    have f2: "Deliver (i, Expunge e mo i) \<in> set (history j)"
      by (meson assms network.prefix_msg_in_history network_axioms)
    then show ?thesis using f1 A
      by (metis (no_types, lifting) fst_conv msg_id_unique network.delivery_has_a_cause
          network_axioms)
  qed
  ultimately show ?thesis
    using hb.intros(2) events_in_local_order by blast
qed

lemma (in imap) concurrent_store_store_independent_technical:
  assumes "xs prefix of j"
    and "(i, Store e mo i) \<in> set (node_deliver_messages xs)"
    and "(r, Store e i r) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Store e mo i) (r, Store e i r)"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Store e i r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f1: "\<forall>e. e \<notin> set pre \<or> e \<in> set (history k)"
    using prefix_elem_to_carriers by blast
  have f2: "Deliver (i, Append i e) \<in> set pre \<or> (\<exists> mo2 . Deliver (i, Store e mo2 i) \<in> set pre)"
    using Broadcast_Store_Deliver_prefix_closed assms(1) P by auto
  hence "Deliver (i, Store e mo i) \<in> set pre" using assms f1
    by (metis delivery_has_a_cause fst_conv msg_id_unique prefix_msg_in_history)
  then show ?thesis
    using hb.intros(2) events_in_local_order P by blast
qed

lemma (in imap) expunge_delete_tag_causality:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Expunge e1 mo i) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e2) \<in> set (node_deliver_messages xs)"
    and "pre@[Broadcast (ir, Delete is e2)] prefix of k"
  shows "Deliver (i, Expunge e2 mo i) \<in> set (history k)"
proof-
  have f1: "Deliver (i, Append i e2) \<notin> set (history k)" using assms
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.distinct(15) prefix_msg_in_history)
  have f2: "Deliver (i, Create i e2) \<notin> set (history k)" using assms
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.distinct(5) prefix_msg_in_history)
  have f3: "\<forall> mo. Deliver (i, Store e2 mo i) \<notin> set (history k)" using assms
    by (metis Pair_inject fst_conv msg_id_unique network.delivery_has_a_cause network_axioms
        operation.simps(25) prefix_msg_in_history)
  hence "\<exists> mo1. Deliver (i, Expunge e2 mo1 i) \<in> set (history k)" using assms f1 f2
    by (meson imap.Broadcast_Deliver_prefix_closed imap_axioms node_histories.prefix_of_appendD
        node_histories_axioms prefix_elem_to_carriers)
  then obtain mo1 :: 'a where
    "Deliver (i, Expunge e2 mo1 i) \<in> set (history k)" by blast
  then show ?thesis  using assms f1 f2 f3
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.inject(4) prefix_msg_in_history)
qed

lemma (in imap) expunge_delete_ids_imply_messages_same:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Expunge e1 mo i) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e2) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e2)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence "Deliver (i, Expunge e2 mo i) \<in> set (history k)" using assms expunge_delete_tag_causality
    by blast
  then show ?thesis using assms
    by (metis delivery_has_a_cause fst_conv network.msg_id_unique network_axioms
        operation.inject(4) prefix_msg_in_history prod.inject)
qed

lemma (in imap) store_delete_ids_imply_messages_same:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Store e1 mo i) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e2) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e2)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  have f1: "Deliver (i, Append i e2) \<notin> set (history k)" using assms
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.distinct(17) prefix_msg_in_history)
  have f2: "\<forall> mo. Deliver (i, Expunge e2 mo i) \<notin> set (history k)" using assms
    by (metis Pair_inject fst_conv msg_id_unique network.delivery_has_a_cause network_axioms
        operation.distinct(19) prefix_msg_in_history)
  have f3: "Deliver (i, Create i e2) \<notin> set (history k)" using assms
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.distinct(8) prefix_msg_in_history)
  hence "(\<exists> mo1. Deliver (i, Store e2 mo1 i) \<in> set pre)" using assms P f1 f2 imap_axioms
    by (meson imap.Broadcast_Deliver_prefix_closed prefix_elem_to_carriers prefix_of_appendD)
  then obtain mo1 :: 'a where
    f3: "Deliver (i, Store e2 mo1 i) \<in> set pre" by blast
  then have f4: "Deliver (i, Store e2 mo1 i) \<in> set (history k)"
    using P prefix_elem_to_carriers by blast
  hence "Deliver (i, Store e2 mo i) \<in> set pre" using f2 f3 assms
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.inject(5) prefix_msg_in_history)
  moreover have "Deliver(i, Store e1 mo i) \<in> set (history j)"
    using assms(2) assms(3) prefix_msg_in_history by blast
  ultimately show ?thesis using f4
    by (metis delivery_has_a_cause fst_conv msg_id_unique old.prod.inject operation.inject(5))
qed

lemma (in imap) create_delete_ids_imply_messages_same:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Create i e1) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e2) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e2)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  have f1: "Deliver (i, Append i e2) \<notin> set (history k)"
    by (metis assms(2) assms(3) delivery_has_a_cause fst_conv network.msg_id_unique
        network.prefix_msg_in_history network_axioms operation.distinct(3) prod.inject)
  have f2: "\<forall> mo. Deliver (i, Expunge e2 mo i) \<notin> set (history k)"
    by (metis assms(2) assms(3) fst_conv msg_id_unique network.delivery_has_a_cause network_axioms
        old.prod.inject operation.distinct(5) prefix_msg_in_history)
  have f3: "\<forall> mo. Deliver (i, Store e2 mo i) \<notin> set (history k)"
    by (metis Pair_inject assms(2) assms(3) delivery_has_a_cause fst_conv msg_id_unique
        operation.distinct(7) prefix_msg_in_history)
  hence "Deliver (i, Create i e2) \<in> set pre" using assms P f2 f1 imap_axioms
    by (meson imap.Broadcast_Deliver_prefix_closed  prefix_elem_to_carriers prefix_of_appendD)
  then show ?thesis using f1 f2 f3
    by (metis (no_types, lifting) P assms(2) assms(3) delivery_has_a_cause fst_conv msg_id_unique
        node_histories.prefix_of_appendD node_histories_axioms old.prod.inject operation.inject(1)
        prefix_elem_to_carriers prefix_msg_in_history)
qed

lemma (in imap) append_delete_ids_imply_messages_same:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Append i e1) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e2) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e2)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f1: "\<And>e. e \<in> set pre \<Longrightarrow> e \<in> set (history k)" using prefix_elem_to_carriers by blast
  have f2: "Deliver (i, Create i e2) \<notin> set pre" using P f1
    by (metis assms(2) assms(3) fst_conv msg_id_unique network.delivery_has_a_cause network_axioms
        old.prod.inject operation.distinct(3) prefix_msg_in_history)
  moreover have D1: "\<forall> mo. Deliver (i, Expunge e2 mo i) \<notin> set pre" using P f1
    by (metis Pair_inject assms(2) assms(3) fst_conv msg_id_unique network.delivery_has_a_cause
        network_axioms operation.distinct(15) prefix_msg_in_history)
  moreover have D2: "\<forall> mo. Deliver (i, Store e2 mo i) \<notin> set pre" using P f1
    by (metis Pair_inject assms(2) assms(3) fst_conv msg_id_unique network.delivery_has_a_cause
        network_axioms operation.simps(23) prefix_msg_in_history)
  moreover hence "Deliver (i, Append i e2) \<in> set pre"
    using P D1 D2 f2 assms(1) Broadcast_Deliver_prefix_closed by blast
  moreover have "Deliver (i, Append i e1) \<in> set (history j)"
    using assms(2) assms(3) prefix_msg_in_history by blast
  ultimately show ?thesis using assms
    by (metis f1 msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.inject(3) prod.sel(1))
qed

lemma (in imap) append_expunge_ids_imply_messages_same:
  assumes "i = mo"
    and "xs prefix of j"
    and "(i, Append i e1) \<in> set (node_deliver_messages xs)"
    and "(r, Expunge e2 mo r) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where pre: "pre@[Broadcast (r, Expunge e2 mo r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence "Deliver (mo, Append mo e2) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (mo, Store e2 mo2 mo) \<in> set pre)"
    using Broadcast_Expunge_Deliver_prefix_closed assms(1)
    by (meson imap.Broadcast_Deliver_prefix_closed imap_axioms)
  hence "Deliver (i, Append i e2) \<in> set pre" using assms
    by (metis (no_types, lifting) pre delivery_has_a_cause fst_conv hb_broadcast_exists1
        msg_id_unique network.hb_deliver network.prefix_msg_in_history network_axioms
        node_histories.events_in_local_order node_histories_axioms operation.distinct(17)
        prod.inject)
  moreover have "Deliver (i, Append i e1) \<in> set (history j)"
    using assms(2) assms(3) prefix_msg_in_history by blast
  ultimately show ?thesis
    by (metis (no_types, lifting) fst_conv network.delivery_has_a_cause network.msg_id_unique
        network_axioms operation.inject(3) prefix_elem_to_carriers prefix_of_appendD prod.inject)
qed

lemma (in imap) append_store_ids_imply_messages_same:
  assumes "i = mo"
    and "xs prefix of j"
    and "(i, Append i e1) \<in> set (node_deliver_messages xs)"
    and "(r, Store e2 mo r) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Store e2 mo r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence A: "Deliver (mo, Append mo e2) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (mo, Store e2 mo2 mo) \<in> set pre)"
    using Broadcast_Store_Deliver_prefix_closed assms(1)
    by (meson imap.Broadcast_Deliver_prefix_closed imap_axioms)
  have f1: "Deliver (i, Append i e1) \<in> set (history j)"
    using assms(2) assms(3) prefix_msg_in_history by blast
  hence "Deliver (i, Append i e2) \<in> set pre" using assms P A
    by (metis Pair_inject assms(1) P delivery_has_a_cause fst_conv msg_id_unique
        operation.simps(23) prefix_elem_to_carriers prefix_of_appendD)
  then show ?thesis using f1
    by (metis P delivery_has_a_cause fst_conv msg_id_unique
        node_histories.prefix_of_appendD node_histories_axioms operation.inject(3)
        prefix_elem_to_carriers prod.inject)
qed

lemma (in imap) expunge_store_ids_imply_messages_same:
  assumes "xs prefix of j"
    and "(i, Store e1 mo i) \<in> set (node_deliver_messages xs)"
    and "(r, Expunge e2 i r) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Expunge e2 i r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence pprefix: "pre prefix of k"
    using P by blast
  have A: "Deliver (i, Append i e2) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (i, Store e2 mo2 i) \<in> set pre)"
    using Broadcast_Expunge_Deliver_prefix_closed assms(1) P by blast
  have "Deliver (i, Store e2 mo i) \<in> set pre" using assms A P
  proof -
    obtain op1 :: "'a \<times> ('a, 'b) operation \<Rightarrow> nat" where
      f1: "Broadcast (i, Store e1 mo i) \<in> set (history (op1 (i, Store e1 mo i)))"
      by (meson assms(1) assms(2) delivery_has_a_cause prefix_msg_in_history)
    then show ?thesis
      using f1 A pprefix delivery_has_a_cause network.msg_id_unique network_axioms
        node_histories.prefix_to_carriers node_histories_axioms
      by fastforce
  qed
  moreover have "Deliver (i, Store e1 mo i) \<in> set (history j)"
    using assms(1) assms(2) prefix_msg_in_history by auto
  ultimately show ?thesis using assms P
    by (metis delivery_has_a_cause fst_conv msg_id_unique operation.inject(5)
        prefix_elem_to_carriers prefix_of_appendD prod.inject)
qed

lemma (in imap) store_store_ids_imply_messages_same:
  assumes "xs prefix of j"
    and "(i, Store e1 mo i) \<in> set (node_deliver_messages xs)"
    and "(r, Store e2 i r) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Store e2 i r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence A: "Deliver (i, Append i e2) \<in> set pre \<or>
    (\<exists> mo2 . Deliver (i, Store e2 mo2 i) \<in> set pre)"
    using Broadcast_Store_Deliver_prefix_closed assms(1) by blast
  have "\<forall>e. e \<notin> set pre \<or> e \<in> set (history k)"
    using P prefix_elem_to_carriers by auto
  hence "Deliver (i, Store e2 mo i) \<in> set pre"
    by (metis A assms(1) assms(2) delivery_has_a_cause fst_conv msg_id_unique
        operation.distinct(17) operation.inject(5) prefix_msg_in_history prod.inject)
  moreover have "Deliver (i, Store e1 mo i) \<in> set (history j)"
    using assms(1) assms(2) prefix_msg_in_history by auto
  ultimately show ?thesis using assms
    by (metis Pair_inject delivery_has_a_cause msg_id_unique operation.simps(5)
        prefix_elem_to_carriers prefix_of_appendD prod.sel(1))
qed

end


theory SINVAR_NoRefl_impl
imports SINVAR_NoRefl "../TopoS_Interface_impl"
begin

code_identifier code_module  SINVAR_NoRefl_impl => (Scala) SINVAR_NoRefl

subsubsection \<open>SecurityInvariant NoRefl List Implementation\<close>

fun sinvar :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (s,r) \<in> set (edgesL G). s = r \<longrightarrow> nP s = Refl)"

definition NoRefl_offending_list:: "'v list_graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> ('v \<times> 'v) list list" where
  "NoRefl_offending_list G nP = (if sinvar G nP then
    []
   else
    [ [e \<leftarrow> edgesL G. case e of (e1,e2) \<Rightarrow> e1 = e2 \<and> nP e1 = NoRefl] ])"

definition "NetModel_node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> SINVAR_NoRefl.default_node_properties))"

definition "NoRefl_eval G P = (wf_list_graph G \<and>
  sinvar G (SecurityInvariant.node_props SINVAR_NoRefl.default_node_properties P))"

interpretation NoRefl_impl:TopoS_List_Impl
  where default_node_properties=SINVAR_NoRefl.default_node_properties
  and sinvar_spec=SINVAR_NoRefl.sinvar
  and sinvar_impl=sinvar
  and receiver_violation=SINVAR_NoRefl.receiver_violation
  and offending_flows_impl=NoRefl_offending_list
  and node_props_impl=NetModel_node_props
  and eval_impl=NoRefl_eval
 apply(unfold TopoS_List_Impl_def)
 apply(rule conjI)
  apply(simp add: TopoS_NoRefl list_graph_to_graph_def)
 apply(rule conjI)
  apply(simp add: list_graph_to_graph_def NoRefl_offending_set NoRefl_offending_set_def NoRefl_offending_list_def)
 apply(rule conjI)
  apply(simp only: NetModel_node_props_def)
  apply(metis NoRefl.node_props.simps NoRefl.node_props_eq_node_props_formaldef)
 apply(simp only: NoRefl_eval_def)
 apply(simp add: TopoS_eval_impl_proofrule[OF TopoS_NoRefl])
 apply(simp add: list_graph_to_graph_def)
done

subsubsection \<open>PolEnforcePoint packing\<close>
  definition SINVAR_LIB_NoRefl :: "('v::vertex, node_config) TopoS_packed" where
    "SINVAR_LIB_NoRefl \<equiv>
    \<lparr> nm_name = ''NoRefl'',
      nm_receiver_violation = SINVAR_NoRefl.receiver_violation,
      nm_default = SINVAR_NoRefl.default_node_properties,
      nm_sinvar = sinvar,
      nm_offending_flows = NoRefl_offending_list,
      nm_node_props = NetModel_node_props,
      nm_eval = NoRefl_eval
      \<rparr>"
  interpretation SINVAR_LIB_NoRefl_interpretation: TopoS_modelLibrary SINVAR_LIB_NoRefl
      SINVAR_NoRefl.sinvar
    apply(unfold TopoS_modelLibrary_def SINVAR_LIB_NoRefl_def)
    apply(rule conjI)
     apply(simp)
    apply(simp)
    by(unfold_locales)

text \<open>Examples\<close>

  definition example_net :: "nat list_graph" where
  "example_net \<equiv> \<lparr> nodesL = [1::nat,2,3],
    edgesL = [(1,2),(2,2),(2,1),(1,3)] \<rparr>"
  lemma "wf_list_graph example_net" by eval

  definition example_conf where
  "example_conf \<equiv> ((\<lambda>e. SINVAR_NoRefl.default_node_properties)(2:= Refl))"

  lemma "sinvar example_net example_conf" by eval
  lemma "NoRefl_offending_list example_net (\<lambda>e. SINVAR_NoRefl.default_node_properties) = [[(2, 2)]]" by eval

hide_const (open) NetModel_node_props
hide_const (open) sinvar

end


(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory AfsFsopR
imports
  "../adt/BilbyT"
  "../adt/VfsT"
  "../spec/AfsS"
  "../spec/AfsInvS"
  "../spec/OstoreInvS"
begin

text {*
 Relation between the abstract FS of the correctness
 spec and the FS implemented by the Fsop component relying on
 the object store.

The object store is a projection from its internal state to a
mapping from OID to Object (ostore_map).
Each ostore update is a function update on the ostore_map and can non-deterministically
be synchronised to medium. Synchronisation is similar to correctness spec level,
applying all updates to ostore_map. Refinement proof (fsop_sync/ostore_sync) should be easy.
Each update should have a matching update at correctness spec level and applying all
and sequentially applying updates on both AFS and OstoreMap should yield an element
that satisfy the relation afs_fsop_sr.

*}

definition
 obj_inode_type_to_afs_type :: "ObjInode\<^sub>T \<Rightarrow> afs_inode \<Rightarrow> afs_inode_type"
where
  "obj_inode_type_to_afs_type i afsinode \<equiv> (if S_ISREG (ObjInode.mode\<^sub>f i) then IReg (i_data afsinode) else
                (if S_ISDIR (ObjInode.mode\<^sub>f i) then IDir (i_dir afsinode) else
                 (\<comment> \<open> if S_ISLNK (mode<^sub>f i) then \<close> ILnk (i_path afsinode) \<comment> \<open>else
                   undefined\<close>)))"

definition
  obj_inode_to_afs_inode :: "Obj\<^sub>T \<Rightarrow> afs_inode \<Rightarrow> afs_inode"
where
  "obj_inode_to_afs_inode obj afsinode \<equiv>
    (let i = obj_oinode obj in
     \<lparr>i_type = obj_inode_type_to_afs_type i afsinode,
      i_ino = inum_from_obj_id $ ObjInode.id\<^sub>f i,
      i_nlink = ObjInode.nlink\<^sub>f i,
      i_size = ObjInode.size\<^sub>f i,
      i_mtime = ObjInode.mtime_sec\<^sub>f i,
      i_ctime = ObjInode.ctime_sec\<^sub>f i,
      i_uid = ObjInode.uid\<^sub>f i,
      i_gid = ObjInode.gid\<^sub>f i,
      i_mode = ObjInode.mode\<^sub>f i,
      i_flags = ObjInode.flags\<^sub>f i\<rparr>)"

text {*
 Relation between a AFS file and a file in the object store.
 A file in the correctness spec corresponds to two type of objects
 stored in the object store:
  - An inode object where file attributes are stored, including the
    size (i_data part is irrelevant)
  - Multiple data objects that contain the data stored in the file.
    Each data object contains a "block" of data of BILBYFS_BLOCK_SIZE
    bytes. The block index parameter of ObjIdData indicates the index
    of the block in the file. (Where index i is byte offset
    i \<times> BILBYFS_BLOCK_SIZE in the file.)
    We currently do not allow holes.
 *}

definition
  file_eq :: "afs_inode \<Rightarrow> ostore_map \<Rightarrow> bool"
where
 "file_eq file os \<equiv>
   (\<forall>blk_idx blk. (blk_idx < length (i_data file) \<and> blk = (i_data file) ! blk_idx) \<longrightarrow>
     blk = (\<alpha>wa $ odata\<^sub>f $ obj_odata $ the $ os $ obj_id_data_mk (i_ino file, of_nat blk_idx)))"

definition
  get_dent_type :: "afs_map \<Rightarrow> Ino \<Rightarrow> U8"
where
 "get_dent_type afs ino \<equiv>
    (case (i_type $ the $ afs ino) of
       IReg _ \<Rightarrow>  bilbyFsItypeReg | IDir _ \<Rightarrow> bilbyFsItypeDir | ILnk _ \<Rightarrow> bilbyFsItypeLnk )"

text {*
  Relation between a AFS directory and a directory in the object store.
  At the correctness spec level directories are a an inode that contains
  a bunch of attributes and a mapping from name to inode number.
  At the Fsop level, directories are:
    - An inode for attributes such as mode, owner...
    - Multiple directory entry arrays (dentarrs).
       Each directory entry contains a name, an inode number and a type.
       The idea is that in order to have a quick lookup for a name in a
       directory, we address directory entries using a hash of the
       name they contain. As different names can have the same hash,
       we group all hash collisions together within an array of directory
       entry (dentarr).
       Mapping entries on AFS directories and dentarr objects attached to
       Fsop directories have to match one another.
       Additionally, directory entries at Fsop level contain a type
       attribute which indicates the type of the inode referred by the
       inode number. This type attribute is a duplicated piece of
       information also contained in the inode itself, but having
       it is necessary for performance reason. When listing a directory
       reading an extra inode for each directory entry would be orders
       of magnitude slower.
   *}

definition
  dir_eq :: "afs_inode \<Rightarrow> afs_map \<Rightarrow>ostore_map \<Rightarrow> bool"
where
 "dir_eq dir afs os \<equiv>
    (\<forall>name.
     (let obj = os $ obj_id_dentarr_mk (i_ino dir, name);
          entries = stripNone $ \<alpha>a $ ObjDentarr.entries\<^sub>f $ obj_odentarr $ the obj in
      (case i_dir dir $ \<alpha>wa name of
        option.Some in_ino \<Rightarrow>
         (case obj of
           option.Some _ \<Rightarrow>
            {e \<in> set entries. ObjDentry.ino\<^sub>f e = in_ino \<and> ObjDentry.name\<^sub>f e = name} =
              {\<lparr>ino\<^sub>f = in_ino, type\<^sub>f = get_dent_type afs in_ino, nlen\<^sub>f = u32_to_u16 $ wordarray_length name, name\<^sub>f = name \<rparr>} |
            option.None \<Rightarrow> False)
       | option.None \<Rightarrow>
           (case obj of
              option.Some _ \<Rightarrow>
                  {e \<in> set entries. ObjDentry.name\<^sub>f e = name} = {}
            | option.None \<Rightarrow> True))))"

text {* Relation between a AFS symlinks and a symlinks in the object store.
  This relation is quite similar to files except that symbolic links can
  only use a single data block to store the symbolic link path.
*}
definition
  symlink_eq :: "afs_inode \<Rightarrow> ostore_map \<Rightarrow> bool"
where
 "symlink_eq symlink os \<equiv>
   i_path symlink = (\<alpha>wa $ odata\<^sub>f $ obj_odata $ the $ os $ obj_id_data_mk (i_ino symlink, 0))"

text {*
  Domain equivalence ensures that there is an inode in the AFS
  iff there is an existing inode at Fsop level.
*}
definition
  afs_fsop_dom_eq :: "afs_map \<Rightarrow> ostore_map \<Rightarrow> bool"
where
 "afs_fsop_dom_eq afs os \<equiv> dom afs = dom (\<lambda>ino. os (obj_id_inode_mk ino))"

text {*
  Content equivalence
*}
definition
  afs_fsop_content_eq :: "afs_map \<Rightarrow> ostore_map \<Rightarrow> bool"
where
 "afs_fsop_content_eq afs os \<equiv>
  (\<forall>ino \<in> dom afs.
      let inode = (the $ afs ino);
          oino = (the $ os $ obj_id_inode_mk ino) in
          obj_inode_to_afs_inode oino inode = inode \<and>
          (case i_type inode of
             IReg file_data \<Rightarrow> file_eq inode os |
             IDir dir \<Rightarrow> dir_eq inode afs os |
             ILnk path \<Rightarrow>  symlink_eq inode os))"

definition
  afs_fsop_match :: "afs_map \<Rightarrow> ostore_map \<Rightarrow> bool"
where
 "afs_fsop_match afs os \<equiv> afs_fsop_dom_eq afs os \<and> afs_fsop_content_eq afs os"

text {*
 Definitions useful to describe parameters, pre/post conditions of
 refinement statements
*}
definition
 vnode_afs_inode_consistency :: "vnode \<Rightarrow> afs_inode \<Rightarrow> bool"
where
 "vnode_afs_inode_consistency v i \<equiv>
  v_ino v = i_ino i \<and>
  v_nlink v = i_nlink i \<and>
  v_mtime v = i_mtime i \<and>
  v_ctime v = i_ctime i \<and>
  v_uid v = i_uid i \<and>
  v_gid v = i_gid i \<and>
  v_mode v = i_mode i"

definition
 is_valid_vdir :: "vnode \<Rightarrow> (Ino \<rightharpoonup> afs_inode) \<Rightarrow> bool"
where
 "is_valid_vdir vdir afs \<equiv>
    v_ino vdir \<in> dom afs \<and>
    (v_mode vdir AND s_IFMT = s_IFDIR) \<and>
    afs_inode_is_dir (i_type $ the $ afs $ v_ino vdir) \<and>
    vnode_afs_inode_consistency vdir (the $ afs $ v_ino vdir)"

lemma vdir_dir_consistent:
 "is_valid_vdir vdir afs \<Longrightarrow> vnode_afs_inode_consistency vdir (the $ afs $ v_ino vdir)"
 by (clarsimp simp: is_valid_vdir_def dom_def)

lemma vdir_is_dir:
 "\<lbrakk> is_valid_vdir vdir afs \<rbrakk> \<Longrightarrow> afs_inode_is_dir (i_type $ the $ afs (v_ino vdir))"
  by (clarsimp simp: is_valid_vdir_def)

text {* Refinement proof of the operation sync. *}

definition
 match_afs_data_fs_state :: "afs_state \<Rightarrow> FsState\<^sub>T \<Rightarrow> bool"
where
 "match_afs_data_fs_state afs_data fs_st \<equiv>
  a_is_readonly afs_data = (is_ro\<^sub>f $ fsop_st\<^sub>f fs_st)"

definition
 afs_fsop_match_step_updates :: "afs_map \<Rightarrow> (afs_map \<Rightarrow> afs_map) list \<Rightarrow>
                                 ostore_map \<Rightarrow> (ostore_map \<Rightarrow> ostore_map) list \<Rightarrow> bool"
where
 "afs_fsop_match_step_updates afs afs_updates os os_updates \<equiv>
     length os_updates = length afs_updates \<and>
     (\<forall>n \<le> length os_updates.
        afs_fsop_match (a_afs_updated_n n afs afs_updates)
                       (apply_n_updates n os os_updates))"

definition
 "afmsu afs_data os_st \<equiv>
   afs_fsop_match_step_updates
    (a_medium_afs afs_data) (a_medium_updates afs_data)
    (\<alpha>_ostore_medium os_st) (\<alpha>_updates os_st)"

definition
  "afs_inv_steps afs \<equiv>
    (\<forall>n \<le> length (a_medium_updates afs).
     afs_inv (a_afs_updated_n n (a_medium_afs afs) (a_medium_updates afs)))"

lemma afs_inv_steps_updated_afsD:
 "afs_inv_steps afs \<Longrightarrow> afs_inv (updated_afs afs)"
  apply (simp add: updated_afs_def)
  apply (simp add: afs_inv_steps_def)
  apply (erule_tac x="length (a_medium_updates afs)" in allE)
  apply (fastforce simp add: a_afs_updated_def)
 done

text{* In the success case, we ensure that the updates match and that the on-medium
 states match too. Note that simply applying the updates on both sides and ensuring
 that the resulting states match is not enough, both syncs could have applied a different
 number of updates. *}
definition
 afs_fsop_rel :: "afs_state \<Rightarrow> FsState\<^sub>T \<Rightarrow> bool"
where
 "afs_fsop_rel afs_data fs_st \<equiv>
   inv_mount_st (FsState.mount_st\<^sub>f fs_st) \<and>
   afs_inv_steps afs_data \<and>
   (let os_st = ostore_st\<^sub>f fs_st in
     afmsu afs_data os_st \<and>
     inv_ostore (mount_st\<^sub>f fs_st) os_st \<and> inv_\<alpha>_ostore (\<alpha>_ostore_uptodate os_st) \<and>
     match_afs_data_fs_state afs_data fs_st)"

lemma afs_fsop_rel_inv_ostoreD:
 "afs_fsop_rel afs_data fs_st \<Longrightarrow> inv_ostore (mount_st\<^sub>f fs_st) (ostore_st\<^sub>f fs_st)"
 by (clarsimp simp: afs_fsop_rel_def Let_def)
(*
lemma afs_fsop_rel_inv_stepD:
"afs_fsop_rel afs_data fs_st \<Longrightarrow> inv_\<alpha>_step_updates (ostore_st\<^sub>f fs_st)"
by (clarsimp simp: afs_fsop_rel_def Let_def)
*)
lemma afs_fsop_rel_inv_\<alpha>_ostoreD:
"afs_fsop_rel afs_data fs_st \<Longrightarrow>  inv_\<alpha>_ostore (\<alpha>_ostore_uptodate (ostore_st\<^sub>f fs_st))"
by (clarsimp simp: afs_fsop_rel_def Let_def)

lemmas afs_fsop_rel_simps =
  afs_fsop_rel_def
  match_afs_data_fs_state_def
  afmsu_def
  Let_def
  afs_fsop_match_step_updates_def

end