(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Late_Bisim_SC
  imports Strong_Late_Bisim_Pres Strong_Late_Sim_SC
begin

lemma nilBisim[dest]:
  fixes a :: name
  and   b :: name
  and   x :: name
  and   P :: pi

  shows "\<tau>.(P) \<sim> \<zero> \<Longrightarrow> False"
  and   "a<x>.P \<sim> \<zero> \<Longrightarrow> False"
  and   "a{b}.P \<sim> \<zero> \<Longrightarrow> False"
  and   "\<zero> \<sim> \<tau>.(P) \<Longrightarrow> False"
  and   "\<zero> \<sim> a<x>.P \<Longrightarrow> False"
  and   "\<zero> \<sim> a{b}.P \<Longrightarrow> False"
by(auto dest: bisimE symmetric)

(******** Structural Congruence **********)

lemma matchId:
  fixes a :: name
  and   P :: pi

  shows "[a\<frown>a]P \<sim> P"
proof -
  let ?X = "{([a\<frown>a]P, P), (P, [a\<frown>a]P)}"
  have "([a\<frown>a]P, P) \<in> ?X" by simp
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: matchIdLeft matchIdRight reflexive)
qed

lemma matchNil:
  fixes a :: name
  and   b :: name

  assumes "a \<noteq> b"

  shows "[a\<frown>b]P \<sim> \<zero>"
proof -
  let ?X = "{([a\<frown>b]P, \<zero>), (\<zero>, [a\<frown>b]P)}"
  have "([a\<frown>b]P, \<zero>) \<in> ?X" by simp
  thus ?thesis using `a \<noteq> b`
    by(coinduct rule: bisimCoinduct) (auto intro: matchNilLeft nilSimRight reflexive)
qed

lemma mismatchId:
  fixes a :: name
  and   b :: name
  and   P :: pi

  assumes "a \<noteq> b"

  shows "[a\<noteq>b]P \<sim> P"
proof -
  let ?X = "{([a\<noteq>b]P, P), (P, [a\<noteq>b]P)}"
  have "([a\<noteq>b]P, P) \<in> ?X" by simp
  thus ?thesis using `a \<noteq> b`
    by(coinduct rule: bisimCoinduct) (auto intro: mismatchIdLeft mismatchIdRight reflexive)
qed

lemma nilRes:
  fixes x :: name

  shows "<\<nu>x>\<zero> \<sim> \<zero>"
proof -
  let ?X = "{(<\<nu>x>\<zero>, \<zero>), (\<zero>, <\<nu>x>\<zero>)}"
  have "(<\<nu>x>\<zero>, \<zero>) \<in> ?X" by simp
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: nilSimRight resNilRight)
qed

lemma resComm:
  fixes x :: name
  and   y :: name
  and   P :: pi

  shows "<\<nu>x><\<nu>y>P \<sim> <\<nu>y><\<nu>x>P"
proof -
  let ?X = "{(<\<nu>x><\<nu>y>P, <\<nu>y><\<nu>x>P) | x y P. True}"
  have "(<\<nu>x><\<nu>y>P, <\<nu>y><\<nu>x>P) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim xyP yxP)
    {
      fix x y P
      have "\<And>x y P. (<\<nu>x><\<nu>y>P, <\<nu>y><\<nu>x>P) \<in> ?X \<union> bisim" by auto
      moreover have "Id \<subseteq> ?X \<union> bisim" by(auto intro: reflexive)
      moreover have "eqvt ?X" by(force simp add: eqvt_def)
      hence "eqvt(?X \<union> bisim)" by auto
      ultimately have "<\<nu>x><\<nu>y>P \<leadsto>[(?X \<union> bisim)] <\<nu>y><\<nu>x>P" by(rule resComm)
    }
    with `(xyP, yxP) \<in> ?X` show ?case by auto
  next
    case(cSym xyP yxP)
    thus ?case by auto
  qed
qed

(******** The +-operator *********)

lemma sumSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<oplus> Q \<sim> Q \<oplus> P"
proof -
  let ?X = "{(P \<oplus> Q, Q \<oplus> P), (Q \<oplus> P, P \<oplus> Q)}"
  have "(P \<oplus> Q, Q \<oplus> P) \<in> ?X" by simp
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: reflexive sumSym)
qed

lemma sumIdemp:
  fixes P :: pi

  shows "P \<oplus> P \<sim> P"
proof -
  let ?X = "{(P \<oplus> P, P), (P, P \<oplus> P)}"
  have "(P \<oplus> P, P) \<in> ?X" by simp
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: reflexive sumIdempLeft sumIdempRight)
qed

(******** The |-operator *********)

lemma parZero:
  fixes P :: pi

  shows "P \<parallel> \<zero> \<sim> P"
proof -
  let ?X = "{(P \<parallel> \<zero>, P) | P. True} \<union> {(P, P \<parallel> \<zero>) | P . True}"
  have "(P \<parallel> \<zero>, P) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: bisimCoinduct, auto intro: parZeroRight parZeroLeft)
qed

lemma parSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<parallel> Q \<sim> Q \<parallel> P"
proof -
  let ?X = "{(resChain lst (P \<parallel> Q), resChain lst (Q \<parallel> P)) | lst P Q. True}"
  have "(P \<parallel> Q, Q \<parallel> P) \<in> ?X" by(blast intro: resChain.base[THEN sym])
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim PQ QP)
    {
      fix lst P Q
      have "\<And>P Q. (P \<parallel> Q, Q \<parallel> P) \<in> ?X \<union> bisim" by(blast intro: resChain.base[THEN sym])
      moreover have Res: "\<And>x P Q. (P, Q) \<in> ?X \<union> bisim \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?X \<union> bisim"
        by(auto intro: resPres resChain.step[THEN sym])
      ultimately have "P \<parallel> Q \<leadsto>[(?X \<union> bisim)] Q \<parallel> P" by(rule parSym)
      moreover have "eqvt ?X" by(force simp add: eqvt_def)
      hence "eqvt(?X \<union> bisim)" by auto
      ultimately have "resChain lst (P \<parallel> Q) \<leadsto>[(?X \<union> bisim)] resChain lst (Q \<parallel> P)" using Res
        by(rule resChainI)
    }
    with `(PQ, QP) \<in> ?X` show ?case by auto
  next
    case(cSym PQ QP)
    thus ?case by auto
  qed
qed

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<parallel> Q) \<sim> P \<parallel> <\<nu>x>Q"
proof -
  let ?X = "{(resChain lst (<\<nu>x>(P \<parallel> Q)), resChain lst (P \<parallel> <\<nu>x>Q)) | lst x P Q. x \<sharp> P} \<union>
            {(resChain lst (P \<parallel> <\<nu>x>Q), resChain lst (<\<nu>x>(P \<parallel> Q))) | lst x P Q. x \<sharp> P}"
  let ?Y = "bisim O (?X \<union> bisim) O bisim"

  have Res: "\<And>P Q x. (P, Q) \<in> ?X \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?X" by(blast intro: resChain.step[THEN sym])

  from `x \<sharp> P` have "(<\<nu>x>(P \<parallel> Q), P \<parallel> <\<nu>x>Q) \<in> ?X" by(blast intro: resChain.base[THEN sym])
  moreover have EqvtX: "eqvt ?X" by(fastforce simp add: eqvt_def name_fresh_left name_rev_per)
  ultimately show ?thesis
  proof(coinduct rule: bisimTransitiveCoinduct)
    case(cSim P Q)
    {
      fix P Q lst x
      assume "(x::name) \<sharp> (P::pi)"
      moreover have "Id \<subseteq> ?Y" by(blast intro: reflexive)
      moreover from `eqvt ?X` bisimEqvt have "eqvt ?Y" by blast
      moreover have "\<And>P Q x. x \<sharp> P \<Longrightarrow> (<\<nu>x>(P \<parallel> Q), P \<parallel> <\<nu>x>Q) \<in> ?Y"
        by(blast intro: resChain.base[THEN sym] reflexive)
      moreover {
        fix P Q x y
        have "<\<nu>x><\<nu>y>(P \<parallel> Q) \<sim> <\<nu>y><\<nu>x>(P \<parallel> Q)" by(rule resComm)
        moreover assume "x \<sharp> P"
        hence "(<\<nu>x>(P \<parallel> Q), P \<parallel> <\<nu>x>Q) \<in> ?X" by(fastforce intro: resChain.base[THEN sym])
        hence "(<\<nu>y><\<nu>x>(P \<parallel> Q), <\<nu>y>(P \<parallel> <\<nu>x>Q)) \<in> ?X" by(rule Res)
        ultimately have  "(<\<nu>x><\<nu>y>(P \<parallel> Q), <\<nu>y>(P \<parallel> <\<nu>x>Q)) \<in> ?Y" by(blast intro: reflexive)
      }
      ultimately have "<\<nu>x>(P \<parallel> Q) \<leadsto>[?Y] (P \<parallel> <\<nu>x>Q)" by(rule scopeExtParLeft)
      moreover note `eqvt ?Y`
      moreover from Res have "\<And>P Q x. (P, Q) \<in> ?Y \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?Y"
        by(blast intro: resChain.step[THEN sym] dest: resPres)
      ultimately have "resChain lst (<\<nu>x>(P \<parallel> Q)) \<leadsto>[?Y] resChain lst (P \<parallel> <\<nu>x>Q)"
        by(rule resChainI)
    }
    moreover {
      fix P Q lst x
      assume "(x::name) \<sharp> (P::pi)"
      moreover have "Id \<subseteq> ?Y" by(blast intro: reflexive)
      moreover from `eqvt ?X` bisimEqvt have "eqvt ?Y" by blast
      moreover have "\<And>P Q x. x \<sharp> P \<Longrightarrow> (P \<parallel> <\<nu>x>Q, <\<nu>x>(P \<parallel> Q)) \<in> ?Y"
        by(blast intro: resChain.base[THEN sym] reflexive)
      moreover {
        fix P Q x y
        have "<\<nu>y><\<nu>x>(P \<parallel> Q) \<sim> <\<nu>x><\<nu>y>(P \<parallel> Q)" by(rule resComm)
        moreover assume "x \<sharp> P"
        hence "(P \<parallel> <\<nu>x>Q, <\<nu>x>(P \<parallel> Q)) \<in> ?X" by(fastforce intro: resChain.base[THEN sym])
        hence "(<\<nu>y>(P \<parallel> <\<nu>x>Q), <\<nu>y><\<nu>x>(P \<parallel> Q)) \<in> ?X" by(rule Res)
        ultimately have  "(<\<nu>y>(P \<parallel> <\<nu>x>Q), <\<nu>x><\<nu>y>(P \<parallel> Q)) \<in> ?Y" by(blast intro: reflexive)
      }
      ultimately have "(P \<parallel> <\<nu>x>Q) \<leadsto>[?Y] <\<nu>x>(P \<parallel> Q)"
        by(rule scopeExtParRight)
      moreover note `eqvt ?Y`
      moreover from Res have "\<And>P Q x. (P, Q) \<in> ?Y \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?Y"
        by(blast intro: resChain.step[THEN sym] dest: resPres)
      ultimately have "resChain lst (P \<parallel> <\<nu>x>Q) \<leadsto>[?Y] resChain lst (<\<nu>x>(P \<parallel> Q))"
        by(rule resChainI)
    }
    ultimately show ?case using `(P, Q) \<in> ?X` by auto
  next
    case(cSym P Q)
    thus ?case
      by auto (blast dest: symmetric transitive intro: resChain.base[THEN sym] reflexive)+
  qed
qed

lemma scopeExtPar':
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes xFreshQ: "x \<sharp> Q"

  shows "<\<nu>x>(P \<parallel> Q) \<sim> (<\<nu>x>P) \<parallel> Q"
proof -
  have "<\<nu>x>(P \<parallel> Q) \<sim> <\<nu>x>(Q \<parallel> P)"
  proof -
    have "P \<parallel> Q \<sim> Q \<parallel> P" by(rule parSym)
    thus ?thesis by(rule resPres)
  qed
  moreover from xFreshQ have "<\<nu>x>(Q \<parallel> P) \<sim> Q \<parallel> (<\<nu>x>P)" by(rule scopeExtPar)
  moreover have "Q \<parallel> <\<nu>x>P \<sim> (<\<nu>x>P) \<parallel> Q" by(rule parSym)
  ultimately show ?thesis by(blast intro: transitive)
qed

  shows "(P \<parallel> Q) \<parallel> R \<sim> P \<parallel> (Q \<parallel> R)"
proof -
  let ?X = "{(resChain lst ((P \<parallel> Q) \<parallel> R), resChain lst (P \<parallel> (Q \<parallel> R))) | lst P Q R. True}"
  let ?Y = "bisim O (?X \<union> bisim) O bisim"

  have ResX: "\<And>P Q x. (P, Q) \<in> ?X \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?X"
    by(blast intro: resChain.step[symmetric])
  hence ResY: "\<And>P Q x. (P, Q) \<in> ?Y \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?Y"
    by(blast intro: resChain.step[symmetric] dest: resPres)

  have "((P \<parallel> Q) \<parallel> R, P \<parallel> (Q \<parallel> R)) \<in> ?X" by(blast intro: resChain.base[symmetric])
  moreover have "eqvt ?X" by(fastforce simp add: eqvt_def)
  ultimately show ?thesis
  proof(coinduct rule: bisimTransitiveCoinduct)
    case(cSim P Q)
    {
      fix P Q R lst
      have "\<And>P Q R. ((P \<parallel> Q) \<parallel> R, P \<parallel> (Q \<parallel> R)) \<in> ?Y" by(blast intro: reflexive resChain.base[symmetric])
      moreover have "\<And>P Q x. (P, Q) \<in> ?Y \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?Y" by(blast intro: resChain.step[symmetric] resPres)
      moreover {
        fix P Q R x
        have "(<\<nu>x>((P \<parallel> Q) \<parallel> R), <\<nu>x>(P \<parallel> (Q \<parallel> R))) \<in> ?X" by(rule_tac ResX) (blast intro: resChain.base[symmetric])
        moreover assume "x \<sharp> P"
        hence "<\<nu>x>(P \<parallel> (Q \<parallel> R)) \<sim> P \<parallel> <\<nu>x>(Q \<parallel> R)" by(rule scopeExtPar)
        ultimately have "(<\<nu>x>((P \<parallel> Q) \<parallel> R), P \<parallel> <\<nu>x>(Q \<parallel> R)) \<in> ?Y" by(blast intro: reflexive)
      }
      moreover {
        fix P Q R x
        have "(<\<nu>x>((P \<parallel> Q) \<parallel> R), <\<nu>x>(P \<parallel> (Q \<parallel> R))) \<in> ?X" by(rule_tac ResX) (blast intro: resChain.base[symmetric])
        moreover assume "x \<sharp> R"
        hence "<\<nu>x>(P \<parallel> Q) \<parallel> R \<sim> <\<nu>x>((P \<parallel> Q) \<parallel> R)" by(metis scopeExtPar' symmetric)
        ultimately have "(<\<nu>x>(P \<parallel> Q) \<parallel> R, <\<nu>x>(P \<parallel> (Q \<parallel> R))) \<in> ?Y" by(blast intro: reflexive)
      }
      ultimately have "(P \<parallel> Q) \<parallel> R \<leadsto>[?Y] P \<parallel> (Q \<parallel> R)" by(rule parAssocLeft)
      moreover from `eqvt ?X` bisimEqvt have "eqvt ?Y" by blast
      ultimately have "resChain lst ((P \<parallel> Q) \<parallel> R) \<leadsto>[?Y] resChain lst (P \<parallel> (Q \<parallel> R))" using ResY
        by(rule resChainI)
    }
    with `(P, Q) \<in> ?X` show ?case by auto
  next
    case(cSym P Q)
    {
      fix P Q R lst
      have "P \<parallel> (Q \<parallel> R) \<sim> (R \<parallel> Q) \<parallel> P" by(metis parPres parSym transitive)
      moreover have "((R \<parallel> Q) \<parallel> P, R \<parallel> (Q \<parallel> P)) \<in> ?X" by(blast intro: resChain.base[symmetric])
      moreover have "R \<parallel> (Q \<parallel> P) \<sim> (P \<parallel> Q) \<parallel> R" by(metis parPres parSym transitive)
      ultimately have "(P \<parallel> (Q \<parallel> R), (P \<parallel> Q) \<parallel> R) \<in> ?Y" by blast
      hence "(resChain lst (P \<parallel> (Q \<parallel> R)), resChain lst ((P \<parallel> Q) \<parallel> R)) \<in> ?Y" using ResY
        by(induct lst) auto
    }
    with `(P, Q) \<in> ?X` show ?case by blast
  qed
qed

  assumes "x \<sharp> P"

  shows "<\<nu>x>P \<sim> P"
proof -
  have "<\<nu>x>P \<sim> <\<nu>x>P \<parallel> \<zero>" by(rule parZero[THEN symmetric])

  moreover have "<\<nu>x>P \<parallel> \<zero> \<sim> \<zero> \<parallel> <\<nu>x>P" by(rule parSym)
  moreover have "\<zero> \<parallel> <\<nu>x>P \<sim> <\<nu>x>(\<zero> \<parallel> P)" by(rule scopeExtPar[THEN symmetric]) auto
  moreover have "<\<nu>x>(\<zero> \<parallel> P) \<sim> <\<nu>x>(P \<parallel> \<zero>)" by(rule resPres[OF parSym])
  moreover from `x \<sharp> P` have "<\<nu>x>(P \<parallel> \<zero>) \<sim> P \<parallel> <\<nu>x>\<zero>" by(rule scopeExtPar)
  moreover have  "P \<parallel> <\<nu>x>\<zero> \<sim> <\<nu>x>\<zero> \<parallel> P" by(rule parSym)
  moreover have "<\<nu>x>\<zero> \<parallel> P \<sim> \<zero> \<parallel> P" by(rule parPres[OF nilRes])
  moreover have "\<zero> \<parallel> P \<sim> P \<parallel> \<zero>" by(rule parSym)
  moreover have "P \<parallel> \<zero> \<sim> P" by(rule parZero)
  ultimately show ?thesis by(metis transitive)
qed

lemma sumRes:
  fixes x :: name
  and   P :: pi
  and   Q :: pi

  shows "<\<nu>x>(P \<oplus> Q) \<sim> (<\<nu>x>P) \<oplus> (<\<nu>x>Q)"
proof -
  let ?X = "{(<\<nu>x>(P \<oplus> Q), <\<nu>x>P \<oplus> <\<nu>x>Q) | x P Q. True} \<union>
            {(<\<nu>x>P \<oplus> <\<nu>x>Q, <\<nu>x>(P \<oplus> Q)) | x P Q. True}"
  have "(<\<nu>x>(P \<oplus> Q), <\<nu>x>P \<oplus> <\<nu>x>Q) \<in> ?X" by auto
  moreover have "eqvt ?X" by(fastforce simp add: eqvt_def)
  ultimately show ?thesis
    by(coinduct rule: bisimCoinduct) (fastforce intro: sumResLeft sumResRight reflexive)+
qed

lemma scopeExtSum:
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<oplus> Q) \<sim> P \<oplus> <\<nu>x>Q"
proof -
  have "<\<nu>x>(P \<oplus> Q) \<sim> <\<nu>x>P \<oplus> <\<nu>x>Q" by(rule sumRes)
  moreover from `x \<sharp> P` have "<\<nu>x>P \<oplus> <\<nu>x>Q \<sim> P \<oplus> <\<nu>x>Q"
    by(rule sumPres[OF scopeFresh])
  ultimately show ?thesis by(rule transitive)
qed

lemma bangSC:
  fixes P :: pi

  shows "!P \<sim> P \<parallel> !P"
proof -
  let ?X = "{(!P, P \<parallel> !P), (P \<parallel> !P, !P)}"
  have "(!P, P \<parallel> !P) \<in> ?X" by simp
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: bangLeftSC bangRightSC reflexive)
qed

lemma resNil:
  fixes x :: name
  and   y :: name
  and   P :: pi
  and   b :: name

  shows "<\<nu>x>x<y>.P \<sim> \<zero>"
  and   "<\<nu>x>x{b}.P \<sim> \<zero>"
proof -
  let ?X = "{(<\<nu>x>x<y>.P, \<zero>), (\<zero>, <\<nu>x>x<y>.P)}"
  have "(<\<nu>x>x<y>.P, \<zero>) \<in> ?X" by simp
  thus "<\<nu>x>x<y>.P \<sim> \<zero>"
    by(coinduct rule: bisimCoinduct) (auto simp add: simulation_def)
next
  let ?X = "{(<\<nu>x>x{b}.P, \<zero>), (\<zero>, <\<nu>x>x{b}.P)}"
  have "(<\<nu>x>x{b}.P, \<zero>) \<in> ?X" by simp
  thus "<\<nu>x>x{b}.P \<sim> \<zero>"
    by(coinduct rule: bisimCoinduct) (auto simp add: simulation_def)
qed

lemma resInput:
  fixes x :: name
  and   a :: name
  and   y :: name
  and   P :: pi

  assumes "x \<noteq> a"
  and     "x \<noteq> y"

  shows "<\<nu>x>a<y>.P \<sim> a<y>.(<\<nu>x>P)"
proof -
  let ?X = "{(<\<nu>x>a<y>.P, a<y>.(<\<nu>x>P)) | x a y P. x \<noteq> a \<and> x \<noteq> y} \<union>
            {(a<y>.(<\<nu>x>P), <\<nu>x>a<y>.P) | x a y P. x \<noteq> a \<and> x \<noteq> y}"
  from assms have "(<\<nu>x>a<y>.P, a<y>.(<\<nu>x>P)) \<in> ?X" by auto
  moreover have "eqvt ?X" by(fastforce simp add: eqvt_def pt_bij[OF pt_name_inst, OF at_name_inst])
  ultimately show ?thesis
    by(coinduct rule: bisimCoinduct) (fastforce intro: resInputLeft reflexive resInputRight)+
qed

lemma resOutput:
  fixes x :: name
  and   a :: name
  and   b :: name
  and   P :: pi

  assumes "x \<noteq> a"
  and     "x \<noteq> b"

  shows "<\<nu>x>a{b}.P \<sim> a{b}.(<\<nu>x>P)"
proof -
  let ?X = "{(<\<nu>x>a{b}.P, a{b}.(<\<nu>x>P)) | x a b P. x \<noteq> a \<and> x \<noteq> b} \<union>
            {(a{b}.(<\<nu>x>P), <\<nu>x>a{b}.P) | x a b P. x \<noteq> a \<and> x \<noteq> b}"
  from assms have "(<\<nu>x>a{b}.P, a{b}.(<\<nu>x>P)) \<in> ?X" by blast
  moreover have "eqvt ?X" by(fastforce simp add: eqvt_def pt_bij[OF pt_name_inst, OF at_name_inst])
  ultimately show ?thesis
    by(coinduct rule: bisimCoinduct) (fastforce intro: resOutputLeft resOutputRight reflexive)+
qed

lemma resTau:
  fixes x :: name
  and   P :: pi

  shows "<\<nu>x>\<tau>.(P) \<sim> \<tau>.(<\<nu>x>P)"
proof -
  let ?X = "{(<\<nu>x>\<tau>.(P), \<tau>.(<\<nu>x>P)), (\<tau>.(<\<nu>x>P), <\<nu>x>\<tau>.(P))}"
  have "(<\<nu>x>\<tau>.(P), \<tau>.(<\<nu>x>P)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (fastforce intro: resTauLeft resTauRight reflexive)+
qed

inductive structCong :: "pi \<Rightarrow> pi \<Rightarrow> bool" ("_ \<equiv>\<^sub>s _" [70, 70] 70)
where
  Refl: "P \<equiv>\<^sub>s P"
| Sym:  "P \<equiv>\<^sub>s Q \<Longrightarrow> Q \<equiv>\<^sub>s P"
| Trans: "\<lbrakk>P \<equiv>\<^sub>s Q; Q \<equiv>\<^sub>s R\<rbrakk> \<Longrightarrow> P \<equiv>\<^sub>s R"

| SumComm: "P \<oplus> Q \<equiv>\<^sub>s Q \<oplus> P"
| SumAssoc: "(P \<oplus> Q) \<oplus> R \<equiv>\<^sub>s P \<oplus> (Q \<oplus> R)"
| SumId: "P \<oplus> \<zero> \<equiv>\<^sub>s P"

| ParComm: "P \<parallel> Q \<equiv>\<^sub>s Q \<parallel> P"
| ParAssoc: "(P \<parallel> Q) \<parallel> R \<equiv>\<^sub>s P \<parallel> (Q \<parallel> R)"
| ParId: "P \<parallel> \<zero> \<equiv>\<^sub>s P"

| MatchId: "[a\<frown>a]P \<equiv>\<^sub>s P"

| ResNil: "<\<nu>x>\<zero> \<equiv>\<^sub>s \<zero>"
| ResComm: "<\<nu>x><\<nu>y>P \<equiv>\<^sub>s <\<nu>y><\<nu>x>P"
| ResSum: "<\<nu>x>(P \<oplus> Q) \<equiv>\<^sub>s <\<nu>x>P \<oplus> <\<nu>x>Q"
| ScopeExtPar: "x \<sharp> P \<Longrightarrow> <\<nu>x>(P \<parallel> Q) \<equiv>\<^sub>s P \<parallel> <\<nu>x>Q"
| InputRes: "\<lbrakk>x \<noteq> a; x \<noteq> y\<rbrakk> \<Longrightarrow> <\<nu>x>a<y>.P \<equiv>\<^sub>s a<y>.(<\<nu>x>P)"
| OutputRes: "\<lbrakk>x \<noteq> a; x \<noteq> b\<rbrakk> \<Longrightarrow> <\<nu>x>a{b}.P \<equiv>\<^sub>s a{b}.(<\<nu>x>P)"
| TauRes: "<\<nu>x>\<tau>.(P) \<equiv>\<^sub>s \<tau>.(<\<nu>x>P)"

| BangUnfold: "!P \<equiv>\<^sub>s P \<parallel> !P"

lemma structCongBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<equiv>\<^sub>s Q"

  shows "P \<sim> Q"
using assms
by(induct rule: structCong.induct)
  (auto intro: reflexive symmetric transitive sumSym sumAssoc sumZero parSym parAssoc parZero
               nilRes resComm resInput resOutput resTau sumRes scopeExtPar bangSC matchId mismatchId)

end


theory "Env-Nominal"
  imports Env "Nominal-Utils" "Nominal-HOLCF"
begin

subsubsection {* Equivariance lemmas  *}

lemma edom_perm:
  fixes f :: "'a::pt \<Rightarrow> 'b::{pcpo_pt}"
  shows "edom (\<pi> \<bullet> f) = \<pi> \<bullet> (edom f)"
  by (simp add: edom_def)

lemmas edom_perm_rev[simp,eqvt] = edom_perm[symmetric]

lemma mem_edom_perm[simp]:
  fixes \<rho> :: "'a::at_base \<Rightarrow> 'b::{pcpo_pt}"
  shows "xa \<in> edom (p \<bullet> \<rho>) \<longleftrightarrow> - p \<bullet> xa \<in> edom \<rho>"
  by (metis (mono_tags) edom_perm_rev mem_Collect_eq permute_set_eq)

lemma env_restr_eqvt[eqvt]:
  fixes m :: "'a::pt \<Rightarrow> 'b::{cont_pt,pcpo}"
  shows "\<pi> \<bullet> m f|` d = (\<pi> \<bullet> m) f|` (\<pi> \<bullet> d)"
  by (auto simp add: env_restr_def)

lemma override_on_eqvt[eqvt]:
  fixes m1 m2 :: "'a::pt \<Rightarrow> 'b::{cont_pt,pcpo}"
  shows "\<pi> \<bullet> m1 ++\<^bsub>S\<^esub> m2 = (\<pi> \<bullet> m1) ++\<^bsub>\<pi> \<bullet> S\<^esub> (\<pi> \<bullet> m2)"
  by (auto simp add: override_on_def )

subsubsection {* Permutation and restriction *}

lemma env_restr_perm:
  fixes \<rho> :: "'a::at_base \<Rightarrow> 'b::{pcpo_pt,pure}"
  assumes "supp p \<sharp>* S" and [simp]: "finite S"
  shows "(p \<bullet> \<rho>) f|` S = \<rho> f|` S"
using assms
apply -
apply (rule ext)
apply (case_tac "x \<in> S")
apply (simp)
apply (subst permute_fun_def)
apply (simp add: permute_pure)
apply (subst perm_supp_eq)
apply (auto simp add:perm_supp_eq supp_minus_perm fresh_star_def fresh_def supp_set_elem_finite)
done

lemma env_restr_flip:
  fixes \<rho> :: "'a::at \<Rightarrow> 'b::{pcpo_pt,pure}"
  assumes "x \<notin> S" and "x' \<notin> S"
  shows "((x' \<leftrightarrow> x) \<bullet> \<rho>) f|` S = \<rho> f|` S"
  using assms
  apply -
  apply rule
  apply (auto  simp add: permute_flip_at env_restr_def split:if_splits)
  by (metis eqvt_lambda flip_at_base_simps(3) minus_flip permute_pure unpermute_def)

end


theory Locale
  imports Main
begin

subsection \<open>definition\<close>

locale loc1

locale database0 =
  fixes update :: "'s \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> 's" ("_ [_ := _]")
    and query  :: "'s \<Rightarrow> 'k \<Rightarrow> 'v option" ("_ \<rhd> _")
(*    and add :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "+" 50) *)
  assumes updt_que: "s[k := v] \<rhd> k = Some v"
(*context database0*)
begin
thm database0_axioms
fun updates :: "'s \<Rightarrow> ('k \<times> 'v) list \<Rightarrow> 's"
  where "updates s [] = s" |
        "updates s ((k,v) # xs) = updates (update s k v) xs"

end

subsection \<open>extension\<close>

context database0
begin
definition queries :: "'s \<Rightarrow> 'k list \<Rightarrow> ('v option) list"
  where "queries s ks \<equiv> map (query s) ks"

thm database0.queries_def

end

definition (in database0) queries2 :: "'s \<Rightarrow> 'k list \<Rightarrow> ('v option) list"
  where "queries2 s ks \<equiv> map (query s) ks"

(*
context
begin
definition "fun1 \<equiv> \<lambda>x. Suc x"
end

lemma "fun1 2 = 3" unfolding fun1_def by simp
*)

term "database0"
thm database0_def
thm database0.queries_def
thm database0.queries2_def
thm database0.updates.simps
term database0.queries

subsection \<open>locale instance and expression\<close>

context
begin

definition "locexp1 \<equiv> database0"
thm database0_def
thm locexp1_def
term locexp1
term database0

type_synonym ('k,'v) store_map = "'k \<rightharpoonup> 'v"

fun update :: "('k,'v) store_map \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> ('k,'v) store_map"
  where "update m k v = m(k := Some v)"

definition query :: "('k,'v) store_map \<Rightarrow> 'k \<Rightarrow> 'v option"
  where "query m k = m k"

term "database0 update query"

lemma "database0 update query = (\<forall>s k v. query (update s k v) k = Some v)"
  by (simp add: database0_def query_def)

definition "locexp2 \<equiv> database0 update query"

lemma "locexp1 update query = True"
  unfolding locexp1_def database0_def query_def using update.simps by simp

lemma db0_lm: "database0 update query = True"
  unfolding database0_def query_def using update.simps by simp

term "database0 update"
lemma "database0 update = (\<lambda>q. \<forall>s k v. q (update s k v) k = Some v)"
  unfolding database0_def by simp

term "database0.queries query"
thm database0.queries_def

subsection \<open>locale interpretation\<close>

interpretation database0 update query
  using db0_lm by simp

thm queries_def
thm updates.simps
end

subsection \<open>sublocale\<close>

locale database1 =
  fixes update :: "'s1 \<Rightarrow> 'k1 \<Rightarrow> 'v1 \<Rightarrow> 's1" ("_ [_ := _]")
    and query  :: "'s1 \<Rightarrow> 'k1 \<Rightarrow> 'v1 option" ("_ \<rhd> _")
    and op2 :: "'k1 \<Rightarrow> 'v1"
  assumes updt_que: "s[k := v] \<rhd> k = Some v"

context database1
begin

(* thm queries_def *) (* error *)

sublocale database0
  unfolding database0_def using updt_que by simp

thm queries_def

end

sublocale database1 \<subseteq> database0 using database0_axioms by auto
sublocale database0 \<subseteq> database1 using database0_axioms
  by (simp add: database0_def database1_def)

locale database'1 = database0 update1 query1
  for update1 :: "'s \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> 's" ("_ [_ := _]")
    and query1  :: "'s \<Rightarrow> 'k \<Rightarrow> 'v option" ("_ \<rhd> _")
begin

thm queries_def

end

sublocale database'1 \<subseteq> database0 where update = update1 and query = query1
  using database0_axioms by auto

sublocale database'1 \<subseteq> database0 update1 query1
  using database0_axioms by auto

lemma "l1 < l2 \<Longrightarrow>l1 \<subseteq> l2"
  by auto

locale database'2 = database0
begin
thm queries_def
term update
end

locale database = database0 update query
  for update :: "'s \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> 's" ("_ [_ := _]")
    and query  :: "'s \<Rightarrow> 'k \<Rightarrow> 'v option" ("_ \<rhd> _")
  +
  fixes init :: 's
  assumes init_ : "\<forall>k. (init \<rhd> v) = None"
begin

thm queries_def
thm queries2_def

sublocale database0 using database0_axioms by simp

definition "suc x \<equiv> Suc x"

thm queries_def

end

thm database_def
thm database_axioms_def

sublocale database \<subseteq> database0 using database0_axioms by simp

thm database_def
thm database_axioms_def

print_locale database0

locale database' = database0 +
  fixes init :: 'a
  assumes init_ : "\<forall>k. init \<rhd> k = None"
begin

thm queries_def
thm queries2_def

sublocale database0 using database0_axioms by simp

thm queries_def

definition "suc x \<equiv> Suc (Suc x)"

end

sublocale database' < database0 using database0_axioms by simp
sublocale database' \<subseteq> database0 using database0_axioms by simp

subsection \<open>database example\<close>
locale db_list
begin
type_synonym ('k,'v) store_list = "('k \<times> 'v) list"

definition init :: "('k,'v) store_list"
  where "init \<equiv> []"

fun update :: "('k,'v) store_list \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> ('k,'v) store_list" ("_ [_ := _]")
  where "update [] k v = [(k,v)]" |
        "update (x # xs) k v = (if fst x = k then (k,v)#xs else x # update xs k v)"

primrec query :: "('k,'v) store_list \<Rightarrow> 'k \<Rightarrow> 'v option" ("_ \<rhd> _")
  where "query [] k = None" |
        "query (x # xs) k = (if fst x = k then Some (snd x) else query xs k)"

definition "suc_in_dblist x \<equiv> Suc x"

lemma lm_db_list_updtque: "((s[k := v]) \<rhd> k) = Some v"
  apply(induct s)
  using update.simps query.simps apply force
  using update.simps query.simps apply force
  done

lemma lm_db_list_init: "\<forall>k. init \<rhd> k = None"
  unfolding init_def using query.simps(1) by simp

thm database.intro
thm database0.intro

interpretation database update query init
  using lm_db_list_updtque lm_db_list_init
    database.intro[where query="query" and init="init"]
    database0.intro[where query="query"]
    database_axioms.intro[of query init] by force

interpretation database' update query init
  using lm_db_list_updtque lm_db_list_init
    database'.intro[where query="query" and init="init"]
    database0.intro[where query="query"]
    database'_axioms.intro[of query init] by force

lemma "queries (updates s [(k,v)]) [k] = [Some v]"
  by (simp add: db_list.lm_db_list_updtque queries_def)

thm suc_def
thm query.simps
thm updates.cases
thm queries_def

end

lemma "db_list.query (db_list.update s k v) k = Some v"
  by (simp add: db_list.lm_db_list_updtque)

thm db_list.query.simps
thm db_list.update.simps

print_locale db_list
print_locales

thm database0.queries_def

thm database0.queries_def

locale db_map
begin
type_synonym ('k,'v) store_map = "'k \<rightharpoonup> 'v"

definition init :: "('k,'v) store_map"
  where "init \<equiv> \<lambda>x. None"

fun update :: "('k,'v) store_map \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> ('k,'v) store_map" ("_ [_ := _]")
  where "update m k v = m(k := Some v)"

definition query :: "('k,'v) store_map \<Rightarrow> 'k \<Rightarrow> 'v option" ("_ \<rhd> _")
  where "query m k = m k"

lemma lm_db_map_updtque: "query (update m k v) k = Some v"
  using update.simps by (simp add: query_def)

lemma lm_db_map_init: "query init k = None"
  unfolding init_def query_def by simp

interpretation database update query init
  using lm_db_map_updtque lm_db_map_init
      database.intro[of update query]
      database0.intro[of query update]
      database_axioms.intro[of query init] by fastforce

thm update.simps

(*value "query (update init (1::int, ''aaa'')) (1::int)"*)

end

thm db_map.query_def

lemma (in db_map) "(init[(1::int) := ''aaa'']) \<rhd> (1::int) = Some ''aaa''"
  using lm_db_map_updtque by force

locale statemachine =
  fixes S0 :: "'s set"
  fixes step :: "'a \<Rightarrow> ('s \<times> 's) set"
begin

inductive_set r_states :: "'s set"
  where zero: "x \<in> S0 \<Longrightarrow> x \<in> r_states" |
        step: "\<lbrakk>x \<in> r_states; \<exists>e. (x,y)\<in>step e\<rbrakk> \<Longrightarrow> y \<in> r_states"

primrec run :: "'a list \<Rightarrow> ('s \<times> 's) set"
  where run_Nil: "run [] = Id" |
        run_Cons: "run (a#as) = step a O run as"

definition execute  :: "'a list \<Rightarrow> 's \<Rightarrow> 's set"
  where "execute as s = Image (run as) {s} "

(*
definition reachable :: "'s \<Rightarrow> 's \<Rightarrow> bool" ("(_ \<hookrightarrow> _)" [70,71] 60) where
  "reachable s1 s2 \<equiv>  (\<exists>as. (s1,s2) \<in> run as)"

definition reachable0 :: "'s \<Rightarrow> bool"  where
  "reachable0 s \<equiv> (\<exists>s0\<in>S0. reachable s0 s)"

lemma "r_states = {s. reachable0 s}"
proof
  {
    fix t
    assume "t\<in>r_states"
    then have "reachable0 t"
    proof (induct t)
      case (zero x)
      then show ?case using reachable0_def reachable_def run.simps by blast
    next
      case (step x y)
      assume a0: "x \<in> r_states"
        and  a1: "reachable0 x"
        and  a2: "\<exists>e. (x, y) \<in> step e"
      then obtain s0 and as where "s0\<in>S0 \<and> (s0,x) \<in> run as"
        unfolding reachable0_def reachable_def by auto
      moreover
      from a2 obtain e where "(x,y)\<in>step e" by auto
      ultimately have "(s0, y) \<in> run (as @ [e])" using run.simps(2)
        apply(induct as)
         apply simp

      ultimately show ?case unfolding reachable0_def reachable_def
        using exI[of "\<lambda>x. \<exists>as. (x, y) \<in> run as" s0]
    qed
  }
  then show "r_states \<subseteq> Collect reachable0" by auto

  {
    fix t
    assume "reachable0 t"
    have "t:r_states" sorry
  }
  then show "Collect reachable0 \<subseteq> r_states" by auto
qed
*)

end

locale statemachine_dt = statemachine +
  assumes oneinit: "card S0 = 1"
    and   determ: "\<forall>a s t r. (s, t)\<in>step a \<and> (s, r)\<in>step a \<longrightarrow> t = r"
    and   enabled0: "\<forall>s a. s\<in>r_states \<longrightarrow> (\<exists> s'. (s,s') \<in> step a)"
begin

sublocale statemachine .

end

print_locale statemachine

print_locale statemachine_dt

end


theory RCU_nostop imports RCU_Lems
begin

lemmas rcu_metis =
OpSemExtProof.c_obs_pres_write_diff_var_ext
OpSemExtProof.ext_write_other_pres_d_obs
OpSemExtProof.not_p_obs_other_pres_not_p_obs
OpSemExtProof.p_obs_contradiction
OpSem_ProofRules.d_obs_diff_false
getVWNC_var numeral_eq_iff
semiring_norm(89)
not_p_obs_other_value
neq0_conv
c_obs_write_diff_var_pres
lessI mod_less
mod_self
numeral_2_eq_2
ext_d_obs_rd_pres3
not_gr_zero
not_p_obs_value

lemmas rcu_simps =
OpSem_ProofRules.d_obs_diff_false
OpSemExtProof.ext_c_obs_rdx_pres
OpSemExtProof.not_p_obs_other_pres_not_p_obs
OpSemExtProof.not_p_obs_write_pres_c_obs_diff_var
OpSemExtProof.read_pres_wfs
OpSemExtProof.write_pres_wfs
OpSemExtProof.ext_d_obs_d_obs
OpSemExtProof.ext_write_other_pres_d_obs
OpSemExtProof.c_obs_read_d_obs
OpSemExtProof.read_pres_d_obs
OpSemExtProof.d_obs_read_value
enc_wr_prs
enc_intro
enc_rd_prs
getVWNC_var
not_p_obs_other_value
p_obs_contradiction_2
not_p_obs_value
read_pres_d_obs_other_var
no_val_read_pres
no_val_maintain
getVWNC_var not_p_obs_other_value
d_vorder_not_pobs

consts
  w  :: L
  r :: L
  m  :: L
  n1 :: L
  n2 :: L

definition "global s  \<equiv>
  wfs s \<and>
  w \<noteq> r \<and> w \<noteq> m \<and> w \<noteq> n1 \<and> w \<noteq> n2
\<and> r \<noteq> m \<and> r \<noteq> n1 \<and> r \<noteq> n2
\<and> m \<noteq> n1 \<and> m \<noteq> n2
\<and> n1 \<noteq> n2
"

lemmas opsemsyntax [simp] =  global_def

record RCU =
wr :: V
rr1 :: V
rr2 :: V
a :: nat
mb :: nat
\<sigma> :: surrey_state

(*
definition "r_inv wrv mbv rr1v rr2v av s \<equiv>
      (\<forall> j. j \<noteq> 0 \<and> j \<noteq> 1 \<longrightarrow> \<not> [ w \<approx>\<^sub>3 j] s)
     \<and> (\<forall> j. j \<noteq> 1 \<and> j \<noteq> 2 \<longrightarrow> \<not> [ m \<approx>\<^sub>3 j] s)
     \<and> [ w = 1]\<lparr> w =\<^sub>3 1\<rparr> s
     \<and> [ w = 1]\<lparr> m =\<^sub>3 (mbv mod 2 + 1)\<rparr> s
     \<and> ([w \<approx>\<^sub>3 1] s \<longrightarrow> [w =\<^sub>2 1] s)
     \<and> (rr2v = 1 \<longrightarrow> [ m =\<^sub>3 (mbv mod 2 + 1)] s \<and> [w =\<^sub>3 1] s)
     \<and> ([ r \<approx>\<^sub>2 1] s \<longrightarrow> rr2v = 1)
     \<and> av \<noteq> 0
     \<and> (mbv = 1 \<or> mbv = 2)
     \<and> ((\<not>[n1 \<approx>\<^sub>3 0] s  \<and> \<not>[n2 \<approx>\<^sub>3 0] s \<and> wrv = 0) \<or>
          (rr2v = 1 \<and> (mbv = 1 \<longrightarrow> \<not>[n2 \<approx>\<^sub>3 0] s) \<and> (mbv = 2 \<longrightarrow> \<not>[n1 \<approx>\<^sub>3 0] s)))
"
*)

definition "r_inv wrv mbv rr1v rr2v av s \<equiv>
      (\<forall> j. j \<noteq> 0 \<and> j \<noteq> 1 \<longrightarrow> \<not> [ w \<approx>\<^sub>3 j] s)
     \<and> (\<forall> j. j \<noteq> 1 \<and> j \<noteq> 2 \<longrightarrow> \<not> [ m \<approx>\<^sub>3 j] s)
     \<and> [ w = 1]\<lparr> w =\<^sub>3 1\<rparr> s
     \<and> [ w = 1]\<lparr> m =\<^sub>3 (mbv mod 2 + 1)\<rparr> s
     \<and> (rr2v = 1 \<longrightarrow> [ m =\<^sub>3 (mbv mod 2 + 1)] s \<and> [w =\<^sub>3 1] s)
     \<and> ([ r \<approx>\<^sub>2 1] s \<longrightarrow> rr2v = 1)
     \<and> av \<noteq> 0
     \<and> (mbv = 1 \<or> mbv = 2)
     \<and> ((\<not>[n1 \<approx>\<^sub>3 0] s  \<and> \<not>[n2 \<approx>\<^sub>3 0] s \<and> wrv = 0) \<or>
          (rr2v = 1 \<and> (mbv = 1 \<longrightarrow> \<not>[n2 \<approx>\<^sub>3 0] s) \<and> (mbv = 2 \<longrightarrow> \<not>[n1 \<approx>\<^sub>3 0] s)))
"

lemma RCU:
"
\<parallel>-   \<lbrace>global \<acute>\<sigma> \<and> (\<acute>wr = 0) \<and> (\<acute>rr1 = 0) \<and> (\<acute>rr2 = 0)
       \<and> \<acute>mb \<in> {1, 2} \<and> [ m =\<^sub>2 \<acute>mb]\<acute>\<sigma> \<and> [ m =\<^sub>3 \<acute>mb]\<acute>\<sigma>
       \<and> \<acute>a \<noteq> 0
       \<and> \<not>[n1 \<approx>\<^sub>3 0] \<acute>\<sigma> \<and> \<not>[n2 \<approx>\<^sub>3 0] \<acute>\<sigma>
       \<and> [ w =\<^sub>2 0]\<acute>\<sigma> \<and> [ w =\<^sub>3 0]\<acute>\<sigma> \<and> [ r =\<^sub>2 0]\<acute>\<sigma>  \<rbrace>
COBEGIN
  \<lbrace>global \<acute>\<sigma>
    \<and> [ w =\<^sub>2 0]\<acute>\<sigma> \<and> \<not> [ w \<approx>\<^sub>3 1]\<acute>\<sigma> \<and> [ m =\<^sub>2 \<acute>mb]\<acute>\<sigma>
    \<and> (\<forall> j. j \<noteq> 0 \<and> j \<noteq> 1 \<longrightarrow> \<not> [ r \<approx>\<^sub>2 j]\<acute>\<sigma>) \<and> \<acute>mb \<in>{1,2} \<rbrace>

  < m :=\<^sub>2 (\<acute>mb mod 2) + 1 \<acute>\<sigma>> ;;

  \<lbrace> global \<acute>\<sigma>
    \<and> [ w =\<^sub>2 0]\<acute>\<sigma> \<and> \<not> [ w \<approx>\<^sub>3 1]\<acute>\<sigma> \<and> [ m =\<^sub>2 (\<acute>mb mod 2 + 1)]\<acute>\<sigma>
    \<and> (\<forall> j. j \<noteq> 0 \<and> j \<noteq> 1 \<longrightarrow> \<not> [ r \<approx>\<^sub>2 j]\<acute>\<sigma>) \<and> \<acute>mb \<in>{1,2} \<rbrace>
   <w :=\<^sup>R\<^sub>2 1 \<acute>\<sigma>> ;;

   DO \<lbrace> global \<acute>\<sigma> \<and> (\<forall> j. j \<noteq> 0 \<and> j \<noteq> 1 \<longrightarrow> \<not> [ r \<approx>\<^sub>2 j]\<acute>\<sigma>) \<and> \<acute>mb \<in>{1,2}  \<rbrace>
     <\<acute>wr \<leftarrow>\<^sub>2 r\<acute>\<sigma>>
   UNTIL \<acute>wr = 1
   INV \<lbrace> global \<acute>\<sigma> \<and> (\<forall> j. j \<noteq> 0 \<and> j \<noteq> 1 \<longrightarrow> \<not> [ r \<approx>\<^sub>2 j] \<acute>\<sigma>) \<and> \<acute>mb \<in>{1,2} \<rbrace>
   OD ;;
   \<lbrace> global \<acute>\<sigma> \<and> \<acute>wr = 1 \<and> \<acute>mb \<in>{1,2} \<rbrace>
    IF \<acute>mb = 1
    THEN  \<lbrace> global \<acute>\<sigma> \<and> \<acute>wr = 1 \<and> \<acute>mb = 1  \<rbrace>
      < n1 :=\<^sub>2 0 \<acute>\<sigma>>
    ELSE \<lbrace> global \<acute>\<sigma> \<and> \<acute>wr = 1 \<and> \<acute>mb = 2 \<rbrace>
      < n2 :=\<^sub>2 0 \<acute>\<sigma>>
    FI
   \<lbrace> global \<acute>\<sigma> \<rbrace>

  \<parallel>

  \<lbrace> global \<acute>\<sigma>
     \<and> (\<forall> j. j \<noteq> 0 \<and> j \<noteq> 1 \<longrightarrow> \<not> [ w \<approx>\<^sub>3 j]\<acute>\<sigma>)
     \<and> (\<forall> j. j \<noteq> 1 \<and> j \<noteq> 2 \<longrightarrow> \<not> [ m \<approx>\<^sub>3 j]\<acute>\<sigma>)
     \<and> \<not> [ r \<approx>\<^sub>2 1]\<acute>\<sigma>
     \<and> [ w = 1]\<lparr> w =\<^sub>3 1\<rparr>\<acute>\<sigma> \<and> [ w = 1]\<lparr> m =\<^sub>3 (\<acute>mb mod 2 + 1)\<rparr> \<acute>\<sigma>
     \<and> ([w \<approx>\<^sub>3 1]\<acute>\<sigma> \<longrightarrow> [w =\<^sub>2 1]\<acute>\<sigma>)
     \<and> \<acute>rr1 = 0 \<and> \<acute>rr2 = 0  \<and> \<acute>wr = 0 \<and> \<acute>mb \<in> {1, 2}
     \<and> \<acute>a \<noteq> 0
     \<and> \<not>[n1 \<approx>\<^sub>3 0] \<acute>\<sigma> \<and> \<not>[n2 \<approx>\<^sub>3 0] \<acute>\<sigma>\<rbrace>

  WHILE \<acute>rr2 = 0 INV
  \<lbrace> global \<acute>\<sigma> \<and> r_inv \<acute>wr \<acute>mb \<acute>rr1 \<acute>rr2 \<acute>a \<acute>\<sigma> \<rbrace>
  DO
    \<lbrace> global \<acute>\<sigma> \<and> r_inv \<acute>wr \<acute>mb \<acute>rr1 \<acute>rr2 \<acute>a \<acute>\<sigma> \<rbrace>
      <\<acute>rr1 \<leftarrow>\<^sub>3 m \<acute>\<sigma>> ;;
    \<lbrace> global \<acute>\<sigma> \<and> r_inv \<acute>wr \<acute>mb \<acute>rr1 \<acute>rr2 \<acute>a \<acute>\<sigma>
      \<and> (\<acute>rr2 = 1 \<longrightarrow> \<acute>rr1 = (\<acute>mb mod 2) + 1)
      \<and> (\<acute>rr1 = 1 \<or> \<acute>rr1 = 2)
      \<rbrace>

    IF \<acute>rr1 = 1
    THEN  \<lbrace> global \<acute>\<sigma> \<and> r_inv \<acute>wr \<acute>mb \<acute>rr1 \<acute>rr2 \<acute>a \<acute>\<sigma>
      \<and> (\<acute>rr2 = 1 \<longrightarrow> \<acute>rr1 = (\<acute>mb mod 2) + 1)
      \<and> \<acute>rr1 = 1\<rbrace>
      <\<acute>a \<leftarrow>\<^sub>3 n1 \<acute>\<sigma>>
    ELSE \<lbrace> global \<acute>\<sigma> \<and> r_inv \<acute>wr \<acute>mb \<acute>rr1 \<acute>rr2 \<acute>a \<acute>\<sigma>
      \<and> (\<acute>rr2 = 1 \<longrightarrow> \<acute>rr1 = (\<acute>mb mod 2) + 1)
      \<and> \<acute>rr1 = 2\<rbrace>
      <\<acute>a \<leftarrow>\<^sub>3 n2 \<acute>\<sigma>>
    FI ;;

    \<lbrace> global \<acute>\<sigma> \<and> r_inv \<acute>wr \<acute>mb \<acute>rr1 \<acute>rr2 \<acute>a \<acute>\<sigma> \<rbrace>

     <\<acute>rr2 \<leftarrow>\<^sup>A\<^sub>3 w \<acute>\<sigma>>;;

    \<lbrace> global \<acute>\<sigma> \<and> r_inv \<acute>wr \<acute>mb \<acute>rr1 \<acute>rr2 \<acute>a \<acute>\<sigma> \<and> (\<acute>rr2 = 0 \<or> \<acute>rr2 = 1)  \<rbrace>

    <r :=\<^sub>3 \<acute>rr2 \<acute>\<sigma>>
  OD
  \<lbrace> global \<acute>\<sigma>  \<and> \<acute>a \<noteq> 0
 \<rbrace>

COEND
  \<lbrace>\<acute>a \<noteq> 0 \<rbrace>
"
  apply (oghoare; (simp add: rcu_simps r_inv_def Collect_conj_eq[symmetric] Collect_imp_eq[symmetric] Collect_disj_eq[symmetric] Collect_mono_iff )?; clarify)
  apply (auto simp add: rcu_simps)[2]
  apply linarith
  apply (smt OpSemExtProof.p_obs_contradiction d_obs_value ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 not_p_obs_value)
  apply (metis Suc_inject OpSemExtProof.ext_d_obs_d_obs OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs)
  apply (metis One_nat_def OpSemExtProof.p_obs_contradiction bits_one_mod_two_eq_one ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 neq0_conv not_p_obs_value numeral_2_eq_2)
  apply (metis OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 mod_self neq0_conv not_p_obs_value)
  apply (smt OpSemExtProof.c_obs_read_d_obs OpSemExtProof.c_obs_read_pres OpSemExtProof.p_obs_contradiction d_obs_value ext_d_obs_rd_pres3 not_gr_zero not_p_obs_value)
  apply (smt OpSemExtProof.c_obs_pres_write_diff_var_ext OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs getVWNC_var numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs getVWNC_var neq0_conv numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs getVWNC_var neq0_conv numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis getVWNC_var neq0_conv numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis getVWNC_var neq0_conv numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis getVWNC_var neq0_conv numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis getVWNC_var neq0_conv numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_write_diff_var_pres getVWNC_var mod_self numeral_2_eq_2 numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis OpSemExtProof.ext_c_obs_intro OpSemExtProof.ext_d_obs_d_obs c_obs_same_var_write_pres_diff getVWNC_var numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis OpSemExtProof.p_obs_contradiction OpSemExtProof.read_pres_d_obs ext_c_obs_read_diff_var_pres gr0I not_p_obs_value)
  apply (metis OpSemExtProof.p_obs_contradiction OpSemExtProof.read_pres_d_obs ext_c_obs_read_diff_var_pres not_gr0 not_p_obs_value)
  apply linarith
  apply linarith
  apply (smt One_nat_def OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_write_diff_var_pres d_obs_implies_p_obs getVWNC_var mod_self numeral_2_eq_2 numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (smt OpSemExtProof.ext_c_obs_intro OpSemExtProof.ext_d_obs_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_same_var_write_pres_diff d_obs_implies_p_obs getVWNC_var numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 not_gr_zero not_p_obs_value)
  apply (metis OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 not_gr_zero not_p_obs_value)
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_pres_write_diff_var_ext_2 numeral_eq_iff one_neq_zero semiring_norm(89))
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_pres_write_diff_var_ext_2 mod_self numeral_eq_iff one_neq_zero semiring_norm(89))
  apply (smt One_nat_def OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_write_diff_var_pres d_obs_implies_p_obs getVWNC_var mod_self numeral_2_eq_2 numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (smt OpSemExtProof.ext_c_obs_intro OpSemExtProof.ext_d_obs_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_same_var_write_pres_diff d_obs_implies_p_obs getVWNC_var numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 not_gr_zero not_p_obs_value)
  apply (metis OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 not_gr_zero not_p_obs_value)
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_pres_write_diff_var_ext_2 numeral_eq_iff one_neq_zero semiring_norm(89))
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_pres_write_diff_var_ext_2 mod_self numeral_eq_iff one_neq_zero semiring_norm(89))
  apply (smt One_nat_def OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_write_diff_var_pres d_obs_implies_p_obs getVWNC_var mod_self numeral_2_eq_2 numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (smt OpSemExtProof.ext_c_obs_intro OpSemExtProof.ext_d_obs_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_same_var_write_pres_diff d_obs_implies_p_obs getVWNC_var numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 gr0I not_p_obs_value)
  apply (metis OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 gr0I not_p_obs_value)
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_pres_write_diff_var_ext_2 numeral_eq_iff one_neq_zero semiring_norm(89))
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_pres_write_diff_var_ext_2 mod_self numeral_eq_iff one_neq_zero semiring_norm(89))
  apply (smt One_nat_def OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_write_diff_var_pres d_obs_implies_p_obs getVWNC_var mod_self numeral_2_eq_2 numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (smt OpSemExtProof.ext_c_obs_intro OpSemExtProof.ext_d_obs_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_same_var_write_pres_diff d_obs_implies_p_obs getVWNC_var numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (smt OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 gr0I nat.inject not_p_obs_value)
  apply (smt OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 gr0I nat.inject not_p_obs_value)
  apply (metis One_nat_def n_not_Suc_n one_mod_two_eq_one)
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_pres_write_diff_var_ext_2 numeral_eq_iff one_neq_zero semiring_norm(89))
  apply (smt One_nat_def OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_write_diff_var_pres d_obs_implies_p_obs getVWNC_var mod_self numeral_2_eq_2 numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (smt OpSemExtProof.ext_c_obs_intro OpSemExtProof.ext_d_obs_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_same_var_write_pres_diff d_obs_implies_p_obs getVWNC_var numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (smt OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 gr0I nat.inject not_p_obs_value numeral_2_eq_2)
  apply (smt OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 gr0I nat.inject not_p_obs_value numeral_2_eq_2)
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_pres_write_diff_var_ext_2 numeral_eq_iff one_neq_zero semiring_norm(89))
  apply (metis mod_self n_not_Suc_n numeral_2_eq_2)
  apply (smt One_nat_def OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_write_diff_var_pres d_obs_implies_p_obs getVWNC_var mod_self numeral_2_eq_2 numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (smt OpSemExtProof.ext_c_obs_intro OpSemExtProof.ext_d_obs_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_same_var_write_pres_diff d_obs_implies_p_obs getVWNC_var numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 gr0I not_p_obs_value)
  apply (metis OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 not_gr_zero not_p_obs_value)
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_pres_write_diff_var_ext_2 numeral_eq_iff one_neq_zero semiring_norm(89))
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_pres_write_diff_var_ext_2 mod_self numeral_eq_iff one_neq_zero semiring_norm(89))
  apply (smt One_nat_def OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_write_diff_var_pres d_obs_implies_p_obs getVWNC_var mod_self numeral_2_eq_2 numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (smt OpSemExtProof.ext_c_obs_intro OpSemExtProof.ext_d_obs_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_same_var_write_pres_diff d_obs_implies_p_obs getVWNC_var numeral_eq_iff rcu_simps(23) semiring_norm(89))
  apply (metis OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 gr0I not_p_obs_value)
  apply (metis OpSemExtProof.p_obs_contradiction ext_c_obs_read_diff_var_pres ext_d_obs_rd_pres3 gr0I not_p_obs_value)
  apply (smt One_nat_def OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs bits_one_mod_two_eq_one c_obs_pres_write_diff_var_ext_2 numeral_eq_iff semiring_norm(89))
  apply (smt OpSemExtProof.ext_write_other_pres_d_obs OpSemExtProof.not_p_obs_other_pres_not_p_obs c_obs_pres_write_diff_var_ext_2 mod_self numeral_eq_iff semiring_norm(89))

  done

end


(*  Title:      HOL/SPARK/Examples/RIPEMD-160/Round.thy
    Author:     Fabian Immler, TU Muenchen

Verification of the RIPEMD-160 hash function
*)

theory Round
imports RMD_Specification
begin

spark_open \<open>rmd/round\<close>

abbreviation from_chain :: "chain \<Rightarrow> RMD.chain" where
  "from_chain c \<equiv> (
    word_of_int (h0 c),
    word_of_int (h1 c),
    word_of_int (h2 c),
    word_of_int (h3 c),
    word_of_int (h4 c))"

abbreviation from_chain_pair :: "chain_pair \<Rightarrow> RMD.chain \<times> RMD.chain" where
  "from_chain_pair cc \<equiv> (
    from_chain (left cc),
    from_chain (right cc))"

abbreviation to_chain :: "RMD.chain \<Rightarrow> chain" where
  "to_chain c \<equiv>
    (let (h0, h1, h2, h3, h4) = c in
      (|h0 = uint h0,
        h1 = uint h1,
        h2 = uint h2,
        h3 = uint h3,
        h4 = uint h4|))"

abbreviation to_chain_pair :: "RMD.chain \<times> RMD.chain \<Rightarrow> chain_pair" where
  "to_chain_pair c == (let (c1, c2) = c in
    (| left = to_chain c1,
      right = to_chain c2 |))"

abbreviation steps' :: "chain_pair \<Rightarrow> int \<Rightarrow> block \<Rightarrow> chain_pair" where
  "steps' cc i b == to_chain_pair (steps
    (\<lambda>n. word_of_int (b (int n)))
    (from_chain_pair cc)
    (nat i))"

abbreviation round_spec :: "chain \<Rightarrow> block \<Rightarrow> chain" where
  "round_spec c b == to_chain (round (\<lambda>n. word_of_int (b (int n))) (from_chain c))"

spark_proof_functions
  steps = steps'
  round_spec = round_spec

lemma uint_word_of_int_id:
  assumes "0 <= (x::int)"
  assumes "x <= 4294967295"
  shows"uint(word_of_int x::word32) = x"
  using assms by (simp add: take_bit_int_eq_self unsigned_of_int)

lemma steps_step: "steps X cc (Suc i) = step_both X (steps X cc i) i"
  unfolding steps_def
  by (induct i) simp_all

lemma from_to_id: "from_chain_pair (to_chain_pair CC) = CC"
proof (cases CC)
  fix a::RMD.chain
  fix b c d e f::word32
  assume "CC = (a, b, c, d, e, f)"
  thus ?thesis by (cases a) simp
qed

lemma steps_to_steps':
  "F A (steps X cc i) B =
   F A (from_chain_pair (to_chain_pair (steps X cc i))) B"
  unfolding from_to_id ..

lemma steps'_step:
  assumes "0 <= i"
  shows
  "steps' cc (i + 1) X = to_chain_pair (
     step_both
       (\<lambda>n. word_of_int (X (int n)))
       (from_chain_pair (steps' cc i X))
       (nat i))"
proof -
  have "nat (i + 1) = Suc (nat i)" using assms by simp
  show ?thesis
    unfolding \<open>nat (i + 1) = Suc (nat i)\<close> steps_step steps_to_steps'
    ..
qed

lemma step_from_hyp:
  assumes
  step_hyp:
  "\<lparr>left =
      \<lparr>h0 = a, h1 = b, h2 = c, h3 = d, h4 = e\<rparr>,
    right =
      \<lparr>h0 = a', h1 = b', h2 = c', h3 = d', h4 = e'\<rparr>\<rparr> =
   steps'
     (\<lparr>left =
         \<lparr>h0 = a_0, h1 = b_0, h2 = c_0,
          h3 = d_0, h4 = e_0\<rparr>,
       right =
         \<lparr>h0 = a_0, h1 = b_0, h2 = c_0,
          h3 = d_0, h4 = e_0\<rparr>\<rparr>)
     j x"
  assumes "a <= 4294967295" (is "_ <= ?M")
  assumes                "b  <= ?M" and "c  <= ?M" and "d  <= ?M" and "e  <= ?M"
  assumes "a' <= ?M" and "b' <= ?M" and "c' <= ?M" and "d' <= ?M" and "e' <= ?M"
  assumes "0 <= a " and "0 <= b " and "0 <= c " and "0 <= d " and "0 <= e "
  assumes "0 <= a'" and "0 <= b'" and "0 <= c'" and "0 <= d'" and "0 <= e'"
  assumes "0 <= x (r_l_spec j)" and "x (r_l_spec j) <= ?M"
  assumes "0 <= x (r_r_spec j)" and "x (r_r_spec j) <= ?M"
  assumes "0 <= j" and "j <= 79"
  shows
  "\<lparr>left =
      \<lparr>h0 = e,
         h1 =
           (rotate_left (s_l_spec j)
             ((((a + f_spec j b c d) mod 4294967296 +
                x (r_l_spec j)) mod
               4294967296 +
               k_l_spec j) mod
              4294967296) +
            e) mod
           4294967296,
         h2 = b, h3 = rotate_left 10 c,
         h4 = d\<rparr>,
      right =
        \<lparr>h0 = e',
           h1 =
             (rotate_left (s_r_spec j)
               ((((a' + f_spec (79 - j) b' c' d') mod
                  4294967296 +
                  x (r_r_spec j)) mod
                 4294967296 +
                 k_r_spec j) mod
                4294967296) +
              e') mod
             4294967296,
           h2 = b', h3 = rotate_left 10 c',
           h4 = d'\<rparr>\<rparr> =
   steps'
    (\<lparr>left =
        \<lparr>h0 = a_0, h1 = b_0, h2 = c_0,
           h3 = d_0, h4 = e_0\<rparr>,
        right =
          \<lparr>h0 = a_0, h1 = b_0, h2 = c_0,
             h3 = d_0, h4 = e_0\<rparr>\<rparr>)
    (j + 1) x"
  using step_hyp
proof -
  let ?MM = 4294967296
  have AL: "uint(word_of_int e::word32) = e"
    by (rule uint_word_of_int_id[OF \<open>0 <= e\<close> \<open>e <= ?M\<close>])
  have CL: "uint(word_of_int b::word32) = b"
    by (rule uint_word_of_int_id[OF \<open>0 <= b\<close> \<open>b <= ?M\<close>])
  have DL: "True" ..
  have EL: "uint(word_of_int d::word32) = d"
    by (rule uint_word_of_int_id[OF \<open>0 <= d\<close> \<open>d <= ?M\<close>])
  have AR: "uint(word_of_int e'::word32) = e'"
    by (rule uint_word_of_int_id[OF \<open>0 <= e'\<close> \<open>e' <= ?M\<close>])
  have CR: "uint(word_of_int b'::word32) = b'"
    by (rule uint_word_of_int_id[OF \<open>0 <= b'\<close> \<open>b' <= ?M\<close>])
  have DR: "True" ..
  have ER: "uint(word_of_int d'::word32) = d'"
    by (rule uint_word_of_int_id[OF \<open>0 <= d'\<close> \<open>d' <= ?M\<close>])
  have BL:
    "(uint
      (word_rotl (s (nat j))
        ((word_of_int::int\<Rightarrow>word32)
          ((((a + f_spec j b c d) mod ?MM +
             x (r_l_spec j)) mod ?MM +
            k_l_spec j) mod ?MM))) +
        e) mod ?MM
    =
    uint
              (word_rotl (s (nat j))
                (word_of_int a +
                 f (nat j) (word_of_int b)
                  (word_of_int c) (word_of_int d) +
                 word_of_int (x (r_l_spec j)) +
                 K (nat j)) +
               word_of_int e)"
    (is "(uint (word_rotl _ (_ ((((_ + ?F) mod _ + ?X) mod _ + _) mod _))) + _) mod _ = _")
  proof -
    have "a mod ?MM = a" using \<open>0 <= a\<close> \<open>a <= ?M\<close>
      by simp
    have "?X mod ?MM = ?X" using \<open>0 <= ?X\<close> \<open>?X <= ?M\<close>
      by simp
    have "e mod ?MM = e" using \<open>0 <= e\<close> \<open>e <= ?M\<close>
      by simp
    have "(?MM::int) = 2 ^ LENGTH(32)" by simp
    show ?thesis
      unfolding
        word_add_def
        uint_word_of_int_id[OF \<open>0 <= a\<close> \<open>a <= ?M\<close>]
        uint_word_of_int_id[OF \<open>0 <= ?X\<close> \<open>?X <= ?M\<close>]
      using \<open>a mod ?MM = a\<close>
        \<open>e mod ?MM = e\<close>
        \<open>?X mod ?MM = ?X\<close>
      unfolding \<open>?MM = 2 ^ LENGTH(32)\<close>
      apply (simp only: flip: take_bit_eq_mod add: uint_word_of_int_eq)
      apply (metis (mono_tags, opaque_lifting) of_int_of_nat_eq ucast_id uint_word_of_int_eq unsigned_of_int)
      done
  qed

  have BR:
    "(uint
      (word_rotl (s' (nat j))
        ((word_of_int::int\<Rightarrow>word32)
          ((((a' + f_spec (79 - j) b' c' d') mod ?MM +
             x (r_r_spec j)) mod ?MM +
            k_r_spec j) mod ?MM))) +
        e') mod ?MM
    =
    uint
              (word_rotl (s' (nat j))
                (word_of_int a' +
                 f (79 - nat j) (word_of_int b')
                  (word_of_int c') (word_of_int d') +
                 word_of_int (x (r_r_spec j)) +
                 K' (nat j)) +
               word_of_int e')"
    (is "(uint (word_rotl _ (_ ((((_ + ?F) mod _ + ?X) mod _ + _) mod _))) + _) mod _ = _")
  proof -
    have "a' mod ?MM = a'" using \<open>0 <= a'\<close> \<open>a' <= ?M\<close>
      by simp
    have "?X mod ?MM = ?X" using \<open>0 <= ?X\<close> \<open>?X <= ?M\<close>
      by simp
    have "e' mod ?MM = e'" using \<open>0 <= e'\<close> \<open>e' <= ?M\<close>
      by simp
    have "(?MM::int) = 2 ^ LENGTH(32)" by simp
    have nat_transfer: "79 - nat j = nat (79 - j)"
      using nat_diff_distrib \<open>0 <= j\<close>  \<open>j <= 79\<close>
      by simp
    show ?thesis
      unfolding
        word_add_def
        uint_word_of_int_id[OF \<open>0 <= a'\<close> \<open>a' <= ?M\<close>]
        uint_word_of_int_id[OF \<open>0 <= ?X\<close> \<open>?X <= ?M\<close>]
        nat_transfer
      using \<open>a' mod ?MM = a'\<close>
        \<open>e' mod ?MM = e'\<close>
        \<open>?X mod ?MM = ?X\<close>
      unfolding \<open>?MM = 2 ^ LENGTH(32)\<close>
      apply (simp only: flip: take_bit_eq_mod add: uint_word_of_int_eq)
      apply (metis (mono_tags, opaque_lifting) of_nat_nat_take_bit_eq ucast_id unsigned_of_int)
      done
  qed

  show ?thesis
    unfolding steps'_step[OF \<open>0 <= j\<close>] step_hyp[symmetric]
      step_both_def step_r_def step_l_def
    using AL CL EL AR CR ER
    by (simp add: BL DL BR DR take_bit_int_eq_self_iff take_bit_int_eq_self)
qed

spark_vc procedure_round_61
proof -
  let ?M = "4294967295::int"
  have step_hyp:
  "\<lparr>left =
      \<lparr>h0 = ca, h1 = cb, h2 = cc,
         h3 = cd, h4 = ce\<rparr>,
      right =
        \<lparr>h0 = ca, h1 = cb, h2 = cc,
           h3 = cd, h4 = ce\<rparr>\<rparr> =
   steps'
    (\<lparr>left =
        \<lparr>h0 = ca, h1 = cb, h2 = cc,
           h3 = cd, h4 = ce\<rparr>,
        right =
          \<lparr>h0 = ca, h1 = cb, h2 = cc,
             h3 = cd, h4 = ce\<rparr>\<rparr>)
    0 x"
    unfolding steps_def
    using
      uint_word_of_int_id[OF \<open>0 <= ca\<close> \<open>ca <= ?M\<close>]
      uint_word_of_int_id[OF \<open>0 <= cb\<close> \<open>cb <= ?M\<close>]
      uint_word_of_int_id[OF \<open>0 <= cc\<close> \<open>cc <= ?M\<close>]
      uint_word_of_int_id[OF \<open>0 <= cd\<close> \<open>cd <= ?M\<close>]
      uint_word_of_int_id[OF \<open>0 <= ce\<close> \<open>ce <= ?M\<close>]
    by (simp add: take_bit_int_eq_self_iff take_bit_int_eq_self)
  let ?rotate_arg_l =
    "((((ca + f 0 cb cc cd) mod 4294967296 +
        x (r_l 0)) mod 4294967296 + k_l 0) mod 4294967296)"
  let ?rotate_arg_r =
    "((((ca + f 79 cb cc cd) mod 4294967296 +
        x (r_r 0)) mod 4294967296 + k_r 0) mod 4294967296)"
  note returns =
    \<open>wordops__rotate (s_l 0) ?rotate_arg_l =
     rotate_left (s_l 0) ?rotate_arg_l\<close>
    \<open>wordops__rotate (s_r 0) ?rotate_arg_r =
     rotate_left (s_r 0) ?rotate_arg_r\<close>
    \<open>wordops__rotate 10 cc = rotate_left 10 cc\<close>
    \<open>f 0 cb cc cd = f_spec 0 cb cc cd\<close>
    \<open>f 79 cb cc cd = f_spec 79 cb cc cd\<close>
    \<open>k_l 0 = k_l_spec 0\<close>
    \<open>k_r 0 = k_r_spec 0\<close>
    \<open>r_l 0 = r_l_spec 0\<close>
    \<open>r_r 0 = r_r_spec 0\<close>
    \<open>s_l 0 = s_l_spec 0\<close>
    \<open>s_r 0 = s_r_spec 0\<close>

  note x_borders = \<open>\<forall>i. 0 \<le> i \<and> i \<le> 15 \<longrightarrow> 0 \<le> x i \<and> x i \<le> ?M\<close>

  from \<open>0 <= r_l 0\<close> \<open>r_l 0 <= 15\<close> x_borders
  have "0 \<le> x (r_l 0)" by blast
  hence x_lower: "0 <= x (r_l_spec 0)" unfolding returns .

  from \<open>0 <= r_l 0\<close> \<open>r_l 0 <= 15\<close> x_borders
  have "x (r_l 0) <= ?M" by blast
  hence x_upper: "x (r_l_spec 0) <= ?M" unfolding returns .

  from \<open>0 <= r_r 0\<close> \<open>r_r 0 <= 15\<close> x_borders
  have "0 \<le> x (r_r 0)" by blast
  hence x_lower': "0 <= x (r_r_spec 0)" unfolding returns .

  from \<open>0 <= r_r 0\<close> \<open>r_r 0 <= 15\<close> x_borders
  have "x (r_r 0) <= ?M" by blast
  hence x_upper': "x (r_r_spec 0) <= ?M" unfolding returns .

  have "0 <= (0::int)" by simp
  have "0 <= (79::int)" by simp
  note step_from_hyp [OF
    step_hyp
    H2 H4 H6 H8 H10 H2 H4 H6 H8 H10 \<comment> \<open>upper bounds\<close>
    H1 H3 H5 H7 H9  H1 H3 H5 H7 H9  \<comment> \<open>lower bounds\<close>
  ]
  from this[OF x_lower x_upper x_lower' x_upper' \<open>0 <= 0\<close> \<open>0 <= 79\<close>]
    \<open>0 \<le> ca\<close> \<open>0 \<le> ce\<close> x_lower x_lower'
  show ?thesis unfolding returns(1) returns(2) unfolding returns
    by (simp del: mod_pos_pos_trivial mod_neg_neg_trivial)
qed

spark_vc procedure_round_62
proof -
  let ?M = "4294967295::int"
  let ?rotate_arg_l =
    "((((cla + f (loop__1__j + 1) clb clc cld) mod 4294967296 +
         x (r_l (loop__1__j + 1))) mod 4294967296 +
         k_l (loop__1__j + 1)) mod 4294967296)"
  let ?rotate_arg_r =
    "((((cra + f (79 - (loop__1__j + 1)) crb crc crd) mod
         4294967296 + x (r_r (loop__1__j + 1))) mod 4294967296 +
         k_r (loop__1__j + 1)) mod 4294967296)"

  have s: "78 - loop__1__j = (79 - (loop__1__j + 1))" by simp
  note returns =
    \<open>wordops__rotate (s_l (loop__1__j + 1)) ?rotate_arg_l =
     rotate_left (s_l (loop__1__j + 1)) ?rotate_arg_l\<close>
    \<open>wordops__rotate (s_r (loop__1__j + 1)) ?rotate_arg_r =
     rotate_left (s_r (loop__1__j + 1)) ?rotate_arg_r\<close>
    \<open>f (loop__1__j + 1) clb clc cld =
     f_spec (loop__1__j + 1) clb clc cld\<close>
    \<open>f (78 - loop__1__j) crb crc crd =
     f_spec (78 - loop__1__j) crb crc crd\<close>[simplified s]
    \<open>wordops__rotate 10 clc = rotate_left 10 clc\<close>
    \<open>wordops__rotate 10 crc = rotate_left 10 crc\<close>
    \<open>k_l (loop__1__j + 1) = k_l_spec (loop__1__j + 1)\<close>
    \<open>k_r (loop__1__j + 1) = k_r_spec (loop__1__j + 1)\<close>
    \<open>r_l (loop__1__j + 1) = r_l_spec (loop__1__j + 1)\<close>
    \<open>r_r (loop__1__j + 1) = r_r_spec (loop__1__j + 1)\<close>
    \<open>s_l (loop__1__j + 1) = s_l_spec (loop__1__j + 1)\<close>
    \<open>s_r (loop__1__j + 1) = s_r_spec (loop__1__j + 1)\<close>

  note x_borders = \<open>\<forall>i. 0 \<le> i \<and> i \<le> 15 \<longrightarrow> 0 \<le> x i \<and> x i \<le> ?M\<close>

  from \<open>0 <= r_l (loop__1__j + 1)\<close> \<open>r_l (loop__1__j + 1) <= 15\<close> x_borders
  have "0 \<le> x (r_l (loop__1__j + 1))" by blast
  hence x_lower: "0 <= x (r_l_spec (loop__1__j + 1))" unfolding returns .

  from \<open>0 <= r_l (loop__1__j + 1)\<close> \<open>r_l (loop__1__j + 1) <= 15\<close> x_borders
  have "x (r_l (loop__1__j + 1)) <= ?M" by blast
  hence x_upper: "x (r_l_spec (loop__1__j + 1)) <= ?M" unfolding returns .

  from \<open>0 <= r_r (loop__1__j + 1)\<close> \<open>r_r (loop__1__j + 1) <= 15\<close> x_borders
  have "0 \<le> x (r_r (loop__1__j + 1))" by blast
  hence x_lower': "0 <= x (r_r_spec (loop__1__j + 1))" unfolding returns .

  from \<open>0 <= r_r (loop__1__j + 1)\<close> \<open>r_r (loop__1__j + 1) <= 15\<close> x_borders
  have "x (r_r (loop__1__j + 1)) <= ?M" by blast
  hence x_upper': "x (r_r_spec (loop__1__j + 1)) <= ?M" unfolding returns .

  from \<open>0 <= loop__1__j\<close> have "0 <= loop__1__j + 1" by simp
  from \<open>loop__1__j <= 78\<close> have "loop__1__j + 1 <= 79" by simp

  have "loop__1__j + 1 + 1 = loop__1__j + 2" by simp

  note step_from_hyp[OF H1
    \<open>cla <= ?M\<close>
    \<open>clb <= ?M\<close>
    \<open>clc <= ?M\<close>
    \<open>cld <= ?M\<close>
    \<open>cle <= ?M\<close>
    \<open>cra <= ?M\<close>
    \<open>crb <= ?M\<close>
    \<open>crc <= ?M\<close>
    \<open>crd <= ?M\<close>
    \<open>cre <= ?M\<close>

    \<open>0 <= cla\<close>
    \<open>0 <= clb\<close>
    \<open>0 <= clc\<close>
    \<open>0 <= cld\<close>
    \<open>0 <= cle\<close>
    \<open>0 <= cra\<close>
    \<open>0 <= crb\<close>
    \<open>0 <= crc\<close>
    \<open>0 <= crd\<close>
    \<open>0 <= cre\<close>]
  from this[OF
    x_lower x_upper x_lower' x_upper'
    \<open>0 <= loop__1__j + 1\<close> \<open>loop__1__j + 1 <= 79\<close>]
    \<open>0 \<le> cla\<close> \<open>0 \<le> cle\<close> \<open>0 \<le> cra\<close> \<open>0 \<le> cre\<close> x_lower x_lower'
  show ?thesis unfolding \<open>loop__1__j + 1 + 1 = loop__1__j + 2\<close>
    unfolding returns(1) returns(2) unfolding returns
    by (simp del: mod_pos_pos_trivial mod_neg_neg_trivial)

qed

spark_vc procedure_round_76
proof -
  let ?M = "4294967295 :: int"
  let ?INIT_CHAIN =
     "\<lparr>h0 = ca_init, h1 = cb_init,
         h2 = cc_init, h3 = cd_init,
         h4 = ce_init\<rparr>"
  have steps_to_steps':
    "steps
       (\<lambda>n::nat. word_of_int (x (int n)))
       (from_chain ?INIT_CHAIN, from_chain ?INIT_CHAIN)
       80 =
    from_chain_pair (
      steps'
      (\<lparr>left = ?INIT_CHAIN, right = ?INIT_CHAIN\<rparr>)
      80
      x)"
    unfolding from_to_id by simp
  from
    \<open>0 \<le> ca_init\<close> \<open>ca_init \<le> ?M\<close>
    \<open>0 \<le> cb_init\<close> \<open>cb_init \<le> ?M\<close>
    \<open>0 \<le> cc_init\<close> \<open>cc_init \<le> ?M\<close>
    \<open>0 \<le> cd_init\<close> \<open>cd_init \<le> ?M\<close>
    \<open>0 \<le> ce_init\<close> \<open>ce_init \<le> ?M\<close>
    \<open>0 \<le> cla\<close> \<open>cla \<le> ?M\<close>
    \<open>0 \<le> clb\<close> \<open>clb \<le> ?M\<close>
    \<open>0 \<le> clc\<close> \<open>clc \<le> ?M\<close>
    \<open>0 \<le> cld\<close> \<open>cld \<le> ?M\<close>
    \<open>0 \<le> cle\<close> \<open>cle \<le> ?M\<close>
    \<open>0 \<le> cra\<close> \<open>cra \<le> ?M\<close>
    \<open>0 \<le> crb\<close> \<open>crb \<le> ?M\<close>
    \<open>0 \<le> crc\<close> \<open>crc \<le> ?M\<close>
    \<open>0 \<le> crd\<close> \<open>crd \<le> ?M\<close>
    \<open>0 \<le> cre\<close> \<open>cre \<le> ?M\<close>
  show ?thesis
    unfolding round_def
    unfolding steps_to_steps'
    unfolding H1[symmetric]
    by (simp add: uint_word_ariths(1) mod_simps
      uint_word_of_int_id take_bit_int_eq_self)
qed

spark_end

end


(*  File:       Elimination_Module_Ref.thy
    Copyright   2023  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Valentin Springsklee, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Refined Elimination Module\<close>

theory Elimination_Module_Ref
  imports "Verified_Voting_Rule_Construction.Elimination_Module"
          Evaluation_Function_Ref
          Electoral_Module_Ref
Refine_Imperative_HOL.IICF
begin

text \<open>
  This is the elimination module. It rejects a set of alternatives only if
  these are not all alternatives. The alternatives potentially to be rejected
  are put in a so-called elimination set. These are all alternatives that score
  below a preset threshold value that depends on the specific voting rule.
\<close>

subsection \<open>Definition\<close>

type_synonym 'a Scores_Map = "'a \<rightharpoonup> nat"

definition init_map :: "'a set \<Rightarrow> 'a Scores_Map nres" where
"init_map A \<equiv>
  FOREACH A
    (\<lambda>x m.
      RETURN (m(x\<mapsto>0::nat))) (Map.empty)"

lemma empty_map:
  fixes A :: "'a set"
  assumes
     fina: "finite A"
  shows "init_map A \<le>
   SPEC(\<lambda> map. map =  ((\<lambda>a. Some (0::nat))|`A ))"
  unfolding init_map_def
  apply (refine_vcg FOREACH_rule [where I ="(\<lambda>it r. r = (\<lambda> a. Some (0::nat))|`(A - it))"])
  apply (auto simp add: fina)
  by (simp add: it_step_insert_iff restrict_map_insert)

definition pre_compute_scores :: "'a Evaluation_Function_Ref \<Rightarrow>
 'a set \<Rightarrow> 'a Profile_List \<Rightarrow> 'a Scores_Map nres"
  where "pre_compute_scores ef A p \<equiv>
  FOREACH A
    (\<lambda>x m. do {
      scx \<leftarrow> (ef x A p);
      RETURN (m(x\<mapsto>scx))
  }) (Map.empty)"

definition scoremax :: "'a set \<Rightarrow> 'a Scores_Map \<Rightarrow> nat nres" where
 "scoremax A scores \<equiv> do {
  FOREACH (A)
    (\<lambda>x max. do {
      ASSERT (x \<in> dom scores);
      let scx = the (scores x);
      (if (scx > max) then
          RETURN (scx)
      else
          RETURN(max))
    }) (0::nat)
}"

definition eliminate:: "'a Scores_Map  \<Rightarrow> Threshold_Value \<Rightarrow>
                            Threshold_Relation \<Rightarrow>
                          'a set \<Rightarrow> ('a set \<times> 'a set) nres" where
 "eliminate scoremap t r A \<equiv> do {
  FOREACH (A)
    (\<lambda>x (rej, def). do {
      ASSERT (x \<in> dom scoremap);
      let scx = the (scoremap x);
      (if (r scx t) then
          RETURN (insert x rej, def)
      else
          RETURN(rej, insert x def))
    }) ({}, {})
}"

definition elimination_module_ref ::
"'a Scores_Map  \<Rightarrow> Threshold_Value \<Rightarrow>
Threshold_Relation \<Rightarrow> 'a Electoral_Module_Ref "
  where
  "elimination_module_ref scores threshold r A p \<equiv> do {
    (rej, def) \<leftarrow> eliminate scores threshold r A;
   if (def = {}) then
       \<comment> \<open>Here rej will be a copy of A\<close>
     RETURN ({},{},rej)
    else
     RETURN ({},rej,def)
  }"

definition scores_map :: "'a Evaluation_Function \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Scores_Map"  where
  "scores_map e Alts pro \<equiv> ((\<lambda>a. Some (e a Alts pro))|`Alts )"

lemma eliminate_correct:
  fixes A :: "'a set"
  fixes efn :: "'a Evaluation_Function"
  and p :: "'a Profile"
  and t :: "Threshold_Value"
  and r :: "Threshold_Relation"
  assumes  fina: "finite A"
  shows "eliminate (scores_map efn A p) t r A
    \<le> SPEC (\<lambda> (rej,def).
    (rej,def) = ((elimination_set efn t r A p), A - (elimination_set efn t r A p)))"
  unfolding scores_map_def eliminate_def
  by (refine_vcg FOREACH_rule
      [where I = "\<lambda> it (rej, def). rej = ((elimination_set efn t r A p) - it)
                \<and> def = (A - it) - (elimination_set efn t r A p)"],auto simp add: fina)

lemma compute_scores_correct:
  fixes A :: "'a set"
  fixes pr :: "'a Profile"
  fixes pl :: "'a Profile_List"
  fixes efnref :: "'a Evaluation_Function_Ref"
  and efn :: "'a Evaluation_Function"
  assumes
     fina: "finite A" and
     prel: "(pl, pr) \<in> profile_rel" and
  efnrel:  "\<forall>a \<in> A. efnref a A pl \<le> SPEC (\<lambda>score. score = (efn a A pr))"
  shows "pre_compute_scores efnref A pl \<le>
   SPEC(\<lambda> map. map = (scores_map efn A pr))"
  unfolding pre_compute_scores_def scores_map_def
proof (refine_vcg FOREACH_rule[where I =
        "(\<lambda>it r. r = (\<lambda> a. Some (efn a A pr))|`(A - it))"],
        clarsimp_all simp add: fina)
    fix x:: 'a
  fix it:: "'a set"
  assume xit: "x \<in> it"
  assume itA: "it \<subseteq> A"
  from xit itA have xiA: "x \<in> A" by fastforce
  from xit itA have wcr: "((\<lambda>a. Some (efn a A pr)) |` (A - it))(x \<mapsto> (efn x A pr)) =
                      (\<lambda>a. Some (efn a A pr)) |` (A - (it - {x}))"
      using it_step_insert_iff restrict_map_insert
      by metis
  from this have mapupdeq: "(\<lambda>scx. ((\<lambda>a. Some (efn a A pr)) |` (A - it))(x \<mapsto> scx) =
                   (\<lambda>a. Some (efn a A pr)) |` (A - (it - {x})))
      = (\<lambda> wc. wc = (efn x A pr))"
    by (metis map_upd_eqD1)
  from efnrel xiA have "efnref x A pl \<le> SPEC (\<lambda>score. score = (efn x A pr))"
    by fastforce
  from this mapupdeq show "efnref x A pl
       \<le> SPEC (\<lambda>scx. ((\<lambda>a. Some (efn a A pr)) |` (A - it))(x \<mapsto> scx) =
                      (\<lambda>a. Some (efn a A pr)) |` (A - (it - {x})))"
    using  it_step_insert_iff restrict_map_insert
    by presburger
qed

lemma elimination_module_ref_correct:
  fixes A :: "'a set"
  fixes efn :: "'a Evaluation_Function"
  and pr :: "'a Profile"
  and pl :: "'a Profile_List"
  and t :: "Threshold_Value"
  and r :: "Threshold_Relation"
    assumes fina: "finite A"  and
  "(pl, pr) \<in> profile_rel"
  shows "elimination_module_ref (scores_map efn A pr) t r A pl \<le>
        SPEC (\<lambda> em. em = (elimination_module efn t r A pr))"
  by (unfold elimination_module_ref_def, refine_vcg eliminate_correct,
    auto simp add: fina)

theorem elimination_module_ref_correct_pc:
  fixes A :: "'a set"
  and efn :: "'a Evaluation_Function"
  and efn_ref :: "'a Evaluation_Function_Ref"
  and pr :: "'a Profile"
  and pl :: "'a Profile_List"
  and t :: "Threshold_Value"
  and r :: "nat \<Rightarrow> nat \<Rightarrow> bool"
  assumes fina: "finite A"
  and prel: "(pl, pr) \<in> profile_rel"
  and efnrel: "(efn_ref, RETURN ooo efn) \<in> efunrel"
shows "(do {
            score_map \<leftarrow> (pre_compute_scores efn_ref A pl);
            elimination_module_ref score_map t r A pl}) \<le>
            SPEC (\<lambda> em. em = (elimination_module efn t r A pr))"
proof (refine_vcg fina prel compute_scores_correct[where efn = efn] , safe)
  fix a :: 'a
  note efnr = efnrel[THEN fun_relD,THEN fun_relD,THEN fun_relD,
        THEN nres_relD, THEN refine_IdD]
  from fina prel efnr show "efn_ref a A pl \<le> SPEC (\<lambda>score. score = efn a A pr)"
    unfolding comp_apply SPEC_eq_is_RETURN
    by force
next
  show "elimination_module_ref (scores_map efn A pr) t r A pl
         \<le> SPEC (\<lambda>em. em = elimination_module efn t r A pr)"
    using elimination_module_ref_correct fina prel
    by blast
qed

lemma scoremax_correct:
  fixes A :: "'a set"
  assumes fina: "finite A" and nempa: "A \<noteq> {}"
  fixes efn :: "'a Evaluation_Function"
  and pr :: "'a Profile"
  shows "scoremax A (scores_map efn A pr)
 \<le> SPEC (\<lambda> max. max = Max {(efn a A pr) | a. a \<in> A})"
  unfolding scoremax_def scores_map_def
  apply (refine_vcg FOREACH_rule[where I = "(\<lambda>it max. (\<forall>a \<in> (A - it). (efn a A pr) \<le> max)
      \<and> ((\<exists>a \<in> (A - it). max = (efn a A pr)) \<or> max = 0))"], clarsimp_all simp add:  fina nempa,
         auto)
  using max_score_in[where A= A and f = "(\<lambda> x. efn x A pr)"] fina nempa
            score_bounded[where A= A and f = "(\<lambda> x. efn x A pr)"]
  subgoal by (metis DiffI dual_order.trans order_less_imp_le)
  using max_score_in[where A= A and f = "(\<lambda> x. efn x A pr)"] fina nempa
            score_bounded[where A= A and f = "(\<lambda> x. efn x A pr)"]
proof ((metis (mono_tags, lifting) order_antisym_conv))
  assume all0: "\<forall>a\<in>A. efn a A pr = 0"
  from all0 have eq: "{efn a A pr |a. a \<in> A} = {0}"
    using nempa Max_singleton by force
  have "Max {0} = 0"
    using Max_singleton by blast
  from eq this  show " Max {efn a A pr |a. a \<in> A} = 0"
    by simp
qed

subsection \<open>Common Eliminators\<close>

definition less_eliminator_ref :: "'a Scores_Map  \<Rightarrow> Threshold_Value \<Rightarrow>
                            'a Electoral_Module_Ref" where
  "less_eliminator_ref e t A p \<equiv> elimination_module_ref e t (<) A p"

definition max_eliminator_ref ::  "'a Scores_Map \<Rightarrow>
                            'a Electoral_Module_Ref" where
  "max_eliminator_ref e A p \<equiv>
    if (A = {}) then
      RETURN ({},{},{})
    else do {
    t \<leftarrow> (scoremax A e);
    (less_eliminator_ref e t A p)
 }"

lemma less_eliminator_ref_correct:
  fixes A :: "'a set"
  and efn :: "'a Evaluation_Function"
  and pr :: "'a Profile"
  and pl :: "'a Profile_List"
  and t :: "Threshold_Value"
  assumes fina: "finite A"
  and prel: "(pl, pr) \<in> profile_rel"
  shows "(less_eliminator_ref (scores_map efn A pr) t A pl) \<le>
            SPEC (\<lambda> em. em = (less_eliminator efn t A pr))"
  unfolding less_eliminator_ref_def less_eliminator.simps
proof (-)
 show "elimination_module_ref (scores_map efn A pr) t (<) A pl
       \<le> SPEC (\<lambda>em. em = elimination_module efn t (<) A pr) "
   using fina prel elimination_module_ref_correct by blast
qed

lemma max_eliminator_ref_correct:
  fixes A :: "'a set"
  fixes efn :: "'a Evaluation_Function"
  and pr :: "'a Profile"
  and pl :: "'a Profile_List"
  assumes fina: "finite A"
  assumes prel: "(pl, pr) \<in> profile_rel"
  shows "(max_eliminator_ref (scores_map efn A pr) A pl
          \<le> SPEC (\<lambda> em. em = max_eliminator efn A pr))"
  apply (unfold max_eliminator_ref_def max_eliminator.simps less_eliminator_ref_def)
  apply (refine_vcg scoremax_correct fina )
   apply (simp)
  unfolding less_eliminator.simps using elimination_module_ref_correct assms
  by fastforce

lemma max_eliminator_ref_correct_pc:
  fixes A :: "'a set"
  fixes efn :: "'a Evaluation_Function"
  and pr :: "'a Profile"
  and pl :: "'a Profile_List"
  and scores :: "'a Scores_Map"
  assumes fina: "finite A"
  and prel: "(pl, pr) \<in> profile_rel"
  and mapc: "score_map \<le> SPEC (\<lambda> scores. scores = scores_map efn A pr)"
  shows "(score_map \<bind> (\<lambda> scores. max_eliminator_ref scores A pl))
          \<le> SPEC (\<lambda> em. em = max_eliminator efn A pr)"
proof (refine_vcg mapc)
  fix map :: "'a Scores_Map"
  assume perfmap: "map = scores_map efn A pr"
  show "max_eliminator_ref map A pl \<le> SPEC (\<lambda>em. em = max_eliminator efn A pr)"
    unfolding perfmap using max_eliminator_ref_correct[OF fina prel] .
qed

theorem max_eliminator_ref_correct_default:
  fixes A :: "'a set"
  and efn :: "'a Evaluation_Function"
  and efn_ref :: "'a Evaluation_Function_Ref"
  and pr :: "'a Profile"
  and pl :: "'a Profile_List"
  and t :: "Threshold_Value"
  and r :: "nat \<Rightarrow> nat \<Rightarrow> bool"
  assumes fina: "finite A"
  and prel: "(pl, pr) \<in> profile_rel"
  and efnrel: "\<forall>a \<in> A. efn_ref a A pl \<le> SPEC (\<lambda> score. score = efn a A pr)"
  shows "(do {
            score_map \<leftarrow> (pre_compute_scores efn_ref A pl);
            max_eliminator_ref score_map A pl}) \<le>
            SPEC (\<lambda> em. em = (max_eliminator efn A pr))"
  by (refine_vcg compute_scores_correct max_eliminator_ref_correct_pc assms)

definition leq_eliminator_ref :: "'a Scores_Map \<Rightarrow> Threshold_Value \<Rightarrow>
                            'a Electoral_Module_Ref" where
  "leq_eliminator_ref e t A p = elimination_module_ref e t (\<le>) A p"

end