\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Generic Compositions\<close>
theory Transport_Compositions_Generic
  imports
    Transport_Compositions_Generic_Galois_Equivalence
    Transport_Compositions_Generic_Galois_Relator
    Transport_Compositions_Generic_Order_Base
    Transport_Compositions_Generic_Order_Equivalence
begin

paragraph \<open>Summary of Main Results\<close>

subparagraph \<open>Closure of Order and Galois Concepts\<close>

context transport_comp
begin

interpretation flip : transport_comp R2 L2 r2 l2 R1 L1 r1 l1 .

lemma preorder_galois_connection_if_galois_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_field (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "preorder_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "reflexive_on (in_field (\<le>\<^bsub>R2\<^esub>)) (\<le>\<^bsub>R2\<^esub>)"
  and "middle_compatible_codom"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro preorder_galois_connectionI)
  (auto elim!: t1.galois_equivalenceE t2.galois_equivalenceE
    intro!: galois_connection_left_right_if_galois_equivalenceI
      preorder_on_in_field_leftI flip.preorder_on_in_field_leftI
      mono_in_codom_left_rel_left1_if_in_codom_rel_comp_le
      flip.mono_in_codom_left_rel_left1_if_in_codom_rel_comp_le
      in_codom_eq_in_dom_if_reflexive_on_in_field)

theorem preorder_galois_connection_if_preorder_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "middle_compatible_codom"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro preorder_galois_connection_if_galois_equivalenceI)
  auto

lemma preorder_equivalence_if_galois_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "reflexive_on (in_field (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "preorder_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "reflexive_on (in_field (\<le>\<^bsub>R2\<^esub>)) (\<le>\<^bsub>R2\<^esub>)"
  and "middle_compatible_codom"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
proof -
  from assms have "((\<le>\<^bsub>L\<^esub>) \<stileturn>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
    by (intro preorder_galois_connection_if_galois_equivalenceI) auto
  with assms show ?thesis by (intro preorder_equivalence_if_galois_equivalenceI)
    (auto intro!: galois_equivalence_if_galois_equivalenceI
      preorder_galois_connection_if_galois_equivalenceI)
qed

theorem preorder_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "middle_compatible_codom"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro preorder_equivalence_if_galois_equivalenceI) auto

theorem partial_equivalence_rel_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "middle_compatible_codom"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro partial_equivalence_rel_equivalence_if_galois_equivalenceI
    galois_equivalence_if_galois_equivalenceI
    partial_equivalence_rel_leftI flip.partial_equivalence_rel_leftI
    in_codom_eq_in_dom_if_partial_equivalence_rel)
  auto

subparagraph \<open>Simplification of GaloisGalois relator\<close>

theorem Galois_eq_Galois_rel_compI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>R2\<^esub>) \<stileturn>\<^bsub>pre\<^esub> (\<le>\<^bsub>L2\<^esub>)) r2 l2"
  and "middle_compatible_codom"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) = ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
  using assms by (intro
    Galois_eq_Galois_rel_comp_if_galois_connection_if_galois_equivalenceI)
  auto

text \<open>For theorems with weaker assumptions, see
@{thm "Galois_eq_Galois_rel_compI'"
"Galois_eq_Galois_rel_comp_if_galois_connection_if_galois_equivalenceI"}.\<close>

subparagraph \<open>Simplification of Compatibility Assumption\<close>

text \<open>See @{theory "Transport.Transport_Compositions_Generic_Base"}.\<close>

end

end


(*
   Title: Psi-calculi
   Based on the AFP entry by Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Bisim_Subst
  imports Weak_Bisim_Struct_Cong Weak_Bisim_Pres Bisim_Subst
begin

context env begin

abbreviation
  weakBisimSubstJudge ("_ \<rhd> _ \<approx>\<^sub>s _" [70, 70, 70] 65) where "\<Psi> \<rhd> P \<approx>\<^sub>s Q \<equiv> (\<Psi>, P, Q) \<in> close_subst weakBisim"
abbreviation
  weakBisimSubstNilJudge ("_ \<approx>\<^sub>s _" [70, 70] 65) where "P \<approx>\<^sub>s Q \<equiv> \<one> \<rhd> P \<approx>\<^sub>s Q"

lemmas weakBisimSubstClosed[eqvt] = close_subst_closed[OF weakBisimEqvt]
lemmas weakBisimEqvt[simp] = close_subst_eqvt[OF weakBisimEqvt]

lemma strongBisimSubstWeakBisimSubst:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<sim>\<^sub>s Q"

  shows "\<Psi> \<rhd> P \<approx>\<^sub>s Q"
using assms
by(metis close_substI close_substE strongBisimWeakBisim)

lemma weakBisimSubstOutputPres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   M :: 'a
  and   N :: 'a

  assumes "\<Psi> \<rhd> P \<approx>\<^sub>s Q"

  shows "\<Psi> \<rhd> M\<langle>N\<rangle>.P \<approx>\<^sub>s M\<langle>N\<rangle>.Q"
using assms
by(fastforce intro: close_substI close_substE weakBisimOutputPres)

lemma bisimSubstInputPres:
  fixes \<Psi>    :: 'b
  and   P    :: "('a, 'b, 'c) psi"
  and   Q    :: "('a, 'b, 'c) psi"
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a

  assumes "\<Psi> \<rhd> P \<approx>\<^sub>s Q"
  and     "xvec \<sharp>* \<Psi>"
  and     "distinct xvec"

  shows "\<Psi> \<rhd> M\<lparr>\<lambda>*xvec N\<rparr>.P \<approx>\<^sub>s M\<lparr>\<lambda>*xvec N\<rparr>.Q"
proof(rule_tac close_substI)
  fix \<sigma> :: "(name list \<times> 'a list) list"
  assume "well_formed_subst \<sigma>"
  obtain p where "(p \<bullet> xvec) \<sharp>* \<sigma>"
           and "(p \<bullet> xvec) \<sharp>* P" and "(p \<bullet> xvec) \<sharp>* Q" and "(p \<bullet> xvec) \<sharp>* \<Psi>" and "(p \<bullet> xvec) \<sharp>* N"
           and S: "set p \<subseteq> set xvec \<times> set (p \<bullet> xvec)"
    by(rule_tac c="(\<sigma>, P, Q, \<Psi>, N)" in name_list_avoiding) auto

  from `\<Psi> \<rhd> P \<approx>\<^sub>s Q` have "(p \<bullet> \<Psi>) \<rhd> (p \<bullet> P) \<approx>\<^sub>s (p \<bullet> Q)"
    by(rule weakBisimSubstClosed)
  with `xvec \<sharp>* \<Psi>` `(p \<bullet> xvec) \<sharp>* \<Psi>` S have "\<Psi> \<rhd> (p \<bullet> P) \<approx>\<^sub>s (p \<bullet> Q)"
    by simp

  {
    fix Tvec' :: "'a list"
    assume "length (p \<bullet> xvec) = length Tvec'"
    with `well_formed_subst \<sigma>` `distinct xvec` have "well_formed_subst (\<sigma> @ [(p \<bullet> xvec,Tvec')])"
      by simp
    with `\<Psi> \<rhd> (p \<bullet> P) \<approx>\<^sub>s (p \<bullet> Q)` have "\<Psi> \<rhd> (p \<bullet> P)[<(\<sigma> @ [(p \<bullet> xvec,Tvec')])>] \<approx> (p \<bullet> Q)[<(\<sigma> @ [(p \<bullet> xvec,Tvec')])>]"
      by (rule close_substE)
    then have "\<Psi> \<rhd> ((p \<bullet> P)[<\<sigma>>])[(p \<bullet> xvec)::=Tvec'] \<approx> ((p \<bullet> Q)[<\<sigma>>])[(p \<bullet> xvec)::=Tvec']"
      by (metis seq_subs_cons seq_subs_nil seq_subs_term_append)
  }

  then have "\<Psi> \<rhd> M[<\<sigma>>]\<lparr>\<lambda>*(p \<bullet> xvec) (p \<bullet> N)[<\<sigma>>]\<rparr>.((p \<bullet> P)[<\<sigma>>]) \<approx> M[<\<sigma>>]\<lparr>\<lambda>*(p \<bullet> xvec) (p \<bullet> N)[<\<sigma>>]\<rparr>.((p \<bullet> Q)[<\<sigma>>])"
    using weakBisimInputPres by metis
  with `(p \<bullet> xvec) \<sharp>* \<sigma>` have "\<Psi> \<rhd> (M\<lparr>\<lambda>*(p \<bullet> xvec) (p \<bullet> N)\<rparr>.(p \<bullet> P))[<\<sigma>>] \<approx> (M\<lparr>\<lambda>*(p \<bullet> xvec) (p \<bullet> N)\<rparr>.(p \<bullet> Q))[<\<sigma>>]"
    by (metis seq_subst_input_chain seq_subst_simps(3))
  moreover from `(p \<bullet> xvec) \<sharp>* N` `(p \<bullet> xvec) \<sharp>* P` S have "M\<lparr>\<lambda>*(p \<bullet> xvec) (p \<bullet> N)\<rparr>.(p \<bullet> P) = M\<lparr>\<lambda>*xvec N\<rparr>.P"
    apply (simp add: psi.inject) by (rule input_chain_alpha[symmetric]) auto
  moreover from `(p \<bullet> xvec) \<sharp>* N` `(p \<bullet> xvec) \<sharp>* Q` S have "M\<lparr>\<lambda>*(p \<bullet> xvec) (p \<bullet> N)\<rparr>.(p \<bullet> Q) = M\<lparr>\<lambda>*xvec N\<rparr>.Q"
    apply (simp add: psi.inject) by (rule input_chain_alpha[symmetric]) auto
  ultimately show "\<Psi> \<rhd> (M\<lparr>\<lambda>*xvec N\<rparr>.P)[<\<sigma>>] \<approx> (M\<lparr>\<lambda>*xvec N\<rparr>.Q)[<\<sigma>>]"
    by force
qed
(*
lemma bisimSubstCasePresAux:
  fixes \<Psi>   :: 'b
  and   CsP :: "('c \<times> ('a, 'b, 'c) psi) list"
  and   CsQ :: "('c \<times> ('a, 'b, 'c) psi) list"

  assumes C1: "\<And>\<phi> P. (\<phi>, P) mem CsP \<Longrightarrow> \<exists>Q. (\<phi>, Q) mem CsQ \<and> guarded Q \<and> \<Psi> \<rhd> P \<sim>\<^sub>s Q"
  and     C2: "\<And>\<phi> Q. (\<phi>, Q) mem CsQ \<Longrightarrow> \<exists>P. (\<phi>, P) mem CsP \<and> guarded P \<and> \<Psi> \<rhd> P \<sim>\<^sub>s Q"

  shows "\<Psi> \<rhd> Cases CsP \<sim>\<^sub>s Cases CsQ"
proof -
  {
    fix xvec :: "name list"
    and Tvec :: "'a list"

    assume "length xvec = length Tvec"
    and    "distinct xvec"

    have "\<Psi> \<rhd> Cases(caseListSubst CsP xvec Tvec) \<sim> Cases(caseListSubst CsQ xvec Tvec)"
    proof(rule bisimCasePres)
      fix \<phi> P
      assume "(\<phi>, P) mem (caseListSubst CsP xvec Tvec)"
      then obtain \<phi>' P' where "(\<phi>', P') mem CsP" and "\<phi> = substCond \<phi>' xvec Tvec" and PeqP': "P = (P'[xvec::=Tvec])"
        by(induct CsP) force+
      from `(\<phi>', P') mem CsP` obtain Q' where "(\<phi>', Q') mem CsQ" and "guarded Q'" and "\<Psi> \<rhd> P' \<sim>\<^sub>s Q'" by(blast dest: C1)
      from `(\<phi>', Q') mem CsQ` `\<phi> = substCond \<phi>' xvec Tvec` obtain Q where "(\<phi>, Q) mem (caseListSubst CsQ xvec Tvec)" and "Q = Q'[xvec::=Tvec]"
        by(induct CsQ) auto
      with PeqP' `guarded Q'` `\<Psi> \<rhd> P' \<sim>\<^sub>s Q'` `length xvec = length Tvec` `distinct xvec` show "\<exists>Q. (\<phi>, Q) mem (caseListSubst CsQ xvec Tvec) \<and> guarded Q \<and> \<Psi> \<rhd> P \<sim> Q"
        by(blast dest: bisimSubstE guardedSubst)
    next
      fix \<phi> Q
      assume "(\<phi>, Q) mem (caseListSubst CsQ xvec Tvec)"
      then obtain \<phi>' Q' where "(\<phi>', Q') mem CsQ" and "\<phi> = substCond \<phi>' xvec Tvec" and QeqQ': "Q = Q'[xvec::=Tvec]"
        by(induct CsQ) force+
      from `(\<phi>', Q') mem CsQ` obtain P' where "(\<phi>', P') mem CsP" and "guarded P'" and "\<Psi> \<rhd> P' \<sim>\<^sub>s Q'" by(blast dest: C2)
      from `(\<phi>', P') mem CsP` `\<phi> = substCond \<phi>' xvec Tvec` obtain P where "(\<phi>, P) mem (caseListSubst CsP xvec Tvec)" and "P = P'[xvec::=Tvec]"
        by(induct CsP) auto
      with QeqQ' `guarded P'` `\<Psi> \<rhd> P' \<sim>\<^sub>s Q'` `length xvec = length Tvec` `distinct xvec` show "\<exists>P. (\<phi>, P) mem (caseListSubst CsP xvec Tvec) \<and> guarded P \<and> \<Psi> \<rhd> P \<sim> Q"
        by(blast dest: bisimSubstE guardedSubst)
    qed
  }
  thus ?thesis
    by(rule_tac bisimSubstI) auto
qed
*)
lemma weakBisimSubstReflexive:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<approx>\<^sub>s P"
by(auto intro: close_substI weakBisimReflexive)

lemma bisimSubstTransitive:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<approx>\<^sub>s Q"
  and     "\<Psi> \<rhd> Q \<approx>\<^sub>s R"

  shows "\<Psi> \<rhd> P \<approx>\<^sub>s R"
using assms
by(auto intro: close_substI close_substE weakBisimTransitive)

lemma weakBisimSubstSymmetric:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<approx>\<^sub>s Q"

  shows "\<Psi> \<rhd> Q \<approx>\<^sub>s P"
using assms
by(auto intro: close_substI close_substE weakBisimE)
(*
lemma bisimSubstCasePres:
  fixes \<Psi>   :: 'b
  and   CsP :: "('c \<times> ('a, 'b, 'c) psi) list"
  and   CsQ :: "('c \<times> ('a, 'b, 'c) psi) list"

  assumes "length CsP = length CsQ"
  and     C: "\<And>(i::nat) \<phi> P \<phi>' Q. \<lbrakk>i <= length CsP; (\<phi>, P) = nth CsP i; (\<phi>', Q) = nth CsQ i\<rbrakk> \<Longrightarrow> \<phi> = \<phi>' \<and> \<Psi> \<rhd> P \<sim> Q"

  shows "\<Psi> \<rhd> Cases CsP \<sim>\<^sub>s Cases CsQ"
proof -
  {
    fix \<phi>
    and P

    assume "(\<phi>, P) mem CsP"

    with `length CsP = length CsQ` have "\<exists>Q. (\<phi>, Q) mem CsQ \<and> \<Psi> \<rhd> P \<sim>\<^sub>s Q"
      apply(induct n=="length CsP" arbitrary: CsP CsQ rule: nat.induct)
      apply simp
      apply simp
      apply auto

  }
using `length CsP = length CsQ`
proof(induct n=="length CsP" rule: nat.induct)
  case zero
  thus ?case by(fastforce intro: bisimSubstReflexive)
next
  case(Suc n)
next
apply auto
apply(blast intro: bisimSubstReflexive)
apply auto
apply(simp add: nth.simps)
apply(auto simp add: nth.simps)
apply blast
apply(rule_tac bisimSubstCasePresAux)
apply auto
*)
lemma weakBisimSubstParPres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<approx>\<^sub>s Q"

  shows "\<Psi> \<rhd> P \<parallel> R \<approx>\<^sub>s Q \<parallel> R"
using assms
by(fastforce intro: close_substI close_substE weakBisimParPres)

lemma weakBisimSubstResPres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   x :: name

  assumes "\<Psi> \<rhd> P \<approx>\<^sub>s Q"
  and     "x \<sharp> \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<approx>\<^sub>s \<lparr>\<nu>x\<rparr>Q"
proof(rule close_substI)
  fix \<sigma> :: "(name list \<times> 'a list) list"
  assume "well_formed_subst \<sigma>"
  obtain y::name where "y \<sharp> \<Psi>" and "y \<sharp> P" and "y \<sharp> Q" and "y \<sharp> \<sigma>"
    by (generate_fresh "name") auto

  from `\<Psi> \<rhd> P \<approx>\<^sub>s Q` have "([(x, y)] \<bullet> \<Psi>) \<rhd> ([(x, y)] \<bullet> P) \<approx>\<^sub>s ([(x, y)] \<bullet> Q)"
    by (rule weakBisimSubstClosed)
  with `x \<sharp> \<Psi>` `y \<sharp> \<Psi>` have "\<Psi> \<rhd> ([(x, y)] \<bullet> P) \<approx>\<^sub>s ([(x, y)] \<bullet> Q)"
    by simp
  hence "\<Psi> \<rhd> ([(x, y)] \<bullet> P)[<\<sigma>>] \<approx> ([(x, y)] \<bullet> Q)[<\<sigma>>]"
    using `well_formed_subst \<sigma>` by (rule close_substE)
  hence "\<Psi> \<rhd> \<lparr>\<nu>y\<rparr>(([(x, y)] \<bullet> P)[<\<sigma>>]) \<approx> \<lparr>\<nu>y\<rparr>(([(x, y)] \<bullet> Q)[<\<sigma>>])"
    using `y \<sharp> \<Psi>` by (rule weakBisimResPres)
  with `y \<sharp> P` `y \<sharp> Q` `y \<sharp> \<sigma>` show "\<Psi> \<rhd> (\<lparr>\<nu>x\<rparr>P)[<\<sigma>>] \<approx> (\<lparr>\<nu>x\<rparr>Q)[<\<sigma>>]"
    by (simp add: alpha_res)
qed

(*
lemma bisimSubstBangPres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<sim>\<^sub>s Q"
  and     "guarded P"
  and     "guarded Q"

  shows "\<Psi> \<rhd> !P \<sim>\<^sub>s !Q"
using assms
by(fastforce intro: bisimSubstI bisimSubstE bisimBangPres)
*)

lemma weakBisimSubstParNil:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<parallel> \<zero> \<approx>\<^sub>s P"
by(metis strongBisimSubstWeakBisimSubst bisim_subst_par_nil)

lemma weakBisimSubstParComm:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<parallel> Q \<approx>\<^sub>s Q \<parallel> P"
by(metis strongBisimSubstWeakBisimSubst bisim_subst_par_comm)

lemma weakBisimSubstParAssoc:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> (P \<parallel> Q) \<parallel> R \<approx>\<^sub>s P \<parallel> (Q \<parallel> R)"
by(metis strongBisimSubstWeakBisimSubst bisim_subst_par_assoc)

lemma weakBisimSubstResNil:
  fixes \<Psi> :: 'b
  and   x :: name

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>\<zero> \<sim>\<^sub>s \<zero>"
by(metis strongBisimSubstWeakBisimSubst bisim_subst_res_nil)

lemma weakBisimSubstScopeExt:
  fixes \<Psi> :: 'b
  and   x :: name
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> P"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(P \<parallel> Q) \<approx>\<^sub>s P \<parallel> \<lparr>\<nu>x\<rparr>Q"
using assms
by(metis strongBisimSubstWeakBisimSubst bisim_subst_scope_ext)

lemma weakBisimSubstCasePushRes:
  fixes x  :: name
  and   \<Psi>  :: 'b
  and   Cs :: "('c \<times> ('a, 'b, 'c) psi) list"

  assumes "x \<sharp> map fst Cs"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(Cases Cs) \<approx>\<^sub>s Cases map (\<lambda>(\<phi>, P). (\<phi>, \<lparr>\<nu>x\<rparr>P)) Cs"
using assms
by(metis strongBisimSubstWeakBisimSubst bisim_subst_case_push_res)

lemma weakBisimSubstOutputPushRes:
  fixes x :: name
  and   \<Psi> :: 'b
  and   M :: 'a
  and   N :: 'a
  and   P :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> M"
  and     "x \<sharp> N"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(M\<langle>N\<rangle>.P) \<approx>\<^sub>s M\<langle>N\<rangle>.\<lparr>\<nu>x\<rparr>P"
using assms
by(metis strongBisimSubstWeakBisimSubst bisim_subst_output_push_res)

lemma weakBisimSubstInputPushRes:
  fixes x    :: name
  and   \<Psi>    :: 'b
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a

  assumes "x \<sharp> M"
  and     "x \<sharp> xvec"
  and     "x \<sharp> N"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(M\<lparr>\<lambda>*xvec N\<rparr>.P) \<approx>\<^sub>s M\<lparr>\<lambda>*xvec N\<rparr>.\<lparr>\<nu>x\<rparr>P"
using assms
by(metis strongBisimSubstWeakBisimSubst bisim_subst_input_push_res)

lemma weakBisimSubstResComm:
  fixes x :: name
  and   y :: name

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>y\<rparr>P) \<approx>\<^sub>s \<lparr>\<nu>y\<rparr>(\<lparr>\<nu>x\<rparr>P)"
by(metis strongBisimSubstWeakBisimSubst bisim_subst_res_comm)

lemma weakBisimSubstExtBang:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  assumes "guarded P"

  shows "\<Psi> \<rhd> !P \<approx>\<^sub>s P \<parallel> !P"
using assms
by(metis strongBisimSubstWeakBisimSubst bisim_subst_ext_bang)

end

end


section \<open>Entry Point for the Automatic Refinement Tool\<close>
theory Automatic_Refinement
imports
  "Tool/Autoref_Tool"
  Autoref_Bindings_HOL
begin
  text \<open>The automatic refinement tool should be used by
    importing this theory\<close>

subsection \<open>Convenience\<close>

text \<open>The following lemmas can be used to add tags to theorems\<close>
lemma PREFER_I: "P x \<Longrightarrow> PREFER P x" by simp
lemma PREFER_D: "PREFER P x \<Longrightarrow> P x" by simp

lemmas PREFER_sv_D = PREFER_D[of single_valued]
lemma PREFER_id_D: "PREFER_id R \<Longrightarrow> R=Id" by simp

abbreviation "PREFER_RUNIV \<equiv> PREFER (\<lambda>R. Range R = UNIV)"
lemmas PREFER_RUNIV_D = PREFER_D[of "(\<lambda>R. Range R = UNIV)"]

lemma SIDE_GEN_ALGO_D: "SIDE_GEN_ALGO P \<Longrightarrow> P" by simp

lemma GEN_OP_D: "GEN_OP c a R \<Longrightarrow> (c,a)\<in>R"
  by simp

lemma MINOR_PRIO_TAG_I: "P \<Longrightarrow> (MINOR_PRIO_TAG p \<Longrightarrow> P)" by auto
lemma MAJOR_PRIO_TAG_I: "P \<Longrightarrow> (MAJOR_PRIO_TAG p \<Longrightarrow> P)" by auto
lemma PRIO_TAG_I: "P \<Longrightarrow> (PRIO_TAG ma mi \<Longrightarrow> P)" by auto

end


theory SafeProof
  imports ProcLangX
begin

type_synonym state = "string \<Rightarrow> p_exp option"

definition invalid_state where
  "invalid_state e S = (\<exists> a. a \<in> free_vars e \<and> a \<notin> dom S)"

definition valid_perm_env where
  "valid_perm_env r_s S = (use_env_vars r_s \<subseteq> dom S)"


(*  Title:      HOL/Auth/fifo_lemma_invs_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The fifo Protocol Case Study*}

theory fifo_lemma_invs_on_rules imports fifo_lemma_inv__1_on_rules
begin
lemma invs_on_rules:
  assumes a1: "f \<in> invariants N" and a2: "r \<in> rules N"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have b1: "(f=inv__1  )"
  apply (cut_tac a1, auto) done
    moreover {
      assume c1: "(f=inv__1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac a2 c1, metis lemma_inv__1_on_rules) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


theory Values imports
Main Archi AST BinNums Integers Floats
begin

(** This module defines the type of values that is used in the dynamic
  semantics of all our intermediate languages. *)

type_synonym block = positive

(** A value is either:
- a machine integer;
- a floating-point number;
- a pointer: a pair of a memory address and an integer offset with respect
  to this address;
- the [Vundef] value denoting an arbitrary bit pattern, such as the
  value of an uninitialized variable.
*)

datatype val =
    Vundef
  | Vint m_int
  | Vlong m_int64
  | Vfloat float64
  | Vsingle float32
  | Vptr block m_ptrofs

definition "Vtrue \<equiv> Vint 1"
definition "Vfalse \<equiv> Vint 0"

definition "Vnullptr \<equiv> Vlong 0"  (* only valid on 64-bit arch *)

definition Vptrofs :: "m_ptrofs \<Rightarrow> val" where
  "Vptrofs n \<equiv> Vlong n" (* only valid on 64-bit arch *)

lemma vptrofs_equ[iff]: "Vptrofs n = Vptrofs n' \<longleftrightarrow> n = n'"
  unfolding Vptrofs_def by simp

section \<open>Operations over values\<close>

(** The module [Val] defines a number of arithmetic and logical operations
  over type [val].  Most of these operations are straightforward extensions
  of the corresponding integer or floating-point operations. *)

locale Val'
begin

fun has_type :: "val \<Rightarrow> type \<Rightarrow> bool" where
  "has_type v t =
  (case (v, t) of
    (Vundef, _) \<Rightarrow> True
  | (Vint _, Tint) \<Rightarrow> True
  | (Vlong _, Tlong) \<Rightarrow> True
  | (Vfloat _, Tfloat) \<Rightarrow> True
  | (Vsingle _, Tsingle) \<Rightarrow> True
  | (Vptr _ _, Tint) \<Rightarrow> Archi.ptr64 = False
  | (Vptr _ _, Tlong) \<Rightarrow> Archi.ptr64 = True
  | (Vint _, Tany32) \<Rightarrow> True
  | (Vsingle _, Tany32) \<Rightarrow> True
  | (Vptr _ _, Tany32) \<Rightarrow> Archi.ptr64 = False
  | (_, Tany64) \<Rightarrow> True
  | (_, _) \<Rightarrow> False
  )"

fun has_rettype :: "val \<Rightarrow> rettype \<Rightarrow> bool" where
  "has_rettype v (Tret t) = has_type v t"
| "has_rettype (Vint n) Tint8signed = (n = Int.sign_ext TYPE(8) n)"
| "has_rettype (Vint n) Tint8unsigned = (n = Int.zero_ext TYPE(8) n)"
| "has_rettype (Vint n) Tint16signed = (n = Int.sign_ext TYPE(16) n)"
| "has_rettype (Vint n) Tint16unsigned = (n = Int.zero_ext TYPE(16) n)"
| "has_rettype Vundef _ = True"
| "has_rettype _ _ = False"

(** Truth values.  Non-zero integers are treated as [True].
  The integer 0 (also used to represent the null pointer) is [False].
  Other values are neither true nor false. *)

fun bool_to_val where
  "bool_to_val False = Vfalse"
| "bool_to_val True = Vtrue"

inductive bool_of_val :: "val \<Rightarrow> bool \<Rightarrow> bool" where
  bool_of_val_int: "(n \<noteq> 0) = b \<Longrightarrow> bool_of_val (Vint n) b"

lemma bool_of_val_one: "bool_of_val v False \<Longrightarrow> bool_of_val v True \<Longrightarrow> P"
  by (metis bool_of_val.cases val.inject(1))

fun bool_of_val_func :: "val \<Rightarrow> bool option" where
  "bool_of_val_func (Vint n) = (if n = 0 then Some False else Some True)"
| "bool_of_val_func _ = None"

(** Arithmetic operations *)

fun neg :: "val \<Rightarrow> val" where
  "neg (Vint n) = Vint (- n)"
| "neg _ = Vundef"

fun negf :: "val \<Rightarrow> val" where
  "negf (Vfloat f) = Vfloat (- f)"
| "negf _ = Vundef"

fun absf :: "val \<Rightarrow> val" where
  "absf (Vfloat f) = Vfloat (abs f)"
| "absf _ = Vundef"

fun negfs :: "val \<Rightarrow> val" where
  "negfs (Vsingle f) = Vsingle (- f)"
| "negfs _ = Vundef"

fun absfs :: "val \<Rightarrow> val" where
  "absfs (Vsingle f) = Vsingle (abs f)"
| "absfs _ = Vundef"

(* fun intoffloat :: "val \<Rightarrow> (val option)" where
  "intoffloat (Vfloat f) = map_option Vint (Float.to_int f)"
| "intoffloat _ = None"

fun intuoffloat :: "val \<Rightarrow> (val option)" where
  "intuoffloat (Vfloat f) = map_option Vint (Float.to_intu f)"
| "intuoffloat _ = None"

fun floatofint :: "val \<Rightarrow> (val option)" where
  "floatofint (Vint n) = Some (Vfloat (Float.of_int n))"
| "floatofint _ = None"

fun floatofintu :: "val \<Rightarrow> (val option)" where
  "floatofintu (Vint n) = Some (Vfloat (Float.of_intu n))"
| "floatofintu _ = None"

fun intofsingle :: "val \<Rightarrow> (val option)" where
  "intofsingle (Vsingle f) = map_option Vint (Float32.to_int f)"
| "intofsingle _ = None"

fun intuofsingle :: "val \<Rightarrow> (val option)" where
  "intuofsingle (Vsingle f) = map_option Vint (Float32.to_intu f)"
| "intuofsingle _ = None"

fun singleofint :: "val \<Rightarrow> (val option)" where
  "singleofint (Vint n) = Some (Vsingle (Float32.of_int n))"
| "singleofint _ = None"

fun singleofintu :: "val \<Rightarrow> (val option)" where
  "singleofintu (Vint n) = Some (Vsingle (Float32.of_intu n))"
| "singleofintu _ = None" *)

fun negint :: "val \<Rightarrow> val" where
  "negint (Vint n) = Vint (- n)"
| "negint _ = Vundef"

fun notint :: "val \<Rightarrow> val" where
  "notint (Vint n) = Vint (not n)"
| "notint _ = Vundef"

fun of_bool :: "bool \<Rightarrow> val"  where
  "of_bool True = Vtrue"
| "of_bool False = Vfalse"

fun boolval :: "val \<Rightarrow> val" where
  "boolval (Vint n) = of_bool (n \<noteq> 0)"
| "boolval (Vptr b ofs) = Vtrue"
| "boolval _ = Vundef"

fun notbool :: "val \<Rightarrow> val" where
  "notbool (Vint n) = of_bool (n = 0)"
| "notbool (Vptr b ofs) = Vfalse"
| "notbool _ = Vundef"

fun zero_ext :: "'l::len itself \<Rightarrow> val \<Rightarrow> val" where
  "zero_ext nbits (Vint n) = Vint(Int.zero_ext nbits n)"
| "zero_ext nbits _ = Vundef"

fun sign_ext :: "'l::len itself \<Rightarrow> val \<Rightarrow> val" where
  "sign_ext nbits (Vint n) = Vint(Int.sign_ext nbits n)"
| "sign_ext nbits _ = Vundef"

(* fun singleoffloat :: "val \<Rightarrow> val" where
  "singleoffloat (Vfloat f) = Vsingle (Float.to_single f)"
| "singleoffloat _ = Vundef"

fun floatofsingle :: "val \<Rightarrow> val" where
  "floatofsingle (Vsingle f) = Vfloat (Float.of_single f)"
| "floatofsingle _ = Vundef" *)

fun add :: "val \<Rightarrow> val \<Rightarrow> val" where
  "add (Vint n1) (Vint n2) = Vint(Int.add n1 n2)"
| "add (Vptr b1 ofs1) (Vint n2) = (if Archi.ptr64 then Vundef else Vptr b1 (Ptrofs.add ofs1 (Ptrofs.of_int n2)))"
| "add (Vint n1) (Vptr b2 ofs2) = (if Archi.ptr64 then Vundef else Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int n1)))"
| "add _ _ = Vundef"

fun sub :: "val \<Rightarrow> val \<Rightarrow> val" where
  "sub v1 v2 =
  (case (v1, v2) of
    (Vint n1, Vint n2) \<Rightarrow> Vint (Int.sub n1 n2)
  | (Vptr b1 ofs1, Vint n2) \<Rightarrow> if Archi.ptr64 then Vundef else Vptr b1 (Ptrofs.sub ofs1 (Ptrofs.of_int n2))
  | (Vptr b1 ofs1, Vptr b2 ofs2) \<Rightarrow>
      if Archi.ptr64 then Vundef else
      if b1 = b2 then Vint(Ptrofs.to_int (Ptrofs.sub ofs1 ofs2)) else Vundef
  | (_, _) \<Rightarrow> Vundef
  )"

fun mul :: "val \<Rightarrow> val \<Rightarrow> val" where
  "mul (Vint n1) (Vint n2) = Vint(Int.mul n1 n2)"
| "mul _ _ = Vundef"

(* fun mulhs :: "val \<Rightarrow> val \<Rightarrow> val" where
  "mulhs (Vint n1) (Vint n2) = Vint(Int.mulhs n1 n2)"
| "mulhs _ _ = Vundef"

fun mulhu :: "val \<Rightarrow> val \<Rightarrow> val" where
  "mulhu (Vint n1) (Vint n2) = Vint(Int.mulhu n1 n2)"
| "mulhu _ _ = Vundef" *)

fun divs :: "val \<Rightarrow> val \<Rightarrow> (val option)" where
  "divs v1 v2 =
  (case (v1, v2) of
    (Vint n1, Vint n2) \<Rightarrow>
      if n2 = 0
      \<or> n1 = (Int.repr Int.min_signed) \<and> n2 = Int.mone
      then None
      else Some(Vint(Int.divs n1 n2))
  | (_, _) \<Rightarrow> None
  )"

fun mods :: "val \<Rightarrow> val \<Rightarrow> (val option)" where
  "mods v1 v2 =
  (case (v1, v2) of
    (Vint n1, Vint n2) \<Rightarrow>
      if n2 = 0
      \<or> n1 = (Int.repr Int.min_signed) \<and> n2 = Int.mone
      then None
      else Some(Vint(Int.mods n1 n2))
  | (_, _) \<Rightarrow> None
  )"

fun divu :: "val \<Rightarrow> val \<Rightarrow> (val option)" where
  "divu (Vint n1) (Vint n2) = (if n2 = 0 then None else Some(Vint(Int.divu n1 n2)))"
| "divu _ _ = None"

fun modu :: "val \<Rightarrow> val \<Rightarrow> (val option)" where
  "modu (Vint n1) (Vint n2) = (if n2 = 0 then None else Some(Vint(Int.modu n1 n2)))"
| "modu _ _ = None"

(* fun add_carry :: "val \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val" where
  "add_carry (Vint n1) (Vint n2) (Vint c) = Vint(Int.add_carry n1 n2 c)"
| "add_carry _ _ _ = Vundef"

fun sub_overflow :: "val \<Rightarrow> val \<Rightarrow> val" where
  "sub_overflow (Vint n1) (Vint n2) = Vint(Int.sub_overflow n1 n2 Int.zero)"
| "sub_overflow _ _ = Vundef"

fun negative :: "val \<Rightarrow> val" where
  "negative (Vint n) = Vint (Int.negative n)"
| "negative _ = Vundef" *)

fun and' :: "val \<Rightarrow> val \<Rightarrow> val" where
  "and' (Vint n1) (Vint n2) = Vint(Int.and' n1 n2)"
| "and' _ _ = Vundef"

fun or :: "val \<Rightarrow> val \<Rightarrow> val" where
  "or (Vint n1) (Vint n2) = Vint(Int.or n1 n2)"
| "or _ _ = Vundef"

fun xor' :: "val \<Rightarrow> val \<Rightarrow> val" where
  "xor' (Vint n1) (Vint n2) = Vint(Int.xor n1 n2)"
| "xor' _ _ = Vundef"

fun shl :: "val \<Rightarrow> val \<Rightarrow> val" where
  "shl v1 v2 =
  (case (v1, v2) of
    (Vint n1, Vint n2) \<Rightarrow>
     if Int.ltu n2 Int.iwordsize
     then Vint(Int.shl n1 n2)
     else Vundef
  | (_, _) \<Rightarrow> Vundef
  )"

fun shr :: "val \<Rightarrow> val \<Rightarrow> val" where
  "shr v1 v2 =
  (case (v1, v2) of
    (Vint n1, Vint n2) \<Rightarrow>
     if Int.ltu n2 Int.iwordsize
     then Vint(Int.shr n1 n2)
     else Vundef
  | (_, _) \<Rightarrow> Vundef
  )"

(* fun shr_carry :: "val \<Rightarrow> val \<Rightarrow> val" where
  "shr_carry v1 v2 =
  (case v1, v2 of
    Vint n1, Vint n2 \<Rightarrow>
     if Int.ltu n2 Int.iwordsize
     then Vint(Int.shr_carry n1 n2)
     else Vundef
  | _, _ \<Rightarrow> Vundef
  )" *)

(* fun shrx :: "val \<Rightarrow> val \<Rightarrow> (val option)" where
  "shrx v1 v2 =
  (case v1, v2 of
    Vint n1, Vint n2 \<Rightarrow>
     if Int.ltu n2 (Int.repr 31)
     then Some(Vint(Int.shrx n1 n2))
     else None
  | _, _ \<Rightarrow> None
  )" *)

fun shru :: "val \<Rightarrow> val \<Rightarrow> val" where
  "shru v1 v2 =
  (case (v1, v2) of
    (Vint n1, Vint n2) \<Rightarrow>
     if Int.ltu n2 Int.iwordsize
     then Vint(Int.shru n1 n2)
     else Vundef
  | (_, _) \<Rightarrow> Vundef
  )"

fun rol :: "val \<Rightarrow> val \<Rightarrow> val" where
  "rol (Vint n1) (Vint n2) = Vint(Int.rol n1 n2)"
| "rol _ _ = Vundef"

(* fun rolm :: "val \<Rightarrow> int \<Rightarrow> int \<Rightarrow> val" where
  "rolm (Vint n) amount mask = Vint(Int.rolm n amount mask)"
| "rolm _ amount mask = Vundef" *)

fun ror :: "val \<Rightarrow> val \<Rightarrow> val" where
  "ror (Vint n1) (Vint n2) = Vint(Int.ror n1 n2)"
| "ror _ _ = Vundef"

fun addf :: "val \<Rightarrow> val \<Rightarrow> val" where
  "addf (Vfloat f1) (Vfloat f2) = Vfloat(Float.add f1 f2)"
| "addf _ _ = Vundef"

fun subf :: "val \<Rightarrow> val \<Rightarrow> val" where
  "subf (Vfloat f1) (Vfloat f2) = Vfloat(Float.sub f1 f2)"
| "subf _ _ = Vundef"

fun mulf :: "val \<Rightarrow> val \<Rightarrow> val" where
  "mulf (Vfloat f1) (Vfloat f2) = Vfloat(Float.mul f1 f2)"
| "mulf _ _ = Vundef"

fun divf :: "val \<Rightarrow> val \<Rightarrow> val" where
  "divf (Vfloat f1) (Vfloat f2) = Vfloat(Float.div' f1 f2)"
| "divf _ _ = Vundef"

(* fun floatofwords :: "val \<Rightarrow> val \<Rightarrow> val" where
  "floatofwords (Vint n1) (Vint n2) = Vfloat (Float.from_words n1 n2)"
| "floatofwords _ _ = Vundef" *)

fun addfs :: "val \<Rightarrow> val \<Rightarrow> val" where
  "addfs (Vsingle f1) (Vsingle f2) = Vsingle(Float32.add f1 f2)"
| "addfs _ _ = Vundef"

fun subfs :: "val \<Rightarrow> val \<Rightarrow> val" where
  "subfs (Vsingle f1) (Vsingle f2) = Vsingle(Float32.sub f1 f2)"
| "subfs _ _ = Vundef"

fun mulfs :: "val \<Rightarrow> val \<Rightarrow> val" where
  "mulfs (Vsingle f1) (Vsingle f2) = Vsingle(Float32.mul f1 f2)"
| "mulfs _ _ = Vundef"

fun divfs :: "val \<Rightarrow> val \<Rightarrow> val" where
  "divfs (Vsingle f1) (Vsingle f2) = Vsingle(Float32.div' f1 f2)"
| "divfs _ _ = Vundef"

(** Operations on 64-bit integers *)

fun longofwords :: "val \<Rightarrow> val \<Rightarrow> val" where
  "longofwords (Vint n1) (Vint n2) = Vlong (Int64.ofwords n1 n2)"
| "longofwords _ _ = Vundef"

fun loword :: "val \<Rightarrow> val" where
  "loword (Vlong n) = Vint (Int64.loword n)"
| "loword _ = Vundef"

fun hiword :: "val \<Rightarrow> val" where
  "hiword (Vlong n) = Vint (Int64.hiword n)"
| "hiword _ = Vundef"

fun negl :: "val \<Rightarrow> val" where
  "negl (Vlong n) = Vlong (Int64.neg n)"
| "negl _ = Vundef"

fun notl :: "val \<Rightarrow> val" where
  "notl (Vlong n) = Vlong (Int64.not n)"
| "notl _ = Vundef"

fun longofint :: "val \<Rightarrow> val" where
  "longofint (Vint n) = Vlong (Int64.repr (Int.signed n))"
| "longofint _ = Vundef"

fun longofintu :: "val \<Rightarrow> val" where
  "longofintu (Vint n) = Vlong (Int64.repr (Int.unsigned n))"
| "longofintu _ = Vundef"

(* fun longoffloat :: "val \<Rightarrow> (val option)" where
  "longoffloat (Vfloat f) = map_option Vlong (Float.to_long f)"
| "longoffloat _ = None"

fun longuoffloat :: "val \<Rightarrow> (val option)" where
  "longuoffloat (Vfloat f) = map_option Vlong (Float.to_longu f)"
| "longuoffloat _ = None"

fun longofsingle :: "val \<Rightarrow> (val option)" where
  "longofsingle (Vsingle f) = map_option Vlong (Float32.to_long f)"
| "longofsingle _ = None"

fun longuofsingle :: "val \<Rightarrow> (val option)" where
  "longuofsingle (Vsingle f) = map_option Vlong (Float32.to_longu f)"
| "longuofsingle _ = None"

fun floatoflong :: "val \<Rightarrow> (val option)" where
  "floatoflong (Vlong n) = Some (Vfloat (Float.of_long n))"
| "floatoflong _ = None"

fun floatoflongu :: "val \<Rightarrow> (val option)" where
  "floatoflongu (Vlong n) = Some (Vfloat (Float.of_longu n))"
| "floatoflongu _ = None"

fun singleoflong :: "val \<Rightarrow> (val option)" where
  "singleoflong (Vlong n) = Some (Vsingle (Float32.of_long n))"
| "singleoflong _ = None"

fun singleoflongu :: "val \<Rightarrow> (val option)" where
  "singleoflongu (Vlong n) = Some (Vsingle (Float32.of_longu n))"
| "singleoflongu _ = None" *)

fun addl :: "val \<Rightarrow> val \<Rightarrow> val" where
  "addl (Vlong n1) (Vlong n2) = Vlong(Int64.add n1 n2)"
| "addl (Vptr b1 ofs1) (Vlong n2) = (if Archi.ptr64 then Vptr b1 (Ptrofs.add ofs1 (Ptrofs.of_int64 n2)) else Vundef)"
| "addl (Vlong n1) (Vptr b2 ofs2) = (if Archi.ptr64 then Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int64 n1)) else Vundef)"
| "addl _ _ = Vundef"

fun subl :: "val \<Rightarrow> val \<Rightarrow> val" where
  "subl v1 v2 =
  (case (v1, v2) of
    (Vlong n1, Vlong n2) \<Rightarrow> Vlong(Int64.sub n1 n2)
  | (Vptr b1 ofs1, Vlong n2) \<Rightarrow>
      if Archi.ptr64 then Vptr b1 (Ptrofs.sub ofs1 (Ptrofs.of_int64 n2)) else Vundef
  | (Vptr b1 ofs1, Vptr b2 ofs2) \<Rightarrow>
      if \<not>Archi.ptr64 then Vundef else
      if b1 = b2 then Vlong(Ptrofs.to_int64 (Ptrofs.sub ofs1 ofs2)) else Vundef
  | (_, _) \<Rightarrow> Vundef
  )"

fun mull :: "val \<Rightarrow> val \<Rightarrow> val" where
  "mull (Vlong n1) (Vlong n2) = Vlong(Int64.mul n1 n2)"
| "mull _ _ = Vundef"

(* fun mull' :: "val \<Rightarrow> val \<Rightarrow> val" where
  "mull' (Vint n1) (Vint n2) = Vlong(Int64.mul' n1 n2)"
| "mull' _ _ = Vundef"

fun mullhs :: "val \<Rightarrow> val \<Rightarrow> val" where
  "mullhs (Vlong n1) (Vlong n2) = Vlong(Int64.mulhs n1 n2)"
| "mullhs _ _ = Vundef"

fun mullhu :: "val \<Rightarrow> val \<Rightarrow> val" where
  "mullhu (Vlong n1) (Vlong n2) = Vlong(Int64.mulhu n1 n2)"
| "mullhu _ _ = Vundef" *)

fun divls :: "val \<Rightarrow> val \<Rightarrow> (val option)" where
  "divls v1 v2 =
  (case (v1, v2) of
    (Vlong n1, Vlong n2) \<Rightarrow>
      if Int64.eq n2 Int64.zero
      \<or> Int64.eq n1 (Int64.repr Int64.min_signed) \<and> Int64.eq n2 Int64.mone
      then None
      else Some(Vlong(Int64.divs n1 n2))
  | (_, _) \<Rightarrow> None
  )"

fun modls :: "val \<Rightarrow> val \<Rightarrow> (val option)" where
  "modls v1 v2 =
  (case (v1, v2) of
    (Vlong n1, Vlong n2) \<Rightarrow>
      if Int64.eq n2 Int64.zero
      \<or> Int64.eq n1 (Int64.repr Int64.min_signed) \<and> Int64.eq n2 Int64.mone
      then None
      else Some(Vlong(Int64.mods n1 n2))
  | (_, _) \<Rightarrow> None
  )"

fun divlu :: "val \<Rightarrow> val \<Rightarrow> (val option)" where
  "divlu (Vlong n1) (Vlong n2) = (if Int64.eq n2 Int64.zero then None else Some(Vlong(Int64.divu n1 n2)))"
| "divlu _ _ = None"

fun modlu :: "val \<Rightarrow> val \<Rightarrow> (val option)" where
  "modlu (Vlong n1) (Vlong n2) = (if Int64.eq n2 Int64.zero then None else Some(Vlong(Int64.modu n1 n2)))"
| "modlu _ _ = None"

(* fun addl_carry :: "val \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val" where
  "addl_carry (Vlong n1) (Vlong n2) (Vlong c) = Vlong(Int64.add_carry n1 n2 c)"
| "addl_carry _ _ _ = Vundef"

fun subl_overflow :: "val \<Rightarrow> val \<Rightarrow> val" where
  "subl_overflow (Vlong n1) (Vlong n2) = Vint (Int.repr (Int64.unsigned (Int64.sub_overflow n1 n2 Int64.zero)))"
| "subl_overflow _ _ = Vundef"

fun negativel :: "val \<Rightarrow> val" where
  "negativel (Vlong n) = Vint (Int.repr (Int64.unsigned (Int64.negative n)))"
| "negativel _ = Vundef" *)

fun andl :: "val \<Rightarrow> val \<Rightarrow> val" where
  "andl (Vlong n1) (Vlong n2) = Vlong(Int64.and' n1 n2)"
| "andl _ _ = Vundef"

fun orl :: "val \<Rightarrow> val \<Rightarrow> val" where
  "orl (Vlong n1) (Vlong n2) = Vlong(Int64.or n1 n2)"
| "orl _ _ = Vundef"

fun xorl :: "val \<Rightarrow> val \<Rightarrow> val" where
  "xorl (Vlong n1) (Vlong n2) = Vlong(Int64.xor n1 n2)"
| "xorl _ _ = Vundef"

fun shll :: "val \<Rightarrow> val \<Rightarrow> val" where
  "shll v1 v2 =
  (case (v1, v2) of
    (Vlong n1, Vint n2) \<Rightarrow>
     if Int.ltu n2 Int64.iwordsize'
     then Vlong(Int64.shl' n1 n2)
     else Vundef
  | (_, _) \<Rightarrow> Vundef
  )"

fun shrl :: "val \<Rightarrow> val \<Rightarrow> val" where
  "shrl v1 v2 =
  (case (v1, v2) of
    (Vlong n1, Vint n2) \<Rightarrow>
     if Int.ltu n2 Int64.iwordsize'
     then Vlong(Int64.shr' n1 n2)
     else Vundef
  | (_, _) \<Rightarrow> Vundef
  )"

fun shrlu :: "val \<Rightarrow> val \<Rightarrow> val" where
  "shrlu v1 v2 =
  (case (v1, v2) of
    (Vlong n1, Vint n2) \<Rightarrow>
     if Int.ltu n2 Int64.iwordsize'
     then Vlong(Int64.shru' n1 n2)
     else Vundef
  | (_, _) \<Rightarrow> Vundef
  )"

(* fun shrxl :: "val \<Rightarrow> val \<Rightarrow> (val option)" where
  "shrxl v1 v2 =
  (case v1, v2 of
    Vlong n1, Vint n2 \<Rightarrow>
     if Int.ltu n2 (Int.repr 63)
     then Some(Vlong(Int64.shrx' n1 n2))
     else None
  | _, _ \<Rightarrow> None
  )"

fun shrl_carry :: "val \<Rightarrow> val \<Rightarrow> val" where
  "shrl_carry v1 v2 =
  (case v1, v2 of
    Vlong n1, Vint n2 \<Rightarrow>
     if Int.ltu n2 Int64.iwordsize'
     then Vlong(Int64.shr_carry' n1 n2)
     else Vundef
  | _, _ \<Rightarrow> Vundef
  )" *)

fun roll :: "val \<Rightarrow> val \<Rightarrow> val" where
  "roll (Vlong n1) (Vint n2) = Vlong(Int64.rol n1 (Int64.repr (Int.unsigned n2)))"
| "roll _ _ = Vundef"

fun rorl :: "val \<Rightarrow> val \<Rightarrow> val" where
  "rorl (Vlong n1) (Vint n2) = Vlong(Int64.ror n1 (Int64.repr (Int.unsigned n2)))"
| "rorl _ _ = Vundef"

(* fun rolml :: "val \<Rightarrow> int \<Rightarrow> int64 \<Rightarrow> val" where
  "rolml (Vlong n) amount mask = Vlong(Int64.rolm n (Int64.repr (Int.unsigned amount)) mask)"
| "rolml _ amount mask = Vundef" *)

fun zero_ext_l :: "'l::len itself \<Rightarrow> val \<Rightarrow> val" where
  "zero_ext_l nbits (Vlong n) = Vlong(Int64.zero_ext nbits n)"
| "zero_ext_l nbits _ = Vundef"

fun sign_ext_l :: "'l::len itself \<Rightarrow> val \<Rightarrow> val" where
  "sign_ext_l nbits (Vlong n) = Vlong(Int64.sign_ext nbits n)"
| "sign_ext_l nbits _ = Vundef"

section \<open>Comparisons\<close>

fun cmp_bool :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> (bool option)" where
  "cmp_bool c (Vint n1) (Vint n2) = Some (Int.cmp c n1 n2)"
| "cmp_bool c _ _ = None"

fun cmp_different_blocks :: "comparison \<Rightarrow> (bool option)" where
  "cmp_different_blocks Ceq = Some False"
| "cmp_different_blocks Cne = Some True"
| "cmp_different_blocks _ = None"

fun cmpf_bool :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> (bool option)" where
  "cmpf_bool c (Vfloat f1) (Vfloat f2) = Some (Float.cmp c f1 f2)"
| "cmpf_bool c _ _ = None"

fun cmpfs_bool :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> (bool option)" where
  "cmpfs_bool c (Vsingle f1) (Vsingle f2) = Some (Float32.cmp c f1 f2)"
| "cmpfs_bool c _ _ = None"

fun cmpl_bool :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> (bool option)" where
  "cmpl_bool c (Vlong n1) (Vlong n2) = Some (Int64.cmp c n1 n2)"
| "cmpl_bool c _ _ = None"

fun of_optbool :: "(bool option) \<Rightarrow> val" where
  "of_optbool (Some True) = Vtrue"
| "of_optbool (Some False) = Vfalse"
| "of_optbool None = Vundef"

fun cmp :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val" where
  "cmp c v1 v2 = of_optbool (cmp_bool c v1 v2)"

fun cmpf :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val" where
  "cmpf c v1 v2 = of_optbool (cmpf_bool c v1 v2)"

fun cmpfs :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val" where
  "cmpfs c v1 v2 = of_optbool (cmpfs_bool c v1 v2)"

fun cmpl :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> (val option)" where
  "cmpl c v1 v2 = map_option of_bool (cmpl_bool c v1 v2)"

context
  fixes valid_ptr :: "block \<Rightarrow> Z \<Rightarrow> bool"
begin

definition "weak_valid_ptr b ofs \<equiv> valid_ptr b ofs \<or> valid_ptr b (ofs - 1)"

fun cmpu_bool :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> (bool option)" where
  "cmpu_bool c v1 v2 =
  (case (v1, v2) of
    (Vint n1, Vint n2) \<Rightarrow>
      Some (Int.cmpu c n1 n2)
  | (Vint n1, Vptr b2 ofs2) \<Rightarrow>
      if Archi.ptr64 then None else
      if Int.eq n1 Int.zero \<and> weak_valid_ptr b2 (Ptrofs.unsigned ofs2)
      then cmp_different_blocks c
      else None
  | (Vptr b1 ofs1, Vptr b2 ofs2) \<Rightarrow>
      if Archi.ptr64 then None else
      if b1 = b2 then
        if weak_valid_ptr b1 (Ptrofs.unsigned ofs1)
           \<and> weak_valid_ptr b2 (Ptrofs.unsigned ofs2)
        then Some (Ptrofs.cmpu c ofs1 ofs2)
        else None
      else
        if valid_ptr b1 (Ptrofs.unsigned ofs1)
           \<and> valid_ptr b2 (Ptrofs.unsigned ofs2)
        then cmp_different_blocks c
        else None
  | (Vptr b1 ofs1, Vint n2) \<Rightarrow>
      if Archi.ptr64 then None else
      if Int.eq n2 Int.zero \<and> weak_valid_ptr b1 (Ptrofs.unsigned ofs1)
      then cmp_different_blocks c
      else None
  | (_, _) \<Rightarrow> None
  )"

fun cmpu :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val" where
  "cmpu c v1 v2 = of_optbool (cmpu_bool c v1 v2)"

fun cmplu_bool :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> (bool option)" where
  "cmplu_bool c v1 v2 =
  (case (v1, v2) of
    (Vlong n1, Vlong n2) \<Rightarrow> Some (Int64.cmpu c n1 n2)
  | (Vlong n1, Vptr b2 ofs2) \<Rightarrow>
      if \<not>Archi.ptr64 then None else
      if Int64.eq n1 Int64.zero \<and> weak_valid_ptr b2 (Ptrofs.unsigned ofs2)
      then cmp_different_blocks c
      else None
  | (Vptr b1 ofs1, Vptr b2 ofs2) \<Rightarrow>
      if \<not>Archi.ptr64 then None else
      if b1 = b2 then
        if weak_valid_ptr b1 (Ptrofs.unsigned ofs1)
           \<and> weak_valid_ptr b2 (Ptrofs.unsigned ofs2)
        then Some (Ptrofs.cmpu c ofs1 ofs2)
        else None
      else
        if valid_ptr b1 (Ptrofs.unsigned ofs1)
           \<and> valid_ptr b2 (Ptrofs.unsigned ofs2)
        then cmp_different_blocks c
        else None
  | (Vptr b1 ofs1, Vlong n2) \<Rightarrow>
      if \<not>Archi.ptr64 then None else
      if Int64.eq n2 Int64.zero \<and> weak_valid_ptr b1 (Ptrofs.unsigned ofs1)
      then cmp_different_blocks c
      else None
  | (_, _) \<Rightarrow> None
  )"

fun cmplu :: "comparison \<Rightarrow> val \<Rightarrow> val \<Rightarrow> (val option)" where
  "cmplu c v1 v2 = map_option of_bool (cmplu_bool c v1 v2)"
end

(** Add the given offset to the given pointer. *)

fun offset_ptr :: "val \<Rightarrow> m_ptrofs \<Rightarrow> val" where
  "offset_ptr (Vptr b ofs) delta = Vptr b (ofs + delta)"
| "offset_ptr _ delta = Vundef"

(** [load_result] reflects the effect of storing a value with a given
  memory chunk, then reading it back with the same chunk.  Depending
  on the chunk and the type of the value, some normalization occurs.
  For instance, consider storing the integer value [0xFFF] on 1 byte
  at a given address, and reading it back.  If it is read back with
  chunk [Mint8unsigned], zero-extension must be performed, resulting
  in [0xFF].  If it is read back as a [Mint8signed], sign-extension is
  performed and [0xFFFFFFFF] is returned. *)

fun load_result :: "memory_chunk \<Rightarrow> val \<Rightarrow> val" where
  "load_result Mint8signed (Vint n) = Vint (Int.sign_ext TYPE(8) n)"
| "load_result Mint8unsigned (Vint n) = Vint (Int.zero_ext TYPE(8) n)"
| "load_result Mint16signed (Vint n) = Vint (Int.sign_ext TYPE(16) n)"
| "load_result Mint16unsigned (Vint n) = Vint (Int.zero_ext TYPE(16) n)"
| "load_result Mint32 (Vint n) = Vint n"
| "load_result Mint32 (Vptr b ofs) = (if Archi.ptr64 then Vundef else Vptr b ofs)"
| "load_result Mint64 (Vlong n) = Vlong n"
| "load_result Mint64 (Vptr b ofs) = (if Archi.ptr64 then Vptr b ofs else Vundef)"
| "load_result Mfloat32 (Vsingle f) = Vsingle f"
| "load_result Mfloat64 (Vfloat f) = Vfloat f"
| "load_result Many32 (Vint n) = Vint n"
| "load_result Many32 (Vsingle f) = Vsingle f"
| "load_result Many32 (Vptr b ofs) = (if Archi.ptr64 then Vundef else Vptr b ofs)"
| "load_result Many64 v = v"
| "load_result _ _ = Vundef"

(** The ``is less defined'' relation between values.
    A value is less defined than itself, and [Vundef] is
    less defined than any value. *)

inductive lessdef :: "val \<Rightarrow> val \<Rightarrow> bool" where
    lessdef_refl: "lessdef v v"
  | lessdef_undef: "lessdef Vundef v"

inductive lessdef_list :: "val list \<Rightarrow> val list \<Rightarrow> bool" where
    lessdef_list_nil:
      "lessdef_list [] []"
  | lessdef_list_cons:
      "lessdef v1 v2 \<Longrightarrow> lessdef_list vl1 vl2 \<Longrightarrow>
      lessdef_list (v1 # vl1) (v2 # vl2)"

section \<open>Values and memory injections\<close>

(** A memory injection [f] is a function from addresses to either [None]
  or [Some] of an address and an offset.  It defines a correspondence
  between the blocks of two memory states [m1] and [m2]:
- if [f b = None], the block [b] of [m1] has no equivalent in [m2];
- if [f b = Some(b', ofs)], the block [b] of [m2] corresponds to
  a sub-block at offset [ofs] of the block [b'] in [m2].
*)

type_synonym meminj = "block \<Rightarrow> (block * Z) option"

(** A memory injection defines a relation between values that is the
  identity relation, except for pointer values which are shifted
  as prescribed by the memory injection.  Moreover, [Vundef] values
  inject into any other value. *)

inductive inject :: "meminj \<Rightarrow> val \<Rightarrow> val \<Rightarrow> bool" where
    inject_int:
      "inject mi (Vint i) (Vint i)"
  | inject_long:
      "inject mi (Vlong i) (Vlong i)"
  | inject_float:
      "inject mi (Vfloat f) (Vfloat f)"
  | inject_single:
      "inject mi (Vsingle f) (Vsingle f)"
  | inject_ptr:
      "mi b1 = Some (b2, delta) \<Longrightarrow>
      ofs2 = ofs1 + (Int64.repr delta) \<Longrightarrow>
      inject mi (Vptr b1 ofs1) (Vptr b2 ofs2)"
  | val_inject_undef:
      "inject mi Vundef v"

inductive inject_list :: "meminj \<Rightarrow> val list \<Rightarrow> val list \<Rightarrow> bool" where
    inject_list_nil:
      "inject_list mi [] []"
  | inject_list_cons:
      "inject mi v v' \<Longrightarrow> inject_list mi vl vl' \<Longrightarrow>
      inject_list mi (v # vl) (v' # vl')"

end (* locale Val' *)

interpretation Val: Val' .

type_synonym meminj = Val.meminj

(** Monotone evolution of a memory injection. *)

definition inject_incr :: "meminj \<Rightarrow> meminj \<Rightarrow> bool" where
  "inject_incr f1 f2 \<equiv> \<forall> b b' delta. f1 b = Some(b', delta) \<longrightarrow> f2 b = Some(b', delta)"

(** The identity injection gives rise to the "less defined than" relation. *)

definition inject_id :: meminj where
  "inject_id b \<equiv> Some (b, 0)"

end


(* Author: Rene Thiemann, License: LGPL *)

theory Partial_Function_MR
imports Main
keywords "partial_function_mr" :: thy_decl
begin

subsection  \<open>Register the \isa{partial-function-mr} command\<close>
ML_file \<open>partial_function_mr.ML\<close>

subsection \<open>Register the "option"-monad\<close>

text \<open>Obviously, the map-function for the @{type option}-monad is @{term map_option}.\<close>

text \<open>First, derive the required identity lemma.\<close>

lemma option_map_id: "map_option (\<lambda> x. x) x = x"
  by (cases x, auto)

text \<open>Second, register @{term map_option} as being monotone.\<close>
lemma option_map_mono[partial_function_mono]:
  assumes mf: "mono_option B"
  shows "mono_option (\<lambda>f. map_option h (B f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b option" assume fg: "fun_ord option_ord f g"
  with mf
  have "option_ord (B f) (B g)" by (rule monotoneD[of _ _ _ f g])
  then show "option_ord (map_option h (B f)) (map_option h (B g))"
    unfolding flat_ord_def by auto
qed

text \<open>And finally perform the registration. We need
\begin{itemize}
\item a constructor for map: it takes a monadic term $mt$ of type \isa{mtT},
  a list of functions \isa{t-to-ss} with corresponding types in \isa{t-to-sTs},
  a resulting monadic type \isa{msT}, and it should return a monad term \isa{ms} of
  type \isa{msT} which
  is obtained by applying the functions on \isa{mt}. Although for the @{type option}-monad,
  the lengths of the lists will always be one, there might be more elements for monads having
  more than one type-parameter.
\item a function to perform type-construction for monads: it takes a list of fixed parameters
  and a list of flexible parameters and has to construct a monadic type out of these parameters.
  The user can freely choose which parameters should be fixed, and which are flexible.
  Only flexible parameters can be changes in the return type of each set of mutual recursive functions.
  Since in the @{type option}-monad we would like to be able to change the type-parameter, we ignore
  the fixed parameters here.
\item a function to deconstruct monadic types into fixed and flexible type arguments.
\item a compositionality theorem of the form @{term "map f (map g x) = map (f o g) x"}
\item an identity theorem of the form @{term "map (\<lambda> x. x) m = m"}
\end{itemize}
\<close>
declaration \<open>Partial_Function_MR.init
  "option"
  (fn (mt, t_to_ss, mtT, msT, t_to_sTs) =>
      list_comb (Const (@{const_name map_option}, t_to_sTs ---> mtT --> msT), t_to_ss) $ mt)
  (fn (_,argTs) => Type (@{type_name option}, argTs))
  (fn mT => ([],Term.dest_Type mT |> #2))
  @{thms option.map_comp}
  @{thms option_map_id}
\<close>

subsection \<open>Register the "tailrec"-monad\<close>

text \<open>For the "tailrec"-monad (which is the identity monad) we take the identity
  function as map, there are no flexible parameters, and the monadic type itself is
  the (only) fixed argument. As a consequence, we can only define tail-recursive and
  mutual recursive functions which share the same return type.\<close>

declaration \<open>Partial_Function_MR.init
  "tailrec"
  (fn (mt, t_to_ss, mtT, msT, t_to_sTs) => mt)
  (fn (commonT,_) => hd commonT)
  (fn mT => ([mT],[]))
  []
  []
\<close>

end


(*  Title:      HOL/Auth/OtwayReesBella.thy
    Author:     Giampaolo Bella, Catania University
*)

section{*Bella's version of the Otway-Rees protocol*}

theory OtwayReesBella imports Public begin

text{*Bella's modifications to a version of the Otway-Rees protocol taken from
the BAN paper only concern message 7. The updated protocol makes the goal of
key distribution of the session key available to A. Investigating the
principle of Goal Availability undermines the BAN claim about the original
protocol, that "this protocol does not make use of Kab as an encryption key,
so neither principal can know whether the key is known to the other". The
updated protocol makes no use of the session key to encrypt but informs A that
B knows it.*}

inductive_set orb :: "event list set"
 where

  Nil:  "[]\<in> orb"

| Fake: "\<lbrakk>evsa\<in> orb;  X\<in> synth (analz (knows Spy evsa))\<rbrakk>
         \<Longrightarrow> Says Spy B X  # evsa \<in> orb"

| Reception: "\<lbrakk>evsr\<in> orb;  Says A B X \<in> set evsr\<rbrakk>
              \<Longrightarrow> Gets B X # evsr \<in> orb"

| OR1:  "\<lbrakk>evs1\<in> orb;  Nonce NA \<notin> used evs1\<rbrakk>
         \<Longrightarrow> Says A B \<lbrace>Nonce M, Agent A, Agent B,
                   Crypt (shrK A) \<lbrace>Nonce NA, Nonce M, Agent A, Agent B\<rbrace>\<rbrace>
               # evs1 \<in> orb"

| OR2:  "\<lbrakk>evs2\<in> orb;  Nonce NB \<notin> used evs2;
           Gets B \<lbrace>Nonce M, Agent A, Agent B, X\<rbrace> \<in> set evs2\<rbrakk>
        \<Longrightarrow> Says B Server
                \<lbrace>Nonce M, Agent A, Agent B, X,
           Crypt (shrK B) \<lbrace>Nonce NB, Nonce M, Nonce M, Agent A, Agent B\<rbrace>\<rbrace>
               # evs2 \<in> orb"

| OR3:  "\<lbrakk>evs3\<in> orb;  Key KAB \<notin> used evs3;
          Gets Server
             \<lbrace>Nonce M, Agent A, Agent B,
               Crypt (shrK A) \<lbrace>Nonce NA, Nonce M, Agent A, Agent B\<rbrace>,
               Crypt (shrK B) \<lbrace>Nonce NB, Nonce M, Nonce M, Agent A, Agent B\<rbrace>\<rbrace>
          \<in> set evs3\<rbrakk>
        \<Longrightarrow> Says Server B \<lbrace>Nonce M,
                    Crypt (shrK B) \<lbrace>Crypt (shrK A) \<lbrace>Nonce NA, Key KAB\<rbrace>,
                                      Nonce NB, Key KAB\<rbrace>\<rbrace>
               # evs3 \<in> orb"

  (*B can only check that the message he is bouncing is a ciphertext*)
  (*Sending M back is omitted*)
| OR4:  "\<lbrakk>evs4\<in> orb; B \<noteq> Server; \<forall> p q. X \<noteq> \<lbrace>p, q\<rbrace>;
          Says B Server \<lbrace>Nonce M, Agent A, Agent B, X',
                Crypt (shrK B) \<lbrace>Nonce NB, Nonce M, Nonce M, Agent A, Agent B\<rbrace>\<rbrace>
            \<in> set evs4;
          Gets B \<lbrace>Nonce M, Crypt (shrK B) \<lbrace>X, Nonce NB, Key KAB\<rbrace>\<rbrace>
            \<in> set evs4\<rbrakk>
        \<Longrightarrow> Says B A \<lbrace>Nonce M, X\<rbrace> # evs4 \<in> orb"

| Oops: "\<lbrakk>evso\<in> orb;
           Says Server B \<lbrace>Nonce M,
                    Crypt (shrK B) \<lbrace>Crypt (shrK A) \<lbrace>Nonce NA, Key KAB\<rbrace>,
                                      Nonce NB, Key KAB\<rbrace>\<rbrace>
             \<in> set evso\<rbrakk>
 \<Longrightarrow> Notes Spy \<lbrace>Agent A, Agent B, Nonce NA, Nonce NB, Key KAB\<rbrace> # evso
     \<in> orb"

declare knows_Spy_partsEs [elim]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

text{*Fragile proof, with backtracking in the possibility call.*}
lemma possibility_thm: "\<lbrakk>A \<noteq> Server; B \<noteq> Server; Key K \<notin> used[]\<rbrakk>
      \<Longrightarrow>   \<exists> evs \<in> orb.
     Says B A \<lbrace>Nonce M, Crypt (shrK A) \<lbrace>Nonce Na, Key K\<rbrace>\<rbrace> \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] orb.Nil
                    [THEN orb.OR1, THEN orb.Reception,
                     THEN orb.OR2, THEN orb.Reception,
                     THEN orb.OR3, THEN orb.Reception, THEN orb.OR4])
apply (possibility, simp add: used_Cons)
done

lemma Gets_imp_Says :
     "\<lbrakk>Gets B X \<in> set evs; evs \<in> orb\<rbrakk> \<Longrightarrow> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule orb.induct)
apply auto
done

lemma Gets_imp_knows_Spy:
     "\<lbrakk>Gets B X \<in> set evs; evs \<in> orb\<rbrakk>  \<Longrightarrow> X \<in> knows Spy evs"
by (blast dest!: Gets_imp_Says Says_imp_knows_Spy)

declare Gets_imp_knows_Spy [THEN parts.Inj, dest]

lemma Gets_imp_knows:
     "\<lbrakk>Gets B X \<in> set evs; evs \<in> orb\<rbrakk>  \<Longrightarrow> X \<in> knows B evs"
by (metis Gets_imp_knows_Spy Gets_imp_knows_agents)

lemma OR2_analz_knows_Spy:
   "\<lbrakk>Gets B \<lbrace>Nonce M, Agent A, Agent B, X\<rbrace> \<in> set evs; evs \<in> orb\<rbrakk>
    \<Longrightarrow> X \<in> analz (knows Spy evs)"
by (blast dest!: Gets_imp_knows_Spy [THEN analz.Inj])

lemma OR4_parts_knows_Spy:
   "\<lbrakk>Gets B \<lbrace>Nonce M, Crypt (shrK B) \<lbrace>X, Nonce Nb, Key Kab\<rbrace>\<rbrace>  \<in> set evs;
      evs \<in> orb\<rbrakk>   \<Longrightarrow> X \<in> parts (knows Spy evs)"
by blast

lemma Oops_parts_knows_Spy:
    "Says Server B \<lbrace>Nonce M, Crypt K' \<lbrace>X, Nonce Nb, K\<rbrace>\<rbrace> \<in> set evs
     \<Longrightarrow> K \<in> parts (knows Spy evs)"
by blast

lemmas OR2_parts_knows_Spy =
    OR2_analz_knows_Spy [THEN analz_into_parts]

ML
{*
fun parts_explicit_tac i =
    forward_tac [@{thm Oops_parts_knows_Spy}] (i+7) THEN
    forward_tac [@{thm OR4_parts_knows_Spy}]  (i+6) THEN
    forward_tac [@{thm OR2_parts_knows_Spy}]  (i+4)
*}

method_setup parts_explicit = {*
    Scan.succeed (K (SIMPLE_METHOD' parts_explicit_tac)) *}
  "to explicitly state that some message components belong to parts knows Spy"

lemma Spy_see_shrK [simp]:
    "evs \<in> orb \<Longrightarrow> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule orb.induct, parts_explicit, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
"evs \<in> orb \<Longrightarrow> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "[|Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> orb|] ==> A \<in> bad"
by (blast dest: Spy_see_shrK)

lemma new_keys_not_used [simp]:
   "\<lbrakk>Key K \<notin> used evs; K \<in> symKeys; evs \<in> orb\<rbrakk>  \<Longrightarrow> K \<notin> keysFor (parts (knows Spy evs))"
apply (erule rev_mp)
apply (erule orb.induct, parts_explicit, simp_all)
apply (force dest!: keysFor_parts_insert)
apply (blast+)
done

subsection{* Proofs involving analz *}

text{*Describes the form of K and NA when the Server sends this message.  Also
  for Oops case.*}
lemma Says_Server_message_form:
"\<lbrakk>Says Server B  \<lbrace>Nonce M, Crypt (shrK B) \<lbrace>X, Nonce Nb, Key K\<rbrace>\<rbrace> \<in> set evs;
     evs \<in> orb\<rbrakk>
 \<Longrightarrow> K \<notin> range shrK & (\<exists> A Na. X=(Crypt (shrK A) \<lbrace>Nonce Na, Key K\<rbrace>))"
by (erule rev_mp, erule orb.induct, simp_all)

lemma Says_Server_imp_Gets:
 "\<lbrakk>Says Server B \<lbrace>Nonce M, Crypt (shrK B) \<lbrace>Crypt (shrK A) \<lbrace>Nonce Na, Key K\<rbrace>,
                                             Nonce Nb, Key K\<rbrace>\<rbrace> \<in> set evs;
    evs \<in> orb\<rbrakk>
  \<Longrightarrow>  Gets Server \<lbrace>Nonce M, Agent A, Agent B,
                   Crypt (shrK A) \<lbrace>Nonce Na, Nonce M, Agent A, Agent B\<rbrace>,
               Crypt (shrK B) \<lbrace>Nonce Nb, Nonce M, Nonce M, Agent A, Agent B\<rbrace>\<rbrace>
         \<in> set evs"
by (erule rev_mp, erule orb.induct, simp_all)

lemma A_trusts_OR1:
"\<lbrakk>Crypt (shrK A) \<lbrace>Nonce Na, Nonce M, Agent A, Agent B\<rbrace> \<in> parts (knows Spy evs);
    A \<notin> bad; evs \<in> orb\<rbrakk>
 \<Longrightarrow> Says A B \<lbrace>Nonce M, Agent A, Agent B, Crypt (shrK A) \<lbrace>Nonce Na, Nonce M, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs"
apply (erule rev_mp, erule orb.induct, parts_explicit, simp_all)
apply (blast)
done

lemma B_trusts_OR2:
 "\<lbrakk>Crypt (shrK B) \<lbrace>Nonce Nb, Nonce M, Nonce M, Agent A, Agent B\<rbrace>
      \<in> parts (knows Spy evs);  B \<notin> bad; evs \<in> orb\<rbrakk>
  \<Longrightarrow> (\<exists> X. Says B Server \<lbrace>Nonce M, Agent A, Agent B, X,
              Crypt (shrK B) \<lbrace>Nonce Nb, Nonce M, Nonce M, Agent A, Agent B\<rbrace>\<rbrace>
          \<in> set evs)"
apply (erule rev_mp, erule orb.induct, parts_explicit, simp_all)
apply (blast+)
done

lemma B_trusts_OR3:
"\<lbrakk>Crypt (shrK B) \<lbrace>X, Nonce Nb, Key K\<rbrace> \<in> parts (knows Spy evs);
   B \<notin> bad; evs \<in> orb\<rbrakk>
\<Longrightarrow> \<exists> M. Says Server B \<lbrace>Nonce M, Crypt (shrK B) \<lbrace>X, Nonce Nb, Key K\<rbrace>\<rbrace>
         \<in> set evs"
apply (erule rev_mp, erule orb.induct, parts_explicit, simp_all)
apply (blast+)
done

lemma Gets_Server_message_form:
"\<lbrakk>Gets B \<lbrace>Nonce M, Crypt (shrK B) \<lbrace>X, Nonce Nb, Key K\<rbrace>\<rbrace> \<in> set evs;
    evs \<in> orb\<rbrakk>
 \<Longrightarrow> (K \<notin> range shrK & (\<exists> A Na. X = (Crypt (shrK A) \<lbrace>Nonce Na, Key K\<rbrace>)))
             | X \<in> analz (knows Spy evs)"
by (metis B_trusts_OR3 Crypt_Spy_analz_bad Gets_imp_Says MPair_analz MPair_parts
          Says_Server_message_form Says_imp_analz_Spy Says_imp_parts_knows_Spy)

lemma unique_Na: "\<lbrakk>Says A B  \<lbrace>Nonce M, Agent A, Agent B, Crypt (shrK A) \<lbrace>Nonce Na, Nonce M, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs;
         Says A B' \<lbrace>Nonce M', Agent A, Agent B', Crypt (shrK A) \<lbrace>Nonce Na, Nonce M', Agent A, Agent B'\<rbrace>\<rbrace> \<in> set evs;
    A \<notin> bad; evs \<in> orb\<rbrakk> \<Longrightarrow> B=B' & M=M'"
by (erule rev_mp, erule rev_mp, erule orb.induct, simp_all, blast+)

lemma unique_Nb: "\<lbrakk>Says B Server \<lbrace>Nonce M, Agent A, Agent B, X, Crypt (shrK B) \<lbrace>Nonce Nb, Nonce M, Nonce M, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs;
         Says B Server \<lbrace>Nonce M', Agent A', Agent B, X', Crypt (shrK B) \<lbrace>Nonce Nb,Nonce M', Nonce M', Agent A', Agent B\<rbrace>\<rbrace> \<in> set evs;
    B \<notin> bad; evs \<in> orb\<rbrakk> \<Longrightarrow>   M=M' & A=A' & X=X'"
by (erule rev_mp, erule rev_mp, erule orb.induct, simp_all, blast+)

lemma analz_image_freshCryptK_lemma:
"(Crypt K X \<in> analz (Key`nE \<union> H)) \<longrightarrow> (Crypt K X \<in> analz H) \<Longrightarrow>
        (Crypt K X \<in> analz (Key`nE \<union> H)) = (Crypt K X \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

ML
{*
structure OtwayReesBella =
struct

val analz_image_freshK_ss =
  simpset_of
   (@{context} delsimps [image_insert, image_Un]
      delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
      addsimps @{thms analz_image_freshK_simps})

end
*}

method_setup analz_freshCryptK = {*
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac [allI, ballI, impI]),
          REPEAT_FIRST (rtac @{thm analz_image_freshCryptK_lemma}),
          ALLGOALS (asm_simp_tac
            (put_simpset OtwayReesBella.analz_image_freshK_ss ctxt))]))) *}
  "for proving useful rewrite rule"

method_setup disentangle = {*
    Scan.succeed
     (fn ctxt => SIMPLE_METHOD
      (REPEAT_FIRST (eresolve_tac [asm_rl, conjE, disjE]
                   ORELSE' hyp_subst_tac ctxt))) *}
  "for eliminating conjunctions, disjunctions and the like"

lemma analz_image_freshCryptK [rule_format]:
"evs \<in> orb \<Longrightarrow>
     Key K \<notin> analz (knows Spy evs) \<longrightarrow>
       (\<forall> KK. KK \<subseteq> - (range shrK) \<longrightarrow>
             (Crypt K X \<in> analz (Key`KK \<union> (knows Spy evs))) =
             (Crypt K X \<in> analz (knows Spy evs)))"
apply (erule orb.induct)
apply (analz_mono_contra)
apply (frule_tac [7] Gets_Server_message_form)
apply (frule_tac [9] Says_Server_message_form)
apply disentangle
apply (drule_tac [5] Gets_imp_knows_Spy [THEN analz.Inj, THEN analz.Snd, THEN analz.Snd, THEN  analz.Snd])
prefer 8 apply clarify
apply (analz_freshCryptK, spy_analz, fastforce)
done

lemma analz_insert_freshCryptK:
"\<lbrakk>evs \<in> orb;  Key K \<notin> analz (knows Spy evs);
         Seskey \<notin> range shrK\<rbrakk> \<Longrightarrow>
         (Crypt K X \<in> analz (insert (Key Seskey) (knows Spy evs))) =
         (Crypt K X \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshCryptK analz_image_freshK_simps)

lemma analz_hard:
"\<lbrakk>Says A B \<lbrace>Nonce M, Agent A, Agent B,
             Crypt (shrK A) \<lbrace>Nonce Na, Nonce M, Agent A, Agent B\<rbrace>\<rbrace> \<in>set evs;
   Crypt (shrK A) \<lbrace>Nonce Na, Key K\<rbrace> \<in> analz (knows Spy evs);
   A \<notin> bad; B \<notin> bad; evs \<in> orb\<rbrakk>
 \<Longrightarrow>  Says B A \<lbrace>Nonce M, Crypt (shrK A) \<lbrace>Nonce Na, Key K\<rbrace>\<rbrace> \<in> set evs"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule orb.induct)
apply (frule_tac [7] Gets_Server_message_form)
apply (frule_tac [9] Says_Server_message_form)
apply disentangle
txt{*letting the simplifier solve OR2*}
apply (drule_tac [5] Gets_imp_knows_Spy [THEN analz.Inj, THEN analz.Snd, THEN analz.Snd, THEN analz.Snd])
apply (simp_all (no_asm_simp) add: analz_insert_eq pushes split_ifs)
apply (spy_analz)
txt{*OR1*}
apply blast
txt{*Oops*}
prefer 4 apply (blast dest: analz_insert_freshCryptK)
txt{*OR4 - ii*}
prefer 3 apply (blast)
txt{*OR3*}
(*adding Gets_imp_ and Says_imp_ for efficiency*)
apply (blast dest:
       A_trusts_OR1 unique_Na Key_not_used analz_insert_freshCryptK)
txt{*OR4 - i *}
apply clarify
apply (simp add: pushes split_ifs)
apply (case_tac "Aaa\<in>bad")
apply (blast dest: analz_insert_freshCryptK)
apply clarify
apply simp
apply (case_tac "Ba\<in>bad")
apply (frule Gets_imp_knows_Spy [THEN analz.Inj, THEN analz.Snd, THEN analz.Decrypt, THEN analz.Fst] , assumption)
apply (simp (no_asm_simp))
apply clarify
apply (frule Gets_imp_knows_Spy
             [THEN parts.Inj, THEN parts.Snd, THEN B_trusts_OR3],
       assumption, assumption, assumption, erule exE)
apply (frule Says_Server_imp_Gets
            [THEN Gets_imp_knows_Spy, THEN parts.Inj, THEN parts.Snd,
            THEN parts.Snd, THEN parts.Snd, THEN parts.Fst, THEN A_trusts_OR1],
       assumption, assumption, assumption, assumption)
apply (blast dest: Says_Server_imp_Gets B_trusts_OR2 unique_Na unique_Nb)
done

lemma Gets_Server_message_form':
"\<lbrakk>Gets B \<lbrace>Nonce M, Crypt (shrK B) \<lbrace>X, Nonce Nb, Key K\<rbrace>\<rbrace>  \<in> set evs;
   B \<notin> bad; evs \<in> orb\<rbrakk>
  \<Longrightarrow> K \<notin> range shrK & (\<exists> A Na. X = (Crypt (shrK A) \<lbrace>Nonce Na, Key K\<rbrace>))"
by (blast dest!: B_trusts_OR3 Says_Server_message_form)

lemma OR4_imp_Gets:
"\<lbrakk>Says B A \<lbrace>Nonce M, Crypt (shrK A) \<lbrace>Nonce Na, Key K\<rbrace>\<rbrace> \<in> set evs;
   B \<notin> bad; evs \<in> orb\<rbrakk>
 \<Longrightarrow> (\<exists> Nb. Gets B \<lbrace>Nonce M, Crypt (shrK B) \<lbrace>Crypt (shrK A) \<lbrace>Nonce Na, Key K\<rbrace>,
                                             Nonce Nb, Key K\<rbrace>\<rbrace> \<in> set evs)"
apply (erule rev_mp, erule orb.induct, parts_explicit, simp_all)
prefer 3 apply (blast dest: Gets_Server_message_form')
apply blast+
done

lemma A_keydist_to_B:
"\<lbrakk>Says A B \<lbrace>Nonce M, Agent A, Agent B,
            Crypt (shrK A) \<lbrace>Nonce Na, Nonce M, Agent A, Agent B\<rbrace>\<rbrace> \<in>set evs;
   Gets A \<lbrace>Nonce M, Crypt (shrK A) \<lbrace>Nonce Na, Key K\<rbrace>\<rbrace> \<in> set evs;
   A \<notin> bad; B \<notin> bad; evs \<in> orb\<rbrakk>
  \<Longrightarrow> Key K \<in> analz (knows B evs)"
apply (drule Gets_imp_knows_Spy [THEN analz.Inj, THEN analz.Snd], assumption)
apply (drule analz_hard, assumption, assumption, assumption, assumption)
apply (drule OR4_imp_Gets, assumption, assumption)
apply (fastforce dest!: Gets_imp_knows [THEN analz.Inj] analz.Decrypt)
done

text{*Other properties as for the original protocol*}

end


\<^marker>\<open>creator Bernhard Pöttinger\<close>

chapter \<open>Pip: Acquire\<close>
theory Pip_Acquire
imports Pip_Shared
begin

paragraph \<open>Verification of PIP acquire operation\<close>

lemma search23:
  fixes i1 i2 i3 :: "('a,'b :: cancel_comm_monoid_add) fi"
  assumes "i1 + i2 + i3 \<noteq> bot"
  shows "i1 + i2 \<noteq> bot" "i1 + i3 \<noteq> bot" "i2 + i3 \<noteq> bot"
proof -
  show "i1 + i2 \<noteq> bot" using plus_fi_ops_exist(1)[of "i1 + i2" i3] using assms by simp
  have "i1 + i3 + i2 \<noteq> bot" using assms  by (simp add: algebra_simps)
  then show "i1 + i3 \<noteq> bot" using plus_fi_ops_exist(1)[of "i1 + i3" i2] by (simp add: algebra_simps)
  have "i2 + i3 + i1 \<noteq> bot" using assms  by (simp add: algebra_simps)
  then show "i2 + i3 \<noteq> bot" using plus_fi_ops_exist(1)[of "i2 + i3" i1] by (simp add: algebra_simps)
qed

lemma Max_sup_in:
  assumes "finite B" "A \<subseteq> B" "Max B \<in> A"
  shows "Max A = Max B"
  using assms
  by (meson Max.coboundedI Max_eqI in_mono infinite_super)

lemma XD1:
  assumes "ixs + fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (\<eta> xa) (max q0 (Max (insert t (set_mset (m - {#f#}))))) q0 m) n m) \<noteq> bot"
    and "\<eta> xa \<noteq> Some xa" "Max (insert q0 (set_mset m)) = max q0 (Max (insert t (set_mset (m - {#f#}))))"
  shows "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if Some y = \<eta> xa then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else {#}) + ixs \<noteq> bot"
proof -
  have "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if Some y = \<eta> xa then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else {#}) =
        fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (\<eta> xa) (max q0 (Max (insert t (set_mset (m - {#f#}))))) q0 m) n m)"
    apply (rule fi_cong)
    using assms by (simp_all split: fields.splits)
  then show ?thesis
    using assms by (simp add: algebra_simps)
qed

lemma XD2:
  assumes "ixs + fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields None (Max (insert x3 (set_mset m))) x3 m) n m) \<noteq> bot"
  shows "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. {#}) + ixs \<noteq> bot"
proof -
  have "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields None (Max (insert x3 (set_mset m))) x3 m) n m) =
        fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. {#})"
    by (rule fi_cong, simp_all)
  then show ?thesis
    using assms by (simp add: algebra_simps)
qed

lemma XD3:
  assumes "N1 = N2" "\<forall>n \<in> N1. i1 n = i2 n" "\<forall>n \<in> -N1. o1 n = o2 n"
  shows "if1 + fi N1 i1 o1 = fi N2 i2 o2 + if1"
  using assms
  apply (simp add: algebra_simps)
  apply (rule arg_cong[OF fi_cong])
  by (simp_all add: algebra_simps)

lemma XD4:
  assumes "fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm) + i' +
       fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m) \<noteq>
       bot" and "xa \<noteq> xb"
  shows "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if y = xb then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else {#}) + i' \<noteq> bot"
proof -
  let ?f = "Max (insert q0 (set_mset m))"
  let ?t = "max q0 (Max (insert t (set_mset (m - {#f#}))))"

  let ?ia = "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)"
  let ?ia' = "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if y = xb then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else outf_fi (fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)) y)"
  let ?ia'' = "fi {xa} (\<lambda>n. if n = xa then add_mset t (m - {#f#}) else {#}) (\<lambda>n. if n = xb then {#max q0 (Max (insert t (set_mset (m - {#f#}))))#} else outf_fi (fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)) n)"

  let ?ia4 = "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if y = xb then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else {#})"
  have ia4_ia': "?ia4 = ?ia'"
    by (rule fi_cong, auto)

  let ?ib = "fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)"
  let ?ib'' = "fi {xb}
   (\<lambda>n. add_mset (max q0 (Max (insert t (set_mset (m - {#f#})))))
        (inf_fi (fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m) + fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)) n))
   (\<lambda>n. if n = xb then {#} else edge xb (Fs xb) n mm)"

  have X: "?ia' = ?ia''"
    by (rule fi_cong, auto)
  have XX: "(?ia + ?ib) + i' \<noteq> bot"
    using assms by (simp add: algebra_simps)
  have Y: "?ia + ?ib = ?ia'' + ?ib''"
    apply (rule adjust_interface'[of ?ia ?ib xa xb "{#?t#}", symmetric, simplified])
     apply (fact plus_fi_ops_exist(1)[OF XX]) using assms by simp
  then have Z: "(?ia'' + i') + ?ib'' \<noteq> bot"
    using XX by (simp add: algebra_simps)
  then have "?ia'' + i' \<noteq> bot"
    using plus_fi_ops_exist(1) by auto
  then show ?thesis
    using X assms by (simp add: ia4_ia')
qed

lemma onI:
  assumes "\<And>x. x \<in> X \<Longrightarrow> f x = g x"
  shows "f = g on X"
  using assms by blast

lemma plus_fi_cancel_left:
  assumes "i2 = i2'"
  shows "i1 + i2 = i1 + i2'"
  using assms by simp

lemma plus_fi_cancel_rigtht:
  assumes "i1 = i1'"
  shows "i1 + i2 = i1' + i2"
  using assms by simp

lemmas plus_fi_cancel = plus_fi_cancel_left plus_fi_cancel_right

lemma update_correct:
  fixes i ix ixs :: "(fields ref, int multiset) fi"
  assumes "finite (dom_fi i)" "V \<subseteq> dom_fi i" "x \<notin> xs"
    and "i = ixs + fi {x}
      (\<lambda>_. inf_fi ix x - {# f #} + (if t \<ge>0 then {# t #} else {#})) (outf_fi ix)"
    and "i \<noteq> bot" "f < t"
    and "\<forall>x \<in> V. t \<in># fields_qs (Fs x)"
    and "\<forall>x' \<in> dom_fi i. case \<eta> x' of Some y \<Rightarrow> y \<in> {x} \<union> xs | _ \<Rightarrow> True"
    and "t \<ge> 0"
  shows "<ff.NI (\<eta> x) x (Fs x) m ix * ff.GrI \<eta> Fs xs ixs>
    update x f t
    <\<lambda>_. \<exists>\<^sub>AFs'. ff.GrI \<eta> Fs' ({x} \<union> xs) i>"
  using assms
  apply (induction V arbitrary: f Fs m ix ixs xs \<eta> rule: finite_induct_reverse[where F="dom_fi i" and a=x])

  (* base case*)
    apply (rule cons_pre_rule[OF ent_frame_fwd[OF ff.peek_NI]])
      apply frame_inference+

  subgoal for a F f Fs m ix ixs xs \<eta>
    apply (rule cons_pre_rule[OF ent_frame_fwd[OF ff.GrI_dom]])
      apply frame_inference+
    apply clarsimp

    apply (subst update.simps)
    apply (sep_auto simp: pip_simps heap: ll_simps ff.fold_GrI_rule[where g="\<eta> a"] split: fields.splits if_splits dest: in_diffD XD1)
    apply (intro ff.GrI_cong[of "insert a (dom_fi ixs)"] onI)
         apply simp
    apply simp
       apply auto[1]
      apply (rule XD3[symmetric])
        apply simp
       apply simp
    apply simp
   apply (sep_auto simp: pip_simps heap: ll_simps ff.fold_GrI_rule[where g="\<eta> a"] split: fields.splits dest: XD2)
   apply (rule ff.GrI_cong[OF _ eq_on_refl])
      apply simp
    apply simp
    apply (simp add: algebra_simps, rule arg_cong[OF fi_cong], simp, simp, simp)

  subgoal premises prems for q0 ia x
  proof -
    have "t \<in># m" "f < t"
      using prems by auto
    then have "Max (insert q0 (set_mset m)) = max q0 (Max (insert t (set_mset (m - {#f#}))))"
      apply (cases "m = {#}", simp, simp)
      by (smt Max.insert_remove Max.remove at_most_one_mset_mset_diff diff_single_trivial finite_set_mset max_def more_than_one_mset_mset_diff)
    then show ?thesis
      using prems by simp
  qed
  done

  (* Step case! *)
  subgoal for a F' f Fs m ix ixs xs \<eta>

    apply (rule cons_pre_rule[OF ent_frame_fwd[OF ff.GrI_dom]])
      apply frame_inference+

    apply (subst update.simps)
    apply (sep_auto simp: pip_simps heap: ll_simps ff.fold_GrI_rule split: fields.splits if_splits dest: in_diffD XD1)
    apply (intro ff.GrI_cong[of "insert a (dom_fi ixs)"] onI)
         apply simp
    apply simp
       apply auto[1]
      apply (rule XD3[symmetric])
        apply simp
       apply simp
    apply simp
   apply (sep_auto simp: pip_simps heap: ll_simps ff.fold_GrI_rule[where g="\<eta> a"] split: fields.splits dest: XD2)
   apply (rule ff.GrI_cong[OF _ eq_on_refl])
      apply simp
    apply simp
    apply (simp add: algebra_simps, rule arg_cong[OF fi_cong], simp, simp, simp)

   apply (case_tac "a \<in> F'")
   (* re-encounter some node *)
  subgoal premises prems for q0 xb
  proof -
    have "t \<in># m" "f < t"
      using prems by auto
    then have "Max (insert q0 (set_mset m)) = max q0 (Max (insert t (set_mset (m - {#f#}))))"
      apply (cases "m = {#}", simp, simp)
      by (smt Max.insert_remove Max.remove at_most_one_mset_mset_diff diff_single_trivial finite_set_mset max_def more_than_one_mset_mset_diff)
    then show ?thesis
      using prems by simp
  qed

  (* an actual step *)
  apply (sep_auto simp: pip_simps heap: ll_simps ff.fold_GrI_rule[where g="\<eta> a"] split: fields.splits dest: XD4)
  subgoal premises prems for q0 xb i' mm
  proof -
    let ?i1 = "fi {xb} (\<lambda>_. mm) (\<lambda>y. edge x (Fs x) y mm)"

    let ?f = "Max (insert q0 (set_mset m))"
    let ?t = "max q0 (Max (insert t (set_mset (m - {#f#}))))"

    have S: "?t = t"
      by (smt prems Max.insert_not_elem Max.insert_remove Max.remove Max_singleton at_most_one_mset_mset_diff finite_set_mset max_def more_than_one_mset_mset_diff)

    have "Max (insert q0 (set_mset m)) \<noteq> t"
      using prems S by simp
    then have SS: "Max (insert q0 (set_mset m)) < t"
      by (smt Max.insert_remove Max_in Max_insert S at_most_one_mset_mset_diff empty_not_insert finite_set_mset max_def more_than_one_mset_mset_diff prems set_mset_add_mset_insert singletonD)

    have tge0: "?t \<ge> 0" using prems by auto

    let ?ia = "fi {a} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = a then {#} else edge a (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)"
    let ?ia2 = "fi {a} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if y = xb then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else {#})"
    let ?ia3 = " fi {a} (\<lambda>n. if n = a then add_mset t (m - {#f#}) else {#})
      (\<lambda>n. if n = xb then {#max q0 (Max (insert t (set_mset (m - {#f#}))))#} else outf_fi (fi {a} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = a then {#} else edge a (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)) n)"

    have ia2_ia3: "?ia2 = ?ia3" by (rule fi_cong, auto)

    let ?ib = "fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)"
    let ?ib2 = "fi {xb} (\<lambda>_. inf_fi (fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)) xb + (if 0 \<le> max q0 (Max (insert t (set_mset (m - {#f#})))) then {#max q0 (Max (insert t (set_mset (m - {#f#}))))#} else {#}) - {#Max (insert q0 (set_mset m))#}) (outf_fi (fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)))"
    let ?ib3 = "fi {xb} (\<lambda>n. add_mset (max q0 (Max (insert t (set_mset (m - {#f#}))))) ((if n = xb then mm else {#}) - (if n = a then {#} else if n = a then {#} else edge a (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)))
      (\<lambda>n. if n = xb then {#} else edge xb (Fs xb) n mm)"

    have ib2_ib3: "?ib2 = ?ib3" apply (rule fi_cong) using tge0 S prems by (auto simp: algebra_simps)

    have nbot_iaibi': "(?ia + ?ib) + i' \<noteq> bot"
      using prems by (simp add: algebra_simps)
    have nbot_iaib: "?ia + ?ib \<noteq> bot"
      using plus_fi_ops_exist(1)[OF nbot_iaibi'] by simp

    have nbot_ia_ibi': "?ia + (?ib + i') \<noteq> bot"
      using prems by (simp add: algebra_simps)

    have nbot_ib_iai': "?ib + (?ia + i') \<noteq> bot"
      using prems by (simp add: algebra_simps)

    have nbot_ib_i'ia: "?ib + (i' + ?ia) \<noteq> bot"
      using prems by (simp add: algebra_simps)

    have iaib_ia2ib2: "?ia + ?ib = ?ia2 + ?ib2"
      using adjust_interface_mset'[of ?ia ?ib a xb "{#?t#}", OF nbot_iaib] ib2_ib3 ia2_ia3 prems
      by (simp add: algebra_simps)
    then have nbot_ia2ib2: "?ia2 + ?ib2 + i' \<noteq> bot"
      using nbot_iaibi' by (simp add: algebra_simps)

    have nbot_ib_i'ia2: "?ib2 + (i'  + ?ia2) \<noteq> bot"
      using prems iaib_ia2ib2 by (simp add: algebra_simps)

    have nbot: "?i1 \<noteq> bot" "i' \<noteq> bot" "?ib + i' \<noteq> bot" "i' + ?ia \<noteq> bot" "i' + ?ia2 \<noteq> bot"
      using plus_fi_ops_exist(1)[OF nbot_iaib] plus_fi_ops_exist(2)[OF nbot_iaib]
        plus_fi_ops_exist(2)[OF nbot_ia_ibi'] plus_fi_ops_exist(2)[OF nbot_ib_i'ia]
        plus_fi_ops_exist(2)[OF nbot_ib_i'ia2]
      by auto

    have *: "(?ib + ?ia) + i' \<noteq> bot"
      using prems by (simp add: algebra_simps)
    then have "?ib + ?ia \<noteq> bot"
      using plus_fi_ops_exist[OF *] by simp
    then have "inf_fi ?ib xb = inf_fi (?ib + ?ia) xb + outf_fi ?ia xb"
      using unfold_inf_fi[of ?ib ?ia xb] by simp

    have "{xb} \<union> insert a (dom_fi ixs - {xb}) = dom_fi i"
      using prems nbot by simp

    show ?thesis
      apply (subst S)+
      using prems iaib_ia2ib2 tge0 nbot
      apply (sep_auto heap: ent_star_mono[OF _ ff.GrI_cong] cons_rule[OF _ _
       prems(1)[of xb "insert a (dom_fi ixs - {xb})" _ _ _ "\<lambda>y. if y = a then Fields (Some xb) t q0 (add_mset t (m - {#f#})) else Fs y"]]
        simp: tge0 algebra_simps iaib_ia2ib2 nbot intro!: fi_cong ff.GrI_cong split: fields.splits)
      using S apply (simp add: algebra_simps)
      apply simp
      using S apply (simp add: algebra_simps)
      using S apply (simp add: algebra_simps)
      using SS apply simp
       apply (auto split: fields.splits)[1]
      apply (simp split: option.splits)
      apply (smt Un_iff dom_fi_fi dom_fi_plus_fi(1) fiI finite.emptyI finite_insert nbot(5) option.inject prems(9) singletonD)
      using nbot by simp
  qed
  done

  using assms apply simp
  done

lemma inf_fi_plus_fi1:
  assumes "x \<in> N1" "fi N1 i1 o1 + fi N2 i2 o2 \<noteq> bot"
  shows "inf_fi (fi N1 i1 o1 + fi N2 i2 o2) x = i1 x - o2 x"
proof -
  let ?i1 = "fi N1 i1 o1"
  let ?i2 = "fi N2 i2 o2"

  have "is_sum_fi ?i1 ?i2 (?i1 + ?i2)"
    using assms by (simp add: plus_fi_to_is_sum_fi)
  then have "inf_fi ?i1 = \<lambda>n. inf_fi (?i1 + ?i2) n + outf_fi ?i2 n on dom_fi ?i1"
    unfolding is_sum_fi_def by auto
  then have "i1 x = inf_fi (?i1 + ?i2) x + o2 x"
    using assms plus_fi_ops_exist[of ?i1 ?i2] dom_fi_plus_fi[of ?i1 ?i2] by auto
  then show ?thesis by simp
qed

lemma inf_fi_plus_fi2:
  assumes "x \<in> N2" "fi N1 i1 o1 + fi N2 i2 o2 \<noteq> bot"
  shows "inf_fi (fi N1 i1 o1 + fi N2 i2 o2) x = i2 x - o1 x"
proof -
  let ?i1 = "fi N1 i1 o1"
  let ?i2 = "fi N2 i2 o2"

  have "is_sum_fi ?i1 ?i2 (?i1 + ?i2)"
    using assms by (simp add: plus_fi_to_is_sum_fi)
  then have "inf_fi ?i2 = \<lambda>n. inf_fi (?i1 + ?i2) n + outf_fi ?i1 n on dom_fi ?i2"
    unfolding is_sum_fi_def by auto
  then have "i2 x = inf_fi (?i1 + ?i2) x + o1 x"
    using assms plus_fi_ops_exist[of ?i1 ?i2] dom_fi_plus_fi[of ?i1 ?i2] by auto
  then show ?thesis by simp
qed

lemmas pip_simps' = pip_simps fields_y'_def

lemma acquire_correct:
  assumes "p \<in> X" "r \<in> X" "p \<noteq> r" " \<eta> r = None" "i \<noteq> bot" "\<forall>x \<in> X. case \<eta> x of Some y \<Rightarrow> y \<in> X | _ \<Rightarrow> True"
  shows "<ff.GrI \<eta> Fs X i> acquire p r <\<lambda>_. \<exists>\<^sub>AFs'. ff.GrI (case \<eta> r of None \<Rightarrow> \<eta>(r := Some p) | _ \<Rightarrow> \<eta>(p := Some r)) Fs' X i>"
  unfolding acquire_def
  apply (rule cons_pre_rule[OF ent_frame_fwd[OF ff.GrI_dom]], frame_inference+)
  apply (sep_auto simp: pip_simps' heap: ll_simps split: fields.splits)
  using assms apply simp
  using assms apply simp
  apply (sep_auto simp: pip_simps' heap: ll_simps split: fields.splits)
  using assms apply simp
  using assms apply simp
  using assms dom_fi_plus_fi(2) apply fastforce
  apply (sep_auto simp: pip_simps' heap: ll_simps split: fields.splits)
  using assms apply simp
    apply (sep_auto simp: pip_simps' heap: ll_simps ff.fold_GrI_rule[where g="Some p"] split: fields.splits)
  subgoal premises prems for m i'a x3 x4
  proof -
    let ?ir = "fi {r} (\<lambda>_. x4) (\<lambda>y. {#})"
    let ?ir' = "fi {r} (inf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. {#}))) (\<lambda>n. if n = p then {#Max_mset (x4 + {#x3#})#} else outf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. {#})) n)"
    let ?ir2 = "fi {r} (\<lambda>_. x4) (\<lambda>y. if y = p then {#Max_mset (x4 + {#x3#})#} else {#})"
    let ?ip = "fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)"
    let ?ip' = "fi {p} (\<lambda>n. inf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. {#}) + fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)) n + {#Max_mset (x4 + {#x3#})#}) (outf_fi (fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)))"

    have ir'_ir2: "?ir' = ?ir2"
      by (rule fi_cong, auto)

    have "(?ir + ?ip) + i'a \<noteq> bot" using assms prems by (simp add: algebra_simps)
    then have nbot: "?ir + ?ip \<noteq> bot" using plus_fi_ops_exist(1) by blast
    have "?ir' + ?ip' = ?ir + ?ip" using assms adjust_interface'[of ?ir ?ip r p "{#Max_mset (x4 + {#x3#})#}", OF nbot] by simp
    then have "?ir' + (?ip' + i'a) \<noteq> bot" using prems assms by (simp add: algebra_simps)
    then have "?ip' + (?ir' + i'a) \<noteq> bot" by (simp add: algebra_simps)
    then have "?ir' + i'a \<noteq> bot" using plus_fi_ops_exist(2) by blast
    with prems ir'_ir2 show False by simp
  qed
     apply (cases "Fs r", simp)
    apply (cases "Fs r", simp)
   apply simp

  subgoal for m i'a x3 x4 ia

    apply (rule cons_rule[OF _ _ update_correct[where V="{}"], of _ "\<lambda>y. if y = r then Some p else \<eta> y"_ "\<lambda>x. if x = r then Fields (Some p) (Max (insert x3 (set_mset x4))) x3 x4 else Fs x"])
    using assms apply (simp add: algebra_simps)
              apply (rule ent_star_mono[OF ent_refl])
              apply (rule ff.GrI_cong)
                 apply simp
    apply (simp add: assms)
               apply simp
    apply simp
                 apply (rule ent_ex_preI)
                 apply (rule_tac x=Fs' in ent_ex_postI)
             apply (rule ff.GrI_cong _ eq_on_refl)
    apply (intro onI)
                    apply simp
               apply simp
    using assms search23 apply (auto simp: algebra_simps)[1]
             apply simp
            apply simp
           apply simp
    using assms apply simp
    subgoal premises prems
    proof -
      let ?ip = "fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)"
      let ?ip' = "fi {p} (\<lambda>_. inf_fi (fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)) p - {#- 1#} + (if 0 \<le> Max (insert x3 (set_mset x4)) then {#Max (insert x3 (set_mset x4))#} else {#})) (outf_fi (fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)))"
      let ?ip2 = "fi {p} (\<lambda>n. inf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. {#}) + fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)) n + {#Max_mset (x4 + {#x3#})#}) (outf_fi (fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)))"

      let ?ir = "fi {r} (\<lambda>_. x4) (\<lambda>y. {#})"
      let ?ir' = "fi {r} (\<lambda>_. x4) (\<lambda>y. if y = p then {#Max_mset (x4 + {#x3#})#} else {#})"
      let ?ir2 = "fi {r} (inf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. {#}))) (\<lambda>n. if n = p then {#Max_mset (x4 + {#x3#})#} else outf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. {#})) n)"

      have "(?ir + ?ip) + i'a \<noteq> bot" using assms prems by (simp add: algebra_simps)
      then have nbot: "?ir + ?ip \<noteq> bot" using plus_fi_ops_exist(1) by blast

      have B: "-1 \<notin># m"
        using assms prems by (cases "Fs p", auto)

      have A1: "?ip' = ?ip2"
        apply (rule fi_cong)
        apply simp
        using assms prems apply simp
         apply (intro conjI)
        apply clarsimp
          apply (subst inf_fi_plus_fi2, simp)
        using nbot apply blast
          apply (simp add: B diff_single_trivial)
         apply (smt Max_ge finite_insert finite_set_mset insertI1)
        by blast

      have A2: "?ir' = ?ir2"
        by (rule fi_cong, auto)

      have "?ir2 + ?ip2 = ?ir + ?ip"
        using assms adjust_interface'[of ?ir ?ip r p "{#Max_mset (x4 + {#x3#})#}", OF nbot]
        by simp
      then show ?thesis
        using A1 A2 by (simp add: algebra_simps)
    qed
    subgoal premises prems
    proof -
      let ?ip = "fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)"
      let ?ip' = "fi {p} (\<lambda>_. inf_fi (fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)) p - {#- 1#} + (if 0 \<le> Max (insert x3 (set_mset x4)) then {#Max (insert x3 (set_mset x4))#} else {#})) (outf_fi (fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)))"
      let ?ip2 = "fi {p} (\<lambda>n. inf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. {#}) + fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)) n + {#Max_mset (x4 + {#x3#})#}) (outf_fi (fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)))"

      let ?ir = "fi {r} (\<lambda>_. x4) (\<lambda>y. {#})"
      let ?ir' = "fi {r} (\<lambda>_. x4) (\<lambda>y. if y = p then {#Max_mset (x4 + {#x3#})#} else {#})"
      let ?ir2 = "fi {r} (inf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. {#}))) (\<lambda>n. if n = p then {#Max_mset (x4 + {#x3#})#} else outf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. {#})) n)"

      have "(?ir + ?ip) + i'a \<noteq> bot" using assms prems by (simp add: algebra_simps)
      then have nbot: "?ir + ?ip \<noteq> bot" using plus_fi_ops_exist(1) by blast

      have B: "-1 \<notin># m"
        using assms prems by (cases "Fs p", auto)

      have A1: "?ip' = ?ip2"
        using assms prems
        by (smt B Max_ge add_mset_add_single diff_empty diff_single_trivial fiI fi_cong finite.emptyI finite_insert finite_set_mset inf_fi_fi inf_fi_plus_fi2 insertI1 nbot set_mset_add_mset_insert)

      have A2: "?ir' = ?ir2"
        by (rule fi_cong, auto)

      have "?ir2 + ?ip2 = ?ir + ?ip"
        using assms adjust_interface'[of ?ir ?ip r p "{#Max_mset (x4 + {#x3#})#}", OF nbot]
        by simp
      then show ?thesis
        using A1 A2 prems assms by (auto simp: algebra_simps)
    qed
       apply (case_tac x4, simp, simp)
      apply simp
    using assms apply (auto split: option.splits)[1]
    by (case_tac x4, simp, simp)

  apply (sep_auto simp: pip_simps' heap: ll_simps split: fields.splits)
  using assms apply simp
    apply (sep_auto simp: pip_simps' heap: ll_simps ff.fold_GrI_rule[where g="Some r"] split: fields.splits)
  subgoal premises prems for i'a x3 x4 y x3a x4a
  proof -
    let ?ir = "fi {r} (\<lambda>_. x4) (\<lambda>ya. if ya = y then {#Max_mset (x4 + {#x3#})#} else {#})"
    let ?ir2 = "fi {r} (inf_fi (fi {r} (\<lambda>_. x4) (\<lambda>ya. if ya = y then {#Max_mset (x4 + {#x3#})#} else {#})))
     (\<lambda>n. if n = p then {#Max_mset (x4 + {#x3#})#} else outf_fi (fi {r} (\<lambda>_. x4) (\<lambda>ya. if ya = y then {#Max_mset (x4 + {#x3#})#} else {#})) n)"
    let ?ip = "fi {p} (\<lambda>_. x4a) (\<lambda>y. if Some y = \<eta> p then {#Max_mset (x4a + {#x3a#})#} else {#})"
    let ?ip' = "fi {p} (\<lambda>_. x4a) (\<lambda>y. if y = r then {#Max_mset (x4a + {#x3a#})#} else {#})"
    let ?ip2 = "fi {p} (\<lambda>n. inf_fi (fi {r} (\<lambda>_. x4) (\<lambda>ya. if ya = y then {#Max_mset (x4 + {#x3#})#} else {#}) + fi {p} (\<lambda>_. x4a) (\<lambda>y. if Some y = \<eta> p then {#Max_mset (x4a + {#x3a#})#} else {#})) n + {#Max_mset (x4 + {#x3#})#})
     (outf_fi (fi {p} (\<lambda>_. x4a) (\<lambda>y. if Some y = \<eta> p then {#Max_mset (x4a + {#x3a#})#} else {#})))"

    have ir'_ir2: "?ip' = ?ip2"
      apply (rule fi_cong)
      using prems assms by auto

    have "(?ir + ?ip) + i'a \<noteq> bot" using assms prems by (simp add: algebra_simps)
    then have nbot: "?ir + ?ip \<noteq> bot" using plus_fi_ops_exist(1) by blast
    have "?ir2 + ?ip2 = ?ir + ?ip" using assms adjust_interface'[of ?ir ?ip r p "{#Max_mset (x4 + {#x3#})#}", OF nbot] by simp
    then have "?ir2 + (?ip' + i'a) \<noteq> bot" using prems assms by (simp add: algebra_simps)
    then have "?ip' + i'a \<noteq> bot" using plus_fi_ops_exist(2) by blast
    with prems ir'_ir2 show False by simp
  qed
     apply (cases "Fs r", simp)
    apply (cases "Fs r", simp)
   apply simp

  subgoal for i'a x3 x4 y x3a x4a ia

    apply (rule cons_rule[OF _ _ update_correct[where V="{}"], of _ "\<lambda>y. if y = p then Some r else \<eta> y"_ "\<lambda>x. if x = p then Fields (Some r) (Max (insert x3 (set_mset x4))) x3 x4 else Fs x" _
        "fi {r} (\<lambda>_. x4) (\<lambda>ya. if ya = y then {#Max_mset (x4 + {#x3#})#} else {#})" _
        "fi {p} (\<lambda>_. x4a) (\<lambda>y. if y = r then {#Max_mset (x4a + {#x3a#})#} else {#}) + i'a"])
    using assms apply (simp add: algebra_simps)
                 apply (rule ent_ex_preI)
                 apply (rule_tac x=Fs' in ent_ex_postI)
             apply (rule ff.GrI_cong _ eq_on_refl)
    apply (intro onI)
                    apply simp
               apply simp
    using assms search23 apply (auto simp: algebra_simps)[1]
    using assms by (auto simp: algebra_simps)
  done

end