(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Bisimulation
  imports Weak_Simulation Weak_Stat_Imp Bisim_Struct_Cong
begin

context env begin

lemma monoCoinduct: "\<And>x y xa xb xc P Q \<Psi>.
                      x \<le> y \<Longrightarrow>
                      (\<Psi> \<rhd> Q \<leadsto><{(xc, xb, xa). x xc xb xa}> P) \<longrightarrow>
                     (\<Psi> \<rhd> Q \<leadsto><{(xb, xa, xc). y xb xa xc}> P)"
apply auto
apply(rule weakSimMonotonic)
by(auto dest: le_funE)

lemma monoCoinduct2: "\<And>x y xa xb xc P Q \<Psi>.
                      x \<le> y \<Longrightarrow>
                      (\<Psi> \<rhd> Q \<lessapprox><{(xc, xb, xa). x xc xb xa}> P) \<longrightarrow>
                     (\<Psi> \<rhd> Q \<lessapprox><{(xb, xa, xc). y xb xa xc}> P)"
apply auto
apply(rule weakStatImpMonotonic)
by(auto dest: le_funE)

coinductive_set weakBisim :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
where
  step: "\<lbrakk>\<Psi> \<rhd> P \<lessapprox><weakBisim> Q; \<Psi> \<rhd> P \<leadsto><weakBisim> Q;
          \<forall>\<Psi>'. (\<Psi> \<otimes> \<Psi>',  P, Q) \<in> weakBisim; (\<Psi>, Q, P) \<in> weakBisim\<rbrakk> \<Longrightarrow> (\<Psi>, P, Q) \<in> weakBisim"
monos monoCoinduct monoCoinduct2

abbreviation
  weakBisimJudge ("_ \<rhd> _ \<approx> _" [70, 70, 70] 65) where "\<Psi> \<rhd> P \<approx> Q \<equiv> (\<Psi>, P, Q) \<in> weakBisim"
abbreviation
  weakBisimNilJudge ("_ \<approx> _" [70, 70] 65) where "P \<approx> Q \<equiv> \<one> \<rhd> P \<approx> Q"

lemma weakBisimCoinductAux[consumes 1]:
  fixes F :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   X :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes "(\<Psi>, P, Q) \<in> X"
  and     "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> (\<Psi> \<rhd> P \<lessapprox><(X \<union> weakBisim)> Q) \<and>
                                      (\<Psi> \<rhd> P \<leadsto><(X \<union> weakBisim)> Q) \<and>
                                      (\<forall>\<Psi>'. (\<Psi> \<otimes> \<Psi>', P, Q) \<in> X \<or> (\<Psi> \<otimes> \<Psi>', P, Q) \<in> weakBisim) \<and>
                                      ((\<Psi>, Q, P) \<in> X \<or> (\<Psi>, Q, P) \<in> weakBisim)"

  shows "(\<Psi>, P, Q) \<in> weakBisim"
proof -
  have "X \<union> weakBisim = {(\<Psi>, P, Q). (\<Psi>, P, Q) \<in> X \<or> (\<Psi>, P, Q) \<in> weakBisim}" by auto
  with assms show ?thesis
    by coinduct (simp add: rtrancl_def)
qed

lemma weakBisimCoinduct[consumes 1, case_names cStatImp cSim cExt cSym]:
  fixes F :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   X :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes "(\<Psi>, P, Q) \<in> X"
  and     "\<And>\<Psi>' R S. (\<Psi>', R, S) \<in> X \<Longrightarrow> \<Psi>' \<rhd> R \<lessapprox><(X \<union> weakBisim)> S"
  and     "\<And>\<Psi>' R S. (\<Psi>', R, S) \<in> X \<Longrightarrow> \<Psi>' \<rhd> R \<leadsto><(X \<union> weakBisim)> S"
  and     "\<And>\<Psi>' R S \<Psi>''. (\<Psi>', R, S) \<in> X \<Longrightarrow> (\<Psi>' \<otimes> \<Psi>'', R, S) \<in> X \<or> \<Psi>' \<otimes> \<Psi>'' \<rhd> R \<approx> S"
  and     "\<And>\<Psi>' R S. (\<Psi>', R, S) \<in> X \<Longrightarrow> (\<Psi>', S, R) \<in> X \<or> \<Psi>' \<rhd> S \<approx> R"

  shows "\<Psi> \<rhd> P \<approx> Q"
proof -
  have "X \<union> weakBisim = {(\<Psi>, P, Q). (\<Psi>, P, Q) \<in> X \<or> (\<Psi>, P, Q) \<in> weakBisim}" by auto
  with assms show ?thesis
    by coinduct (simp add: rtrancl_def)
qed

lemma weakBisimWeakCoinductAux[consumes 1]:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   X :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes "(\<Psi>, P, Q) \<in> X"
  and     "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> \<Psi> \<rhd> P \<lessapprox><X> Q \<and> \<Psi> \<rhd> P \<leadsto><X> Q \<and>
                                      (\<forall>\<Psi>'. (\<Psi> \<otimes> \<Psi>', P, Q) \<in> X) \<and> (\<Psi>, Q, P) \<in> X"

  shows "\<Psi> \<rhd> P \<approx> Q"
using assms
by(coinduct rule: weakBisimCoinductAux) (blast intro: weakSimMonotonic weakStatImpMonotonic)

lemma weakBisimWeakCoinduct[consumes 1, case_names cStatImp cSim cExt cSym]:
  fixes F :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   X :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes "(\<Psi>, P, Q) \<in> X"
  and     "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> \<Psi> \<rhd> P \<lessapprox><X> Q"
  and     "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> \<Psi> \<rhd> P \<leadsto><X> Q"
  and     "\<And>\<Psi> P Q \<Psi>'. (\<Psi>, P, Q) \<in> X \<Longrightarrow> (\<Psi> \<otimes> \<Psi>', P, Q) \<in> X"
  and     "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> (\<Psi>, Q, P) \<in> X"

  shows "(\<Psi>, P, Q) \<in> weakBisim"
proof -
  have "X \<union> weakBisim = {(\<Psi>, P, Q). (\<Psi>, P, Q) \<in> X \<or> (\<Psi>, P, Q) \<in> weakBisim}" by auto
  with assms show ?thesis
    by(coinduct rule: weakBisimWeakCoinductAux) blast
qed

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

  assumes "\<Psi> \<rhd> P \<approx> Q"

  shows "\<Psi> \<rhd> P \<lessapprox><weakBisim> Q"
  and   "\<Psi> \<rhd> P \<leadsto><weakBisim> Q"
  and   "\<Psi> \<otimes> \<Psi>' \<rhd>  P \<approx> Q"
  and   "\<Psi> \<rhd> Q \<approx> P"
using assms
by(auto intro: weakBisim.cases simp add: rtrancl_def)

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

  assumes "\<Psi> \<rhd> P \<lessapprox><weakBisim> Q"
  and     "\<Psi> \<rhd> P \<leadsto><weakBisim> Q"
  and     "\<forall>\<Psi>'. \<Psi> \<otimes> \<Psi>' \<rhd> P \<approx> Q"
  and     "\<Psi> \<rhd> Q \<approx> P"

  shows "\<Psi> \<rhd> P \<approx> Q"
using assms
by(rule_tac weakBisim.step) (auto simp add: rtrancl_def)

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

  shows "\<Psi> \<rhd> P \<approx> P"
proof -
  let ?X = "{(\<Psi>, P, P) | \<Psi> P. True}"
  have "(\<Psi>, P, P) \<in> ?X" by simp
  thus ?thesis
    by(coinduct rule: weakBisimWeakCoinduct, auto intro: weakSimReflexive weakStatImpReflexive)
qed

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

  assumes "\<Psi> \<rhd> P \<approx> Q"

  shows "(p \<bullet> \<Psi>) \<rhd>  (p \<bullet> P) \<approx> (p \<bullet> Q)"
proof -
  let ?X = "{(p \<bullet> \<Psi>, p \<bullet> P, p \<bullet> Q) | (p::name prm) \<Psi>  P Q. \<Psi> \<rhd> P \<approx> Q}"
  have "eqvt ?X"
    apply(auto simp add: eqvt_def)
    apply(rule_tac x="pa@p" in exI)
    by(auto simp add: pt2[OF pt_name_inst])
  from \<open>\<Psi> \<rhd> P \<approx> Q\<close> have "(p \<bullet> \<Psi>, p \<bullet> P, p \<bullet> Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: weakBisimWeakCoinduct)
    case(cStatImp \<Psi> P Q)
    {
      fix \<Psi> P Q p
      assume "\<Psi> \<rhd> P \<approx> (Q::('a, 'b, 'c) psi)"
      hence "\<Psi> \<rhd> P \<lessapprox><weakBisim> Q" by(rule weakBisimE)
      hence "\<Psi> \<rhd> P \<lessapprox><?X> Q"
        apply(rule_tac A=weakBisim in weakStatImpMonotonic, auto)
        by(rule_tac x="[]::name prm" in exI) auto
      with \<open>eqvt ?X\<close> have "((p::name prm) \<bullet> \<Psi>) \<rhd> (p \<bullet> P) \<lessapprox><?X> (p \<bullet> Q)"
        by(rule weakStatImpClosed)
    }
    with \<open>(\<Psi>, P, Q) \<in> ?X\<close> show ?case by blast
  next
    case(cSim \<Psi> P Q)
    {
      fix p :: "name prm"
      fix \<Psi> P Q
      assume "\<Psi> \<rhd> P \<leadsto><weakBisim> Q"
      hence "\<Psi> \<rhd> P \<leadsto><?X> Q"
        apply(rule_tac A=weakBisim in weakSimMonotonic, auto)
        by(rule_tac x="[]::name prm" in exI) auto
      with \<open>eqvt ?X\<close> have "((p::name prm) \<bullet> \<Psi>) \<rhd> (p \<bullet> P) \<leadsto><?X> (p \<bullet> Q)"
        by(rule_tac weakSimClosed)
    }
    with \<open>(\<Psi>, P, Q) \<in> ?X\<close> show ?case
      by(blast dest: weakBisimE)
  next
    case(cExt \<Psi> P Q \<Psi>')
    {
      fix p :: "name prm"
      fix \<Psi> P Q \<Psi>'
      assume "\<forall>\<Psi>'. (\<Psi> \<otimes> \<Psi>', P, Q) \<in> weakBisim"
      hence "((p \<bullet> \<Psi>) \<otimes> \<Psi>', p \<bullet> P, p \<bullet> Q) \<in> ?X"
        apply(auto, rule_tac x=p in exI)
        apply(rule_tac x="\<Psi> \<otimes> (rev p \<bullet> \<Psi>')" in exI)
        by(auto simp add: eqvts)
    }
    with \<open>(\<Psi>, P, Q) \<in> ?X\<close> show ?case
      by(blast dest: weakBisimE)
  next
    case(cSym \<Psi> P Q)
    thus ?case
      by(blast dest: weakBisimE)
  qed
qed

lemma weakBisimEqvt[simp]:
  shows "eqvt weakBisim"
by(auto simp add: eqvt_def weakBisimClosed)

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

  assumes "\<Psi> \<rhd> P \<approx> Q"
  and     "\<Psi> \<simeq> \<Psi>'"

  shows "\<Psi>' \<rhd> P \<approx> Q"
proof -
  let ?X = "{(\<Psi>', P, Q) | \<Psi> P Q \<Psi>'. \<Psi> \<rhd> P \<approx> Q \<and> \<Psi> \<simeq> \<Psi>'}"
  from \<open>\<Psi> \<rhd> P \<approx> Q\<close> \<open>\<Psi> \<simeq> \<Psi>'\<close> have "(\<Psi>', P, Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cStatImp \<Psi>' P Q)
    from \<open>(\<Psi>', P, Q) \<in> ?X\<close> obtain \<Psi> where "\<Psi> \<rhd> P \<approx> Q" and "\<Psi> \<simeq> \<Psi>'"
      by auto
    from \<open>\<Psi> \<rhd> P \<approx> Q\<close> have "\<Psi> \<rhd> P \<lessapprox><weakBisim> Q" by(rule weakBisimE)
    moreover note \<open>\<Psi> \<simeq> \<Psi>'\<close>
    moreover have "\<And>\<Psi> P Q \<Psi>'. \<lbrakk>\<Psi> \<rhd> P \<approx> Q; \<Psi> \<simeq> \<Psi>'\<rbrakk> \<Longrightarrow> (\<Psi>', P, Q) \<in> ?X \<union> weakBisim"
      by auto
    ultimately show ?case by(rule weakStatImpStatEq)
  next
    case(cSim \<Psi>' P Q)
    from \<open>(\<Psi>', P, Q) \<in> ?X\<close> obtain \<Psi> where "\<Psi> \<rhd> P \<approx> Q" and "\<Psi> \<simeq> \<Psi>'"
      by auto
    from \<open>\<Psi> \<rhd> P \<approx> Q\<close> have "\<Psi> \<rhd> P \<leadsto><weakBisim> Q" by(blast dest: weakBisimE)
    moreover have "eqvt ?X"
      by(auto simp add: eqvt_def) (metis weakBisimClosed AssertionStatEqClosed)
    hence "eqvt(?X \<union> weakBisim)" by auto
    moreover note \<open>\<Psi> \<simeq> \<Psi>'\<close>
    moreover have "\<And>\<Psi> P Q \<Psi>'. \<lbrakk>\<Psi> \<rhd> P \<approx> Q; \<Psi> \<simeq> \<Psi>'\<rbrakk> \<Longrightarrow> (\<Psi>', P, Q) \<in> ?X \<union> weakBisim"
      by auto
    ultimately show ?case by(rule weakSimStatEq)
  next
    case(cExt \<Psi>' P Q \<Psi>'')
    from \<open>(\<Psi>', P, Q) \<in> ?X\<close> obtain \<Psi> where "\<Psi> \<rhd> P \<approx> Q" and "\<Psi> \<simeq> \<Psi>'"
      by auto
    from \<open>\<Psi> \<rhd> P \<approx> Q\<close> have "\<Psi> \<otimes> \<Psi>'' \<rhd> P \<approx> Q" by(rule weakBisimE)
    moreover from \<open>\<Psi> \<simeq> \<Psi>'\<close> have "\<Psi> \<otimes> \<Psi>'' \<simeq> \<Psi>' \<otimes> \<Psi>''" by(rule Composition)
    ultimately show ?case by blast
  next
    case(cSym \<Psi>' P Q)
    from \<open>(\<Psi>', P, Q) \<in> ?X\<close> obtain \<Psi> where "\<Psi> \<rhd> P \<approx> Q" and "\<Psi> \<simeq> \<Psi>'"
      by auto
    from \<open>\<Psi> \<rhd> P \<approx> Q\<close> have "\<Psi> \<rhd> Q \<approx> P" by(rule weakBisimE)
    thus ?case using \<open>\<Psi> \<simeq> \<Psi>'\<close> by auto
  qed
qed

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

  assumes PQ: "\<Psi> \<rhd> P \<approx> Q"
  and     QR: "\<Psi> \<rhd> Q \<approx> R"

  shows "\<Psi> \<rhd> P \<approx> R"
proof -
  let ?X = "{(\<Psi>, P, R) | \<Psi> P R. \<exists>Q. \<Psi> \<rhd> P \<approx> Q \<and> \<Psi> \<rhd> Q \<approx> R}"
  from PQ QR have "(\<Psi>, P, R) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cStatImp \<Psi> P R)
    from \<open>(\<Psi>, P, R) \<in> ?X\<close> obtain Q where "\<Psi> \<rhd> P \<approx> Q" and  "\<Psi> \<rhd> Q \<approx> R" by blast
    from \<open>\<Psi> \<rhd> P \<approx> Q\<close> have "\<Psi> \<rhd> P \<lessapprox><weakBisim> Q" by(rule weakBisimE)
    moreover note \<open>\<Psi> \<rhd> Q \<approx> R\<close>
    moreover have "?X \<subseteq> ?X \<union> weakBisim" by auto
    moreover note weakBisimE(1)
    moreover from weakBisimE(2) have "\<And>\<Psi> P Q P'. \<lbrakk>\<Psi> \<rhd> P \<approx> Q; \<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'\<rbrakk> \<Longrightarrow> \<exists>Q'. \<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q' \<and> \<Psi> \<rhd> P' \<approx> Q'"
      by(metis weakBisimE(4) weakSimTauChain)
    ultimately show ?case by(rule weakStatImpTransitive)
  next
    case(cSim \<Psi> P R)
    {
      fix \<Psi> P Q R
      assume "\<Psi> \<rhd> P \<approx> Q" and "\<Psi> \<rhd> Q \<leadsto><weakBisim> R"
      moreover have "eqvt ?X"
        by(force simp add: eqvt_def dest: weakBisimClosed)
      with weakBisimEqvt have "eqvt (?X \<union> weakBisim)" by blast
      moreover have "?X \<subseteq> ?X \<union> weakBisim" by auto
      moreover note weakBisimE(2)
      ultimately have "\<Psi> \<rhd> P \<leadsto><(?X \<union> weakBisim)> R"
        by(rule_tac weakSimTransitive) auto
    }
    with \<open>(\<Psi>, P, R) \<in> ?X\<close> show ?case
      by(blast dest: weakBisimE)
  next
    case(cExt \<Psi> P R \<Psi>')
    thus ?case by(blast dest: weakBisimE)
  next
    case(cSym \<Psi> P R)
    thus ?case by(blast dest: weakBisimE)
  qed
qed

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

  assumes "\<Psi> \<rhd> P \<sim> Q"

  shows "\<Psi> \<rhd> P \<approx> Q"
proof -
  from \<open>\<Psi> \<rhd> P \<sim> Q\<close>
  show ?thesis
  proof(coinduct rule: weakBisimWeakCoinduct)
    case(cStatImp \<Psi> P Q)
    from \<open>\<Psi> \<rhd> P \<sim> Q\<close> have "insertAssertion(extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion(extractFrame Q) \<Psi>"
      by(metis bisimE FrameStatEq_def)
    moreover from \<open>\<Psi> \<rhd> P \<sim> Q\<close> have "\<And>\<Psi>'. \<Psi> \<otimes> \<Psi>' \<rhd> P \<sim> Q" by(rule bisimE)
    ultimately show ?case by(rule statImpWeakStatImp)
  next
    case(cSim \<Psi> P Q)
    note \<open>\<Psi> \<rhd> P \<sim> Q\<close>
    moreover have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> insertAssertion(extractFrame Q) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion(extractFrame P) \<Psi>"
      by(drule_tac bisimE) (simp add: FrameStatEq_def)
    ultimately show ?case using bisimE(2) bisimE(3)
      by(rule strongSimWeakSim)
  next
    case(cExt \<Psi> P Q \<Psi>')
    from \<open>\<Psi> \<rhd> P \<sim> Q\<close> show ?case
      by(rule bisimE)
  next
    case(cSym \<Psi> P Q)
    from \<open>\<Psi> \<rhd> P \<sim> Q\<close> show ?case
      by(rule bisimE)
  qed
qed

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

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

  shows "P \<approx> Q"
using assms
by(metis structCongBisim strongBisimWeakBisim)

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

  assumes "(\<Psi>, P, Q) \<in> Rel"
  and     "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'"
  and     Sim: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> Rel \<Longrightarrow> \<Psi> \<rhd> P \<leadsto>[Rel] Q"

  obtains P' where "\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'" and "(\<Psi>, P', Q') \<in> Rel"
proof -
  assume A: "\<And>P'. \<lbrakk>\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'; (\<Psi>, P', Q') \<in> Rel\<rbrakk> \<Longrightarrow> thesis"
  from \<open>\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'\<close> \<open>(\<Psi>, P, Q) \<in> Rel\<close> A show ?thesis
  proof(induct arbitrary: P thesis rule: tauChainInduct)
    case(TauBase Q P)
    moreover have "\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P" by simp
    ultimately show ?case by blast
  next
    case(TauStep Q Q' Q'' P)
    from \<open>(\<Psi>, P, Q) \<in> Rel\<close> obtain P' where PChain: "\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'" and "(\<Psi>, P', Q') \<in> Rel"
      by(rule TauStep)
    from \<open>(\<Psi>, P', Q') \<in> Rel\<close> have "\<Psi> \<rhd> P' \<leadsto>[Rel] Q'" by(rule Sim)
    then obtain P'' where P'Chain: "\<Psi> \<rhd> P' \<longmapsto>\<tau> \<prec> P''" and "(\<Psi>, P'', Q'') \<in> Rel"
      using \<open>\<Psi> \<rhd> Q' \<longmapsto>\<tau> \<prec> Q''\<close> by(drule_tac simE) auto
    from PChain P'Chain have "\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P''" by(auto dest: tauActTauChain)
    thus ?case using \<open>(\<Psi>, P'', Q'') \<in> Rel\<close> by(rule TauStep)
  qed
qed

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

  assumes "quiet P"

  shows "\<Psi> \<rhd> P \<approx> \<zero>"
proof -
  let ?X = "{(\<Psi>, \<zero>, P) | \<Psi> P. quiet P} \<union> {(\<Psi>, P, \<zero>) | \<Psi> P. quiet P}"

  from \<open>quiet P\<close> have "(\<Psi>, P, \<zero>) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimWeakCoinduct)
    case(cStatImp \<Psi> P Q)
    thus ?case
      apply(simp add: weakStatImp_def)
      apply(rule allI)
      apply(rule_tac x=Q in exI)
      apply auto
      apply(drule_tac \<Psi>=\<Psi> in quietFrame)
      apply(rule_tac G="\<langle>\<epsilon>, \<Psi>\<rangle>" in FrameStatImpTrans)
      using Identity
      apply(simp add: AssertionStatEq_def)
      apply(simp add: FrameStatEq_def)
      apply(drule_tac \<Psi>=\<Psi> in quietFrame)
      apply(rule_tac G="\<langle>\<epsilon>, \<Psi>\<rangle>" in FrameStatImpTrans)
      apply auto
      defer
      using Identity
      apply(simp add: AssertionStatEq_def)
      apply(simp add: FrameStatEq_def)
      done
  next
    case(cSim \<Psi> P Q)
    moreover have "eqvt ?X" by(auto simp add: eqvt_def intro: quietEqvt)
    ultimately show ?case
      apply auto
      apply(rule quietSim)
      apply auto
      apply(auto simp add: weakSimulation_def)
      done
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by blast
  next
    case(cSym \<Psi> P Q)
    thus ?case by blast
  qed
qed

lemma weakTransitiveWeakCoinduct[case_names cStatImp cSim cExt cSym, case_conclusion bisim step, consumes 2]:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   X :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes p: "(\<Psi>, P, Q) \<in> X"
  and Eqvt: "eqvt X"
  and rStatImp: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> \<Psi> \<rhd> P \<lessapprox><X> Q"
  and rSim: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> \<Psi> \<rhd> P \<leadsto><({(\<Psi>, P, Q) | \<Psi> P Q. \<exists>P' Q'. \<Psi> \<rhd> P \<sim> P' \<and>
                                                                        (\<Psi>, P', Q') \<in> X \<and>
                                                                        \<Psi> \<rhd> Q' \<sim> Q})> Q"
  and rExt: "\<And>\<Psi> P Q \<Psi>'. (\<Psi>, P, Q) \<in> X \<Longrightarrow> (\<Psi> \<otimes> \<Psi>', P, Q) \<in> X"
  and rSym: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> (\<Psi>, Q, P) \<in> X"

  shows "\<Psi> \<rhd> P \<approx> Q"
proof -
  let ?X = "{(\<Psi>, P, Q) | \<Psi> P Q. \<exists>P' Q'. \<Psi> \<rhd> P \<sim> P' \<and> (\<Psi>, P', Q') \<in> X \<and> \<Psi> \<rhd> Q' \<sim> Q}"
  from p have "(\<Psi>, P, Q) \<in> ?X"
    by(blast intro: bisimReflexive)
  thus ?thesis
  proof(coinduct rule: weakBisimWeakCoinduct)
    case(cStatImp \<Psi> P Q)
    {
      fix \<Psi>'
      from \<open>(\<Psi> , P, Q) \<in> ?X\<close> obtain P' Q' where "\<Psi> \<rhd> P \<sim> P'" and "(\<Psi>, P', Q') \<in> X" and "\<Psi> \<rhd> Q' \<sim> Q" by auto
      from \<open>(\<Psi>, P', Q') \<in> X\<close> obtain Q'' Q''' where Q'Chain: "\<Psi> \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''"
                                               and PImpQ: "insertAssertion (extractFrame P') \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q'') \<Psi>"
                                               and Q''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> Q'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'''" and "(\<Psi> \<otimes> \<Psi>', P', Q''') \<in> X"
        apply(drule_tac rStatImp) by(auto simp add: weakStatImp_def) blast
      from \<open>\<Psi> \<rhd> Q' \<sim> Q\<close> have "\<Psi> \<rhd> Q \<sim> Q'" by(rule bisimE)
      then obtain Q'''' where "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''''" and "\<Psi> \<rhd> Q'''' \<sim> Q''" using  \<open>\<Psi> \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''\<close> bisimE(2)
        by(rule simTauChain)
      note \<open>\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''''\<close>
      moreover have "insertAssertion (extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q'''') \<Psi>"
      proof -
        from \<open>\<Psi> \<rhd> P \<sim> P'\<close> have "insertAssertion (extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame P') \<Psi>"
          by(drule_tac bisimE) (simp add: FrameStatEq_def)
        moreover from \<open>\<Psi> \<rhd> Q'''' \<sim> Q''\<close> have "insertAssertion (extractFrame Q'') \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q'''') \<Psi>"
          by(drule_tac bisimE) (simp add: FrameStatEq_def)
        ultimately show ?thesis using PImpQ by(blast intro: FrameStatImpTrans)
      qed
      moreover from \<open>\<Psi> \<rhd> Q'''' \<sim> Q''\<close> have "\<Psi> \<otimes> \<Psi>' \<rhd> Q'''' \<sim> Q''" by(metis bisimE)
      then obtain Q''''' where Q''''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> Q'''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'''''" and "\<Psi> \<otimes> \<Psi>' \<rhd> Q''''' \<sim> Q'''" using Q''Chain bisimE(2)
        by(rule simTauChain)
      moreover from \<open>\<Psi> \<rhd> P \<sim> P'\<close> \<open>(\<Psi> \<otimes> \<Psi>' , P', Q''') \<in> X\<close> \<open>\<Psi> \<otimes> \<Psi>' \<rhd> Q''''' \<sim> Q'''\<close> have "(\<Psi> \<otimes> \<Psi>', P, Q''''') \<in> ?X" by(auto dest: bisimE)
      ultimately have "\<exists>Q' Q''. \<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'' \<and> insertAssertion (extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q'') \<Psi> \<and> \<Psi> \<otimes> \<Psi>' \<rhd> Q'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q' \<and> (\<Psi> \<otimes> \<Psi>', P, Q') \<in> ?X" by blast
    }
    with \<open>(\<Psi>, P, Q) \<in> ?X\<close> show ?case by(simp add: weakStatImp_def) blast
  next
    case(cSim \<Psi> P Q)
    from \<open>(\<Psi>, P, Q) \<in> ?X\<close> obtain P' Q' where "\<Psi> \<rhd> P \<sim> P'" and "(\<Psi>, P', Q') \<in> X" and "\<Psi> \<rhd> Q' \<sim> Q" by auto
    from \<open>(\<Psi>, P', Q') \<in> X\<close> have "\<Psi> \<rhd> P' \<leadsto><?X> Q'"
      by(rule rSim)
    moreover from \<open>\<Psi> \<rhd> Q' \<sim> Q\<close> have "\<Psi> \<rhd> Q' \<leadsto>[bisim] Q" by(rule bisimE)
    moreover from \<open>eqvt X\<close> have "eqvt ?X"
      apply(auto simp add: eqvt_def)
      apply(drule_tac p=p in bisimClosed)
      apply(drule_tac p=p in bisimClosed)
      apply(rule_tac x="p \<bullet> P'" in exI, simp)
      by(rule_tac x="p \<bullet> Q'" in exI, auto)
    moreover from \<open>\<Psi> \<rhd> Q' \<sim> Q\<close> have "insertAssertion (extractFrame Q) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q') \<Psi>"
      by(drule_tac bisimE) (simp add: FrameStatEq_def)
    moreover have "{(\<Psi>, P, R) | \<Psi> P R. \<exists>Q. (\<Psi>, P, Q) \<in> ?X \<and> \<Psi> \<rhd> Q \<sim> R} \<subseteq> ?X"
      by(blast intro: bisimTransitive)
    moreover note bisimE(3)
    ultimately have "\<Psi> \<rhd> P' \<leadsto><?X> Q" by(rule strongAppend)
    moreover have "{(\<Psi>, P, R) | \<Psi> P R. \<exists>Q. \<Psi> \<rhd> P \<sim> Q \<and> (\<Psi>, Q, R) \<in> ?X} \<subseteq> ?X"
      by(blast intro: bisimTransitive)
    moreover {
      fix \<Psi> P Q

      assume "\<Psi> \<rhd> P \<sim> Q"
      moreover have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> insertAssertion (extractFrame Q) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame P) \<Psi>"
        by(drule_tac bisimE) (simp add: FrameStatEq_def)
      ultimately have "\<Psi> \<rhd> P \<leadsto><bisim> Q" using bisimE(2) bisimE(3)
        by(rule strongSimWeakSim)
    }
    ultimately show ?case using \<open>\<Psi> \<rhd> P \<sim> P'\<close> \<open>eqvt ?X\<close>
      by(rule_tac weakSimTransitive)
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by(blast dest: bisimE intro: rExt)
  next
    case(cSym \<Psi> P Q)
    thus ?case by(blast dest: bisimE intro: rSym)
  qed
qed

  assumes p: "(\<Psi>, P, Q) \<in> X"
  and Eqvt: "eqvt X"
  and rStatImp: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> \<Psi> \<rhd> P \<lessapprox><(X \<union> weakBisim)> Q"
  and rSim: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> \<Psi> \<rhd> P \<leadsto><({(\<Psi>, P, Q) | \<Psi> P Q. \<exists>P' Q'. \<Psi> \<rhd> P \<sim> P' \<and>
                                                                        (\<Psi>, P', Q') \<in> (X \<union> weakBisim) \<and>
                                                                        \<Psi> \<rhd> Q' \<sim> Q})> Q"
  and rExt: "\<And>\<Psi> P Q \<Psi>'. (\<Psi>, P, Q) \<in> X \<Longrightarrow> (\<Psi> \<otimes> \<Psi>', P, Q) \<in> X \<union> weakBisim"
  and rSym: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> (\<Psi>, Q, P) \<in> X \<union> weakBisim"

  shows "\<Psi> \<rhd> P \<approx> Q"
proof -
  from p have "(\<Psi>, P, Q) \<in> X \<union> weakBisim" by auto
  moreover from \<open>eqvt X\<close> have "eqvt(X \<union> weakBisim)" by auto
  ultimately show ?thesis
  proof(coinduct rule: weakTransitiveWeakCoinduct)
    case(cStatImp \<Psi> P Q)
    thus ?case by(blast dest: rStatImp weakBisimE(1) weakStatImpMonotonic)
  next
    case(cSim \<Psi> P Q)
    thus ?case by(fastforce intro: rSim weakBisimE(2) weakSimMonotonic bisimReflexive)
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by(blast dest: weakBisimE rExt)
  next
    case(cSym \<Psi> P Q)
    thus ?case by(blast dest: weakBisimE rSym)
  qed
qed

lemma weakTransitiveCoinduct2[case_names cStatImp cSim cExt cSym, case_conclusion bisim step, consumes 2]:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   X :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes p: "(\<Psi>, P, Q) \<in> X"
  and Eqvt: "eqvt X"
  and rStatImp: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> \<Psi> \<rhd> P \<lessapprox><X> Q"
  and rSim: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> \<Psi> \<rhd> P \<leadsto><({(\<Psi>, P, Q) | \<Psi> P Q. \<exists>P' Q'. \<Psi> \<rhd> P \<approx> P' \<and> (\<Psi>, P', Q') \<in> X \<and> \<Psi> \<rhd> Q' \<sim> Q})> Q"
  and rExt: "\<And>\<Psi> P Q \<Psi>'. (\<Psi>, P, Q) \<in> X \<Longrightarrow> (\<Psi> \<otimes> \<Psi>', P, Q) \<in> X"
  and rSym: "\<And>\<Psi> P Q. (\<Psi>, P, Q) \<in> X \<Longrightarrow> (\<Psi>, Q, P) \<in> X"

  shows "\<Psi> \<rhd> P \<approx> Q"
proof -
  let ?X = "{(\<Psi>, P, Q) | \<Psi> P Q. \<exists>P' Q'. \<Psi> \<rhd> P \<approx> P' \<and> (\<Psi>, P', Q') \<in> X \<and> \<Psi> \<rhd> Q' \<sim> Q}"
  let ?Y = "{(\<Psi>, P, Q) | \<Psi> P Q. \<exists>P' Q'. \<Psi> \<rhd> P \<approx> P' \<and> (\<Psi>, P', Q') \<in> X \<and> \<Psi> \<rhd> Q' \<approx> Q}"

  from \<open>eqvt X\<close> have "eqvt ?X"
    apply(auto simp add: eqvt_def)
    apply(drule_tac p=p in bisimClosed)
    apply(drule_tac p=p in weakBisimClosed)
    apply(rule_tac x="p \<bullet> P'" in exI, simp)
    by(rule_tac x="p \<bullet> Q'" in exI, auto)
  from \<open>eqvt X\<close> have "eqvt ?Y"
    apply(auto simp add: eqvt_def)
    apply(drule_tac p=p in weakBisimClosed)
    apply(drule_tac p=p in weakBisimClosed)
    apply(rule_tac x="p \<bullet> P'" in exI, simp)
    by(rule_tac x="p \<bullet> Q'" in exI, auto)

  {
    fix \<Psi> P Q
    assume "(\<Psi>, P, Q) \<in> ?X"
    then obtain P' Q' where "\<Psi> \<rhd> P \<approx> P'" and "(\<Psi>, P', Q') \<in> X" and "\<Psi> \<rhd> Q' \<sim> Q"
      by auto
    note \<open>\<Psi> \<rhd> P \<approx> P'\<close>
    moreover from \<open>(\<Psi>, P', Q') \<in> X\<close> have "\<Psi> \<rhd> P' \<leadsto><?X> Q'" by(rule rSim)
    moreover note \<open>eqvt ?X\<close>
    moreover have "{(\<Psi>, P, R) | \<Psi> P R. \<exists>Q. \<Psi> \<rhd> P \<approx> Q \<and> (\<Psi>, Q, R) \<in> ?X} \<subseteq> ?X"
      by(blast intro: weakBisimTransitive)
    ultimately have "\<Psi> \<rhd> P \<leadsto><?X> Q'" using weakBisimE(2) by(rule weakSimTransitive)
    moreover from \<open>\<Psi> \<rhd> Q' \<sim> Q\<close> have "\<Psi> \<rhd> Q' \<leadsto>[bisim] Q" by(rule bisimE)
    moreover note \<open>eqvt ?X\<close>
    moreover from \<open>\<Psi> \<rhd> Q' \<sim> Q\<close> have "insertAssertion (extractFrame Q) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q') \<Psi>"
      by(drule_tac bisimE) (simp add: FrameStatEq_def)
    moreover have "{(\<Psi>, P, R) | \<Psi> P R. \<exists>Q. (\<Psi>, P, Q) \<in> ?X \<and> \<Psi> \<rhd> Q \<sim> R} \<subseteq> ?X"
      by(blast dest: bisimTransitive)
    moreover note bisimE(3)
    ultimately have "\<Psi> \<rhd> P \<leadsto><?X> Q" by(rule_tac strongAppend)
  }
  note Goal = this

  from p have "(\<Psi>, P, Q) \<in> ?Y" by(blast intro: weakBisimReflexive bisimReflexive rSym)
  thus ?thesis
  proof(coinduct rule: weakBisimWeakCoinduct)
  next
    case(cStatImp \<Psi> P Q)
    {
      fix \<Psi>'

      from \<open>(\<Psi>, P, Q) \<in> ?Y\<close> obtain R S where "\<Psi> \<rhd> P \<approx> R" and "(\<Psi>, R, S) \<in> X" and "\<Psi> \<rhd> S \<approx> Q" by auto
      from \<open>\<Psi> \<rhd> P \<approx> R\<close> obtain R'' R'
        where RChain: "\<Psi> \<rhd> R \<Longrightarrow>\<^sup>^\<^sub>\<tau> R''"
          and PImpR'': "insertAssertion (extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame R'') \<Psi>"
          and R''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> R'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> R'"
          and "\<Psi> \<otimes> \<Psi>' \<rhd> P \<approx> R'"
        apply(drule_tac weakBisimE) by(simp add: weakStatImp_def) blast

      from \<open>(\<Psi>, R, S) \<in> X\<close> have "(\<Psi>, S, R) \<in> ?X" by(blast intro: weakBisimReflexive bisimReflexive rSym)
      with RChain obtain S'' where SChain: "\<Psi> \<rhd> S \<Longrightarrow>\<^sup>^\<^sub>\<tau> S''" and "(\<Psi>, S'', R'') \<in> ?X" using Goal
        by(rule weakSimTauChain)

      from \<open>(\<Psi>, S'', R'') \<in> ?X\<close> obtain T U where "\<Psi> \<rhd> S'' \<approx> T" and "(\<Psi>, T, U) \<in> X" and "\<Psi> \<rhd> U \<sim> R''"
        by auto
      from \<open>\<Psi> \<rhd> U \<sim> R''\<close> have R''ImpU: "insertAssertion (extractFrame R'') \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame U) \<Psi>"
        by(drule_tac bisimE) (simp add: FrameStatEq_def)

      from \<open>(\<Psi>, T, U) \<in> X\<close> weakStatImp_def
      obtain T'' T' where TChain: "\<Psi> \<rhd> T \<Longrightarrow>\<^sup>^\<^sub>\<tau> T''"
                      and UImpT'': "insertAssertion (extractFrame U) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame T'') \<Psi>"
                      and T''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> T'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> T'"
                      and "(\<Psi> \<otimes> \<Psi>', U, T') \<in> X"
        by(blast dest: rStatImp rSym)

      from TChain \<open>\<Psi> \<rhd> S'' \<approx> T\<close> weakBisimE(2) obtain S''' where S''Chain: "\<Psi> \<rhd> S'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> S'''" and "\<Psi> \<rhd> S''' \<approx> T''"
        by(rule weakSimTauChain)

      from \<open>\<Psi> \<rhd> S''' \<approx> T''\<close> weakStatImp_def
      obtain S''''' S'''' where S'''Chain: "\<Psi> \<rhd> S''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> S'''''"
                            and T''ImpS''''': "insertAssertion (extractFrame T'') \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame S''''') \<Psi>"
                            and S'''''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> S''''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> S''''"
                            and "\<Psi> \<otimes> \<Psi>' \<rhd> T'' \<approx> S''''"
        by(metis weakBisimE)

      from SChain S''Chain S'''Chain have "\<Psi> \<rhd> S \<Longrightarrow>\<^sup>^\<^sub>\<tau> S'''''" by auto
      moreover from \<open>\<Psi> \<rhd> S \<approx> Q\<close> have "\<Psi> \<rhd> Q \<approx> S" by(rule weakBisimE)
      ultimately obtain Q''' where QChain: "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'''" and "\<Psi> \<rhd> Q''' \<approx> S'''''" using weakBisimE(2)
        by(rule weakSimTauChain)
      from \<open>\<Psi> \<rhd> Q''' \<approx> S'''''\<close> have "\<Psi> \<rhd> S''''' \<approx> Q'''" by(rule weakBisimE)
      then obtain Q'' Q' where Q'''Chain: "\<Psi> \<rhd> Q''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''"
                           and S'''''ImpQ'': "insertAssertion (extractFrame S''''') \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q'') \<Psi>"
                           and Q''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> Q'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'"
                           and "\<Psi> \<otimes> \<Psi>' \<rhd> S''''' \<approx> Q'" using weakStatImp_def
        by(metis weakBisimE)

      from QChain Q'''Chain have "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''" by auto
      moreover from PImpR'' R''ImpU UImpT'' T''ImpS''''' S'''''ImpQ''
      have "insertAssertion (extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q'') \<Psi>"
        by(blast dest: FrameStatImpTrans)

      moreover from \<open>\<Psi> \<rhd> U \<sim> R''\<close> have "\<Psi> \<otimes> \<Psi>' \<rhd> U \<approx> R''" by(metis weakBisimE strongBisimWeakBisim)
      with R''Chain obtain U' where UChain: "\<Psi> \<otimes> \<Psi>' \<rhd> U \<Longrightarrow>\<^sup>^\<^sub>\<tau> U'" and "\<Psi> \<otimes> \<Psi>' \<rhd> U' \<approx> R'" using weakBisimE(2)
        by(rule weakSimTauChain)
      from \<open>\<Psi> \<otimes> \<Psi>' \<rhd> U' \<approx> R'\<close> have "\<Psi> \<otimes> \<Psi>' \<rhd> R' \<approx> U'" by(rule weakBisimE)
      from \<open>(\<Psi> \<otimes> \<Psi>', U, T') \<in> X\<close> have "(\<Psi> \<otimes> \<Psi>', T', U) \<in> ?X" by(blast intro: rSym weakBisimReflexive bisimReflexive)
      with UChain obtain T''' where T'Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> T' \<Longrightarrow>\<^sup>^\<^sub>\<tau> T'''" and "(\<Psi> \<otimes> \<Psi>', T''', U') \<in> ?X" using Goal
        by(rule weakSimTauChain)
      from \<open>(\<Psi> \<otimes> \<Psi>', T''', U') \<in> ?X\<close> have "(\<Psi> \<otimes> \<Psi>', U', T''') \<in> ?Y"
        by(blast dest: weakBisimE rSym strongBisimWeakBisim)
      from T''Chain T'Chain have "\<Psi> \<otimes> \<Psi>' \<rhd> T'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> T'''" by auto
      then obtain S'''''' where S''''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> S'''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> S''''''" and "\<Psi> \<otimes> \<Psi>' \<rhd> T''' \<approx> S''''''"
        using  \<open>\<Psi> \<otimes> \<Psi>' \<rhd> T'' \<approx> S''''\<close> weakBisimE(2)
        apply(drule_tac weakBisimE(4))
        by(rule weakSimTauChain) (auto dest: weakBisimE(4))
      from S'''''Chain S''''Chain have "\<Psi> \<otimes> \<Psi>' \<rhd> S''''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> S''''''" by auto

      with \<open>\<Psi> \<otimes> \<Psi>' \<rhd> S''''' \<approx> Q'\<close>
      obtain Q'''' where Q'Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''''" and "\<Psi> \<otimes> \<Psi>' \<rhd> S'''''' \<approx> Q''''" using weakBisimE(2)
        apply(drule_tac weakBisimE(4))
        by(rule weakSimTauChain) (auto dest: weakBisimE(4))

      from Q''Chain Q'Chain have "\<Psi> \<otimes> \<Psi>' \<rhd> Q'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''''" by auto
      moreover from \<open>\<Psi> \<otimes> \<Psi>' \<rhd> P \<approx> R'\<close> \<open>\<Psi> \<otimes> \<Psi>' \<rhd> R' \<approx> U'\<close> \<open>(\<Psi> \<otimes> \<Psi>', U', T''') \<in> ?Y\<close> \<open>\<Psi> \<otimes> \<Psi>' \<rhd> T''' \<approx> S''''''\<close>
                    \<open>\<Psi> \<otimes> \<Psi>' \<rhd> S'''''' \<approx> Q''''\<close>
      have "(\<Psi> \<otimes> \<Psi>', P, Q'''') \<in> ?Y"
        by auto (blast dest: weakBisimTransitive)
      ultimately have "\<exists>Q'' Q'. \<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'' \<and> insertAssertion (extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q'') \<Psi> \<and> \<Psi> \<otimes> \<Psi>' \<rhd> Q'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q' \<and> (\<Psi> \<otimes> \<Psi>', P, Q') \<in> ?Y"
        by blast
    }
    thus ?case by(simp add: weakStatImp_def)
  next
    case(cSim \<Psi> P Q)
    moreover {
      fix \<Psi> P P' Q' Q
      assume "\<Psi> \<rhd> P \<approx> P'" and "(\<Psi>, P', Q') \<in> X" and "\<Psi> \<rhd> Q' \<approx> Q"
      from \<open>(\<Psi>, P', Q') \<in> X\<close> have "(\<Psi>, P', Q') \<in> ?X"
        by(blast intro: weakBisimReflexive bisimReflexive)
      moreover from \<open>\<Psi> \<rhd> Q' \<approx> Q\<close> have "\<Psi> \<rhd> Q' \<leadsto><weakBisim> Q" by(rule weakBisimE)
      moreover note \<open>eqvt ?Y\<close>
      moreover have "{(\<Psi>, P, R) | \<Psi> P R. \<exists>Q. (\<Psi>, P, Q) \<in> ?X \<and> \<Psi> \<rhd> Q \<approx> R} \<subseteq> ?Y"
        by(blast dest: weakBisimTransitive strongBisimWeakBisim)
      ultimately have "\<Psi> \<rhd> P' \<leadsto><?Y> Q" using Goal
        by(rule weakSimTransitive)
      note \<open>\<Psi> \<rhd> P \<approx> P'\<close> this \<open>eqvt ?Y\<close>
      moreover have "{(\<Psi>, P, R) | \<Psi> P R. \<exists>Q. \<Psi> \<rhd> P \<approx> Q \<and> (\<Psi>, Q, R) \<in> ?Y} \<subseteq> ?Y"
        by(blast dest: weakBisimTransitive)
      ultimately have "\<Psi> \<rhd> P \<leadsto><?Y> Q" using weakBisimE(2)
        by(rule weakSimTransitive)
    }
    ultimately show ?case by auto
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by(blast dest: bisimE weakBisimE intro: rExt)
  next
    case(cSym \<Psi> P Q)
    thus ?case by(blast dest: bisimE(4) weakBisimE(4) rSym)
  qed
qed

end

end


theory RedSafeCase
  imports WTLemma RedSafeUnpack
begin

  (* ###### case lemmas *)

lemma safe_app_op_case: "\<lbrakk> app_red_exp OpApp (s1, AppExp (OpExp xop) v) ax (s2, e2); FunTy tx tau r a = op_type xop \<rbrakk> \<Longrightarrow> well_typed env r_s1 e2 tau r_s1 empty_use_env"
  apply (case_tac v)
       apply (auto)
  apply (case_tac ax)
   apply (auto)
    (* given xop: op, x1: const, assuming tau matches the return type of xop, we want to show that e2 is well-typed.
        now e2 can either be an op or a const.
    *)
  apply (case_tac "\<not> (\<exists> rop. e2 = OpExp rop)")
   apply (case_tac "\<not> (\<exists> c. e2 = ConstExp c)")
    apply (auto)
        apply (case_tac xop)
             apply (auto)
    (* the hard part is proving that e2 will have the right type. *)
       apply (case_tac xop)
            apply (auto)
         apply (simp add: pure_fun_def)
        apply (simp add: pure_fun_def)
       apply (simp add: pure_fun_def)
      apply (rule_tac id_leq_use_env)
     apply (rule_tac leq_empty_use_env)
    (* op case, same thing *)
    apply (case_tac xop)
         apply (auto)
      apply (simp add: pure_fun_def)
     apply (simp add: pure_fun_def)
    apply (simp add: pure_fun_def)
   apply (rule_tac id_leq_use_env)
  apply (rule_tac leq_empty_use_env)
  done

lemma well_typed_state_add_vars: "\<lbrakk> well_typed_state s1 env rs_map; fresh_var s1 x; well_typed_mem_value env r_s tau v; proper_mem_value rs_map v;
  sub_use_env s1 r_s; sep_nres_map r_s (rem_env rs_map x) \<rbrakk> \<Longrightarrow>
  well_typed_state (add_env s1 x v) (add_env env (Loc x) tau) (add_env rs_map x r_s)"
    (* starts by proving the validity of the env + res map *)
  apply (simp add: well_typed_state_def)
  apply (auto)
    apply (rule_tac dist_add_sub_env)
    apply (simp)
   apply (simp add: valid_nres_map_def)
   apply (auto)
    (* the state is still fully covered by the map *)
     apply (simp add: full_nres_map_def)
     apply (auto)
      apply (simp add: add_env_def)
      apply (auto)
     apply (simp add: add_env_def)
     apply (auto)
    (* prove disjointness remains *)
    apply (rule_tac disj_add_nres_map)
     apply (auto)
    (* prove containment remains *)
   apply (rule_tac add_sub_nres_map2)
    apply (rule_tac add_sub_nres_map1)
     apply (simp_all)
   apply (simp add: fresh_var_def)
    (* now it remains to prove that all the values are still well-typed. we do the x = xa case first *)
  apply (erule_tac x="xa" in allE)
  apply (case_tac "x = xa")
   apply (case_tac "add_env s1 x v x")
    apply (simp add: add_env_def)
   apply (auto)
   apply (case_tac "add_env env (Loc x) tau (Loc x)")
    apply (simp add: add_env_def)
   apply (auto)
   apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" in nres_add_same)
   apply (simp)
   apply (rule_tac well_typed_mv_add_vars)
    apply (simp add: add_env_def)
   apply (simp add: fresh_var_def)
    apply (simp add: sub_env_def)
    apply (erule_tac x="Loc x" in allE)
    apply (auto)
    (* proper mem value *)
   apply (rule_tac proper_add_mv)
    apply (simp add: add_env_def)
   apply (simp add: nres_lookup_def)
   apply (simp add: valid_nres_map_def)
   apply (simp add: full_nres_map_def)
   apply (simp add: fresh_var_def)
   apply (rule_tac leq_empty_use_env)
    (* now we do that x \<noteq> xa case *)
  apply (simp add: add_env_def)
  apply (case_tac "s1 xa")
   apply (auto)
  apply (simp add: add_env_def)
  apply (case_tac "env (Loc xa)")
   apply (auto)
  apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" and y="xa" in nres_add_diff)
   apply (simp_all)
  apply (rule_tac well_typed_mv_add_vars)
   apply (auto)
  apply (simp add: fresh_var_def)
   apply (simp add: sub_env_def)
   apply (erule_tac x="Loc x" in allE)
   apply (auto)
    (* properness *)
  apply (rule_tac proper_add_mv)
   apply (simp)
  apply (simp add: fresh_var_def)
  apply (simp add: valid_nres_map_def)
  apply (simp add: full_nres_map_def)
  apply (simp add: nres_lookup_def)
  apply (rule_tac leq_empty_use_env)
  done

lemma sacc_make_act_case: "
        \<lbrakk>well_typed_state s1 env rs_map; app_red_exp ConstApp (s1, AppExp (ConstExp c) v) (MakeAct x) (s2, e2); valid_exp_use_env s1 rs_map r_f;
                well_typed env r_s1 v t1 r_s2 rx2; leq_use_env r_s3 (diff_use_env r_s2 (comp_use_env rx1 (lift_use_env rx2 r))); leq_use_env rx r_s3;
                FunTy t1 t2 r a \<in> const_type c; c \<noteq> FixConst; ax = MakeAct x; leq_use_env r_s1 r_f\<rbrakk>
               \<Longrightarrow> well_typed (add_env env (Loc x) t2) (add_use_env r_s1 (Loc x) OwnPerm) e2 t2 r_s3 rx"
    (* e2 will always be the generated variable *)
  apply (case_tac "e2 \<noteq> VarExp (LocType x x)")
   apply (case_tac c)
                apply (auto)
    (* simple var reqs *)
   apply (simp add: add_env_def)
    apply (case_tac c)
               apply (auto)
  apply (simp add: add_env_def)
  apply (auto)
    apply (case_tac c)
                apply (auto)
    apply (simp add: pure_fun_def)
   apply (rule_tac ereq_leq_use_envx)
   apply (simp add: add_use_env_def)
    (* prelim: x2 is fresh *)
  apply (case_tac "\<not> fresh_var s1 x")
   apply (case_tac c)
                apply (auto)
    (* prelim: cs is empty, remove elim *)(*
  apply (case_tac "\<not> cs = {}")
   apply (case_tac c)
                apply (auto)*)
    (* prelim: r_s3 \<le> r_s1 *)
  apply (cut_tac r_sc="r_s3" and r_sb="diff_use_env r_s2 (comp_use_env rx1 (lift_use_env rx2 r))" and r_sa="r_s1" in trans_leq_use_env)
    apply (rule_tac diff_leq_use_env)
    apply (simp_all)
    (* we can achieve the desired permissions by removing x from the end perms + reqs (which is okay since they dont appear anywhere else yet). *)
  apply (rule_tac x="one_use_env (Loc x) OwnPerm" in exI)
  apply (auto)
    (* - the end perm bound is possible since we assume r_s3 didnt already contain x2 *)
    apply (rule_tac t=" leq_use_env r_s3 (diff_use_env (add_use_env r_s1 (Loc x) OwnPerm) (comp_use_env (ereq_use_env (Loc x) t2) (one_use_env (Loc x) OwnPerm)))" and
        s=" leq_use_env (rem_use_env r_s3 (Loc x)) (diff_use_env (add_use_env r_s1 (Loc x) OwnPerm) (comp_use_env (ereq_use_env (Loc x) t2) (one_use_env (Loc x) OwnPerm)))" in subst)
     apply (cut_tac r_s="r_s3" and x="Loc x" in ignore_rem_use_env)
      apply (rule_tac r_s="r_s1" in leq_use_none)
       apply (auto)
     apply (simp add: valid_exp_use_env_def)
     apply (simp add: sub_use_env_def)
     apply (auto)
     apply (simp add: fresh_var_def)
     apply (cut_tac r_x="r_s1" and r_s="r_f" and x="Loc x" in leq_use_none)
       apply (auto)
    (* - given this, we can finish proving the bound *)
    apply (rule_tac rhs_unroll_dcl_use_env)
    apply (rule_tac rhs_unroll_rem_use_env)
    apply (rule_tac dist_rem_leq_use_env)
    apply (rule_tac rhs_weak_leq_use_env)
     apply (rule_tac weak_ereq_use_env)
     apply (case_tac c)
                   apply (auto)
     apply (simp add: pure_fun_def)
     apply (simp add: unlim_def)
    apply (rule_tac rhs_add_leq_use_env)
     apply (auto)
    (* - unrolling definitions to prove the subtracter bound *)
   apply (simp add: leq_use_env_def)
   apply (simp add: one_use_env_def)
   apply (simp add: add_use_env_def)
    (* - proving the requirement bound *)
  apply (rule_tac r_sb="diff_use_env (ereq_use_env (Loc x) t2) (one_use_env (Loc x) OwnPerm)" in trans_leq_use_env)
   apply (simp add: ereq_use_env_def)
   apply (rule_tac diff_one_leq_use_env)
  apply (rule_tac lhs_unroll_dcl_use_env)
  apply (rule_tac dist_diff_leq_use_env)
  apply (rule_tac self_diff_leq_use_env)
  done

lemma add_env_force_ex: "\<lbrakk> \<forall> z. add_env s x v z = add_env s x w z \<rbrakk> \<Longrightarrow> v = w"
  apply (erule_tac x="x" in allE)
  apply (simp add: add_env_def)
  done

lemma add_env_force: "\<lbrakk> add_env s x v = add_env s x w \<rbrakk> \<Longrightarrow> v = w"
  apply (rule_tac s="s" and x="x" and v="v" and w="w" in add_env_force_ex)
  apply (auto)
  done

lemma disj_add_use_env: "\<lbrakk> disj_use_env r_s r_x; r_s x = NoPerm \<rbrakk> \<Longrightarrow> disj_use_env r_s (add_use_env r_x x r)"
  apply (simp add: disj_use_env_def)
  apply (simp add: add_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  done

lemma strong_disj_add_use_env: "\<lbrakk> strong_disj_use_env r_s r_x; r_s x = NoPerm \<rbrakk> \<Longrightarrow> strong_disj_use_env r_s (add_use_env r_x x r)"
  apply (simp add: strong_disj_use_env_def)
  apply (simp add: add_use_env_def)
  done

lemma add_valid_exp_use_env: "\<lbrakk> valid_nres_map s rs_map; valid_exp_use_env s rs_map r_s; fresh_var s x \<rbrakk> \<Longrightarrow>
  valid_exp_use_env (add_env s x v) (add_env rs_map x empty_use_env) (add_use_env r_s (Loc x) OwnPerm)"
  apply (simp add: valid_exp_use_env_def)
  apply (auto)
    (* domain preservation *)
   apply (rule_tac rhs_add_sub_use_env)
   apply (rule_tac add_sub_use_env)
    apply (simp)
   apply (simp add: add_env_def)
    (* separation *)
  apply (simp add: sep_nres_map_def)
  apply (auto)
  apply (case_tac "x = xa")
   apply (auto)
   apply (simp add: nres_add_same)
   apply (rule_tac empty_strong_disj_use_env2)
  apply (simp add: nres_add_diff)
  apply (erule_tac x="xa" in allE)
  apply (rule_tac comm_strong_disj_use_env)
  apply (rule_tac strong_disj_add_use_env)
  apply (rule_tac comm_strong_disj_use_env)
   apply (simp)
  apply (simp add: valid_nres_map_def)
  apply (simp add: sub_nres_map_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (simp add: sub_use_env_def)
  apply (simp add: fresh_var_def)
  apply (auto)
  done

    (*
      the hard part that we're dealing with right now is that at the end using pairs does NOT work for the WRITE constants,
        since we want "use" permission for the array, but "own" permission for the value being written.

      what this suggests is that we have to allow for constant + application to be a value.
      even if we do this, we need to give them all their own unique cases, just like for unpacking.
      - this is more complicated than it is with constants, since the contents of the first arg will generally be somewhat complex.

    *)

lemma saccmk2_var_type: "\<lbrakk> env (Loc x) = Some (ChanTy t c_end) \<rbrakk> \<Longrightarrow>
  well_typed env (one_use_env (Loc x) OwnPerm) (VarExp (LocType x x)) (ChanTy t c_end) (one_use_env (Loc x) OwnPerm) (one_use_env (Loc x) OwnPerm)"
  apply (auto)
   apply (rule_tac ereq_leq_use_envx)
   apply (simp add: one_use_env_def)
  apply (rule_tac x="empty_use_env" in exI)
  apply (auto)
     apply (rule_tac rhs_weak_leq_use_env)
      apply (rule_tac dist_weak_comp_use_env)
       apply (rule_tac weak_ereq_use_env)
       apply (simp add: unlim_def)
      apply (simp add: weak_use_env_def)
      apply (simp add: empty_use_env_def)
     apply (rule_tac id_leq_use_env)
     apply (rule_tac id_leq_use_env)
   apply (rule_tac leq_empty_use_env)
  apply (rule_tac diff_leq_use_env)
  apply (rule_tac ereq_leq_use_envx)
  apply (simp add: one_use_env_def)
  done

lemma saccmk2_pair_type: "\<lbrakk> well_typed env (one_use_env x1 OwnPerm) v1 t1 (one_use_env x1 OwnPerm) (one_use_env x1 OwnPerm);
  well_typed env (one_use_env x2 OwnPerm) v2 t2 (one_use_env x2 OwnPerm) (one_use_env x2 OwnPerm);
  r_s1 x1 = OwnPerm; r_s1 x2 = OwnPerm; r_s2 x1 = NoPerm; r_s2 x2 = NoPerm;
  leq_use_env r_s2 r_s1; leq_use_env rx r_s2; is_own r; x1 \<noteq> x2 \<rbrakk> \<Longrightarrow>
  well_typed env r_s1 (PairExp v1 v2) (PairTy t1 t2 r) r_s2 rx"
  apply (auto)
  apply (rule_tac x="r_s1" in exI)
  apply (rule_tac x="r_s1" in exI)
  apply (rule_tac x="one_use_env x1 OwnPerm" in exI)
  apply (auto)
   apply (rule_tac r_s="one_use_env x1 OwnPerm" in well_typed_incr_simul_perm)
    apply (simp add: leq_use_env_def)
    apply (simp add: one_use_env_def)
   apply (simp)
  apply (rule_tac x="one_use_env x2 OwnPerm" in exI)
  apply (auto)
       apply (rule_tac r_s="one_use_env x2 OwnPerm" in well_typed_incr_simul_perm)
        apply (simp add: leq_use_env_def)
        apply (simp add: one_use_env_def)
       apply (simp)
      apply (simp add: is_own_def)
      apply (simp add: leq_use_env_def)
      apply (simp add: one_use_env_def)
     apply (simp add: is_own_def)
     apply (simp add: leq_use_env_def)
     apply (simp add: one_use_env_def)
    apply (simp add: is_own_def)
    apply (case_tac "max_aff (req_type t1) (req_type t2)")
      apply (auto)
   apply (simp add: is_own_def)
   apply (simp add: one_use_env_def)
   apply (simp add: disj_use_env_def)
   apply (simp add: mini_disj_use_env_def)
  apply (rule_tac x="add_use_env (one_use_env x1 OwnPerm) x2 OwnPerm" in exI)
  apply (auto)
    apply (rule_tac mini_disj_diff_leq_use_env2)
     apply (simp)
    apply (simp add: mini_disj_use_env_def)
    apply (simp add: one_use_env_def)
    apply (simp add: add_use_env_def)
    apply (auto)
   apply (rule_tac add_leq_use_env)
    apply (simp add: leq_use_env_def)
    apply (simp add: one_use_env_def)
   apply (auto)
  apply (simp add: pair_req_def)
  apply (auto)
   apply (rule_tac leq_empty_use_env)
  apply (simp add: leq_use_env_def)
  apply (simp add: add_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: comp_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: is_own_def)
  done

lemma sacc_mk2_act_case: "
  \<lbrakk>well_typed_state s1 env rs_map; valid_exp_use_env s1 rs_map r_f; well_typed env r_s1 v t1 r_s2 rx2; proper_exp rs_map (AppExp (ConstExp c) v);
                leq_use_env r_s3 (diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex));
                leq_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_s2; leq_use_env r_ex r_s1; leq_use_env rx r_s3;
                leq_use_env (app_req rx1 rx2 r t2 r_ex) rx; leq_use_env r_s1 r_f; FunTy t1 t2 r a \<in> const_type c; c \<noteq> FixConst; ax = Mk2Act x31 x32;
                is_value v; app_con s1 c v (Mk2Act x31 x32) (s2, e2)\<rbrakk>
               \<Longrightarrow> \<exists>g_ax. well_typed (red_env env g_ax) (exp_red_use_env r_s1 g_ax) e2 t2 (end_red_use_env r_s3 g_ax) (end_red_use_env rx g_ax) \<and>
                          proper_exp (red_nres_map rs_map g_ax) e2 \<and>
                          well_typed_state s2 (red_env env g_ax) (red_nres_map rs_map g_ax) \<and>
                          valid_exp_use_env s2 (red_nres_map rs_map g_ax) (exp_red_use_env r_f g_ax) \<and>
                          safe_act s1 (infl_use_env r_f r_s3) g_ax \<and> corr_act (Mk2Act x31 x32) g_ax"
  apply (case_tac c)
              apply (auto)
  apply (cut_tac eq_own)
  apply (auto)
  apply (rule_tac x="Add2ResAct x31 x32 t" in exI)
  apply (auto)
       apply (cut_tac env="add_env (add_env env (Loc x31) (ChanTy t SEnd)) (Loc x32) (ChanTy t REnd)" and
        ?r_s1.0="add_use_env (add_use_env r_s1 (Loc x31) OwnPerm) (Loc x32) OwnPerm" and
        ?r_s2.0="r_s3" and ?v1.0="VarExp (LocType x31 x31)" and ?v2.0="VarExp (LocType x32 x32)" and ?t1.0="ChanTy t SEnd" and ?t2.0="ChanTy t REnd"
        and ?x1.0="Loc x31" and ?x2.0="Loc x32" in saccmk2_pair_type)
                 apply (rule_tac saccmk2_var_type)
                 apply (simp add: add_env_def)
                apply (rule_tac saccmk2_var_type)
                apply (simp add: add_env_def)
               apply (auto)
            apply (simp add: add_use_env_def)
           apply (simp add: add_use_env_def)
          apply (rule_tac r_s="r_f" in leq_use_none)
           apply (rule_tac r_sb="r_s1" in trans_leq_use_env)
            apply (simp)
           apply (rule_tac r_sb="diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
            apply (rule_tac diff_leq_use_env)
            apply (simp_all)
          apply (simp add: fresh_var_def)
          apply (simp add: valid_exp_use_env_def)
          apply (simp add: sub_use_env_def)
          apply (auto)
         apply (rule_tac r_s="r_f" in leq_use_none)
          apply (rule_tac r_sb="r_s1" in trans_leq_use_env)
           apply (simp)
          apply (rule_tac r_sb="diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
           apply (rule_tac diff_leq_use_env)
            apply (simp_all)
         apply (simp add: fresh_var_def)
         apply (simp add: valid_exp_use_env_def)
         apply (simp add: sub_use_env_def)
         apply (auto)
        apply (rule_tac rhs_add_leq_use_env)
         apply (rule_tac rhs_add_leq_use_env)
          apply (rule_tac r_sb="diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
           apply (rule_tac diff_leq_use_env)
           apply (simp_all)
       apply (rule_tac x="ChanTy t REnd" in exI)
       apply (rule_tac x="ra" in exI)
       apply (auto)
        apply (simp add: pure_fun_def)
        apply (simp add: is_own_def)
       apply (rule_tac x="r_s2a" in exI)
       apply (rule_tac x="r_s3a" in exI)
       apply (rule_tac x="rx1a" in exI)
       apply (auto)
       apply (rule_tac x="rx2a" in exI)
       apply (auto)
       apply (rule_tac x="r_exb" in exI)
       apply (auto)
       apply (simp add: pure_fun_def)
       apply (simp add: is_own_def)
    (* proving the state remains proper *)
      apply (simp add: proper_exp_def)
      apply (auto)
       apply (rule_tac x="[]" in exI)
       apply (simp)
      apply (rule_tac x="[]" in exI)
      apply (simp)
    (* proving the state remains well-typed: environment containment *)
     apply (simp add: well_typed_state_def)
     apply (auto)
       apply (rule_tac dist_add_sub_env)
       apply (rule_tac dist_add_sub_env)
       apply (simp)
    (* res_map validity: completeness *)
      apply (simp add: valid_nres_map_def)
      apply (auto)
        apply (rule_tac add_full_nres_map)
        apply (rule_tac add_full_nres_map)
        apply (simp)
    (* - disjointness *)
       apply (rule_tac disj_add_nres_map)
        apply (rule_tac disj_add_nres_map)
         apply (simp)
        apply (simp add: sep_nres_map_def)
        apply (simp add: empty_strong_disj_use_env1)
       apply (simp add: sep_nres_map_def)
       apply (simp add: empty_strong_disj_use_env1)
    (* - element containment *)
      apply (rule_tac dist_add_sub_nres_map)
       apply (rule_tac dist_add_sub_nres_map)
        apply (simp)
       apply (rule_tac empty_sub_use_env)
      apply (rule_tac empty_sub_use_env)
    (* proving that the memory is still well-typed. starting with x = x31 / x = x32 *)
     apply (case_tac "x = x31")
      apply (simp add: add_env_def)
     apply (case_tac "x = x32")
      apply (simp add: add_env_def)
    (* - otherwise compare with the originals *)
     apply (simp add: add_env_def)
     apply (erule_tac x="x" in allE)
     apply (case_tac "s1 x")
      apply (auto)
     apply (simp add: add_env_def)
     apply (case_tac "env (Loc x)")
      apply (auto)
     apply (rule_tac well_typed_mv_add_vars)
      apply (rule_tac well_typed_mv_add_vars)
       apply (simp add: nres_lookup_def)
       apply (simp add: add_env_def)
      apply (simp add: fresh_var_def)
       apply (simp add: sub_env_def)
       apply (auto)
     apply (simp add: fresh_var_def)
     apply (simp add: sub_env_def)
      apply (simp add: add_env_def)
      apply (auto)
    (* - properness *)
     apply (rule_tac proper_add_mv)
      apply (rule_tac proper_add_mv)
       apply (simp)
      apply (simp add: fresh_var_def)
      apply (simp add: valid_nres_map_def)
      apply (simp add: full_nres_map_def)
      apply (simp add: nres_lookup_def)
      apply (rule_tac leq_empty_use_env)
     apply (simp add: fresh_var_def)
     apply (simp add: valid_nres_map_def)
     apply (simp add: full_nres_map_def)
     apply (simp add: nres_lookup_def)
     apply (simp add: add_env_def)
     apply (rule_tac leq_empty_use_env)
    (* proving the new res_map is still valid: expression map containment *)
    apply (simp add: valid_exp_use_env_def)
    apply (auto)
     apply (rule_tac rhs_add_sub_use_env)
      apply (rule_tac rhs_add_sub_use_env)
       apply (rule_tac add_sub_use_env)
       apply (rule_tac add_sub_use_env)
       apply (simp)
      apply (simp add: add_env_def)
     apply (simp add: add_env_def)
    (* map separation *)
    apply (rule_tac add_sep_nres_map)
     apply (rule_tac add_sep_nres_map)
      apply (simp add: sep_nres_map_def)
      apply (auto)
      apply (simp add: well_typed_state_def)
      apply (simp add: valid_nres_map_def)
      apply (simp add: sub_nres_map_def)
      apply (rule_tac add_strong_disj_use_env)
       apply (rule_tac add_strong_disj_use_env)
        apply (auto)
       apply (case_tac "\<forall>xa. nres_lookup rs_map x xa \<noteq> NoPerm \<longrightarrow> (\<exists>y. xa = Loc y \<and> (\<exists>ya. s1 y = Some ya))")
        apply (erule_tac x="Loc x31" in allE)
        apply (simp add: fresh_var_def)
       apply (simp add: sub_use_env_def)
      apply (case_tac "\<forall>xa. nres_lookup rs_map x xa \<noteq> NoPerm \<longrightarrow> (\<exists>y. xa = Loc y \<and> (\<exists>ya. s1 y = Some ya))")
       apply (erule_tac x="Loc x32" in allE)
       apply (simp add: fresh_var_def)
      apply (simp add: sub_use_env_def)
     apply (rule_tac empty_strong_disj_use_env2)
    apply (rule_tac empty_strong_disj_use_env2)
   apply (simp add: fresh_var_def)
  apply (simp add: fresh_var_def)
  done

    (* the idea is that if we added a permission, we required it to be a variable not already in the env, ie a variable free in e2.
      so then we can remove x by default. *)
    (* in general, this statement says that given a constant-application, the result can be typed with a certain env + perm set,
      so that the state remains well-typed relative to the env + global perm_map, and the env + perm set remains valid *)
lemma safe_app_con_case: "\<lbrakk> well_typed_state s1 env rs_map;
    app_red_exp ConstApp (s1, AppExp (ConstExp c) v) ax (s2, e2); valid_exp_use_env s1 rs_map r_f;
    well_typed env r_s1 v t1 r_s2 rx2; proper_exp rs_map (AppExp (ConstExp c) v);
    leq_use_env r_s3 (diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex));
    leq_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_s2; leq_use_env r_ex r_s1; disj_use_env rx1 (lift_use_env rx2 r);
    leq_use_env rx r_s3; leq_use_env (app_req rx1 rx2 r t2 r_ex) rx; leq_use_env r_s1 r_f;
    FunTy t1 t2 r a \<in> const_type c; c \<noteq> FixConst\<rbrakk>
       \<Longrightarrow> \<exists>g_ax . well_typed (red_env env g_ax) (exp_red_use_env r_s1 g_ax) e2 t2 (end_red_use_env r_s3 g_ax) (end_red_use_env rx g_ax) \<and>
                  proper_exp (red_nres_map rs_map g_ax) e2 \<and> well_typed_state s2 (red_env env g_ax) (red_nres_map rs_map g_ax) \<and>
                  valid_exp_use_env s2 (red_nres_map rs_map g_ax) (exp_red_use_env r_f g_ax) \<and> safe_act s1 (infl_use_env r_f r_s3) g_ax \<and> corr_act ax g_ax"
  apply (case_tac ax)
     apply (auto)
    (* no action cases *)
     apply (cut_tac ?r_s2.0="r_s2" and ?r_s1.0="r_s1" and env="env" in well_typed_perm_leq)
      apply (auto)
     apply (case_tac c)
                 apply (auto)
     apply (rule_tac sares_unpack_case)
                apply (auto)
     apply (simp add: upc_init_abbrev_def)
     apply (rule_tac x="r_s1" in exI)
     apply (auto)
      apply (rule_tac id_leq_use_env)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
      apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
       apply (simp)
      apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
       apply (simp)
      apply (rule_tac self_comp_leq_use_env1)
     apply (rule_tac x="rx2" in exI)
     apply (rule_tac x="r_s2" in exI)
     apply (auto)
     apply (rule_tac x="r_s2a" in exI)
     apply (rule_tac x="r_s3a" in exI)
     apply (rule_tac x="rx1a" in exI)
     apply (auto)
    (* new resource cases. in all cases t2 should be the correct type to add *)
    apply (rule_tac x="AddResAct x2 t2 empty_use_env" in exI)
    apply (auto)
    (* - lemma for main well-typedness statement *)
        apply (rule_tac ?s2.0="s2" and ?rx1.0="rx1" in sacc_make_act_case)
                  apply (auto)
         apply (rule_tac r_sb="diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
          apply (rule_tac lhs_unroll_dcl_use_env)
          apply (rule_tac self_diff_leq_use_env)
         apply (simp)
    (* - proper expression *)
        apply (case_tac c)
                    apply (auto)
        apply (simp add: proper_exp_def)
        apply (rule_tac x="[]" in exI)
        apply (auto)
    (* - well typed state. *)
       apply (case_tac "\<not> (\<exists> v. s2 = add_env s1 x2 v)")
        apply (case_tac c)
                    apply (auto)
       apply (rule_tac well_typed_state_add_vars)
           apply (auto)
          apply (case_tac c)
                      apply (auto)
    (* - wt mem val: array case *)
         apply (case_tac c)
                     apply (auto)
         apply (cut_tac s="s1" and x="x2" and v="va" and w="ArrValue []" in add_env_force)
          apply (auto)
         apply (simp add: pure_fun_def)
    (* - valid res list *)
         apply (rule_tac x="\<lambda> x. None" in exI)
          apply (simp add: valid_res_list_def)
    (* - properness *)
         apply (case_tac c)
                     apply (auto)
         apply (cut_tac s="s1" and x="x2" and v="va" and w="ArrValue []" in add_env_force)
          apply (simp)
         apply (auto)
    (* - x22 is contained in rs_map (true because x22 is the empty set) *)
        apply (simp add: sub_use_env_def)
        apply (simp add: empty_use_env_def)
    (* - map separation + strength *)
       apply (simp add: sep_nres_map_def)
       apply (auto)
       apply (rule_tac empty_strong_disj_use_env1)
    (* - valid use env. *)
      apply (case_tac "\<not> (\<exists> v. s2 = add_env s1 x2 v)")
       apply (case_tac c)
                   apply (auto)
      apply (rule_tac add_valid_exp_use_env)
        apply (simp add: well_typed_state_def)
       apply (simp)
      apply (case_tac c)
                  apply (auto)
     apply (case_tac c)
                 apply (auto)
     apply (simp add: fresh_var_def)
    apply (rule_tac leq_empty_use_env)
    (* dual new resource case. (basically only channel creation) *)
   apply (rule_tac sacc_mk2_act_case)
                apply (auto)
    (* resource usage case. (currently empty) *)
  apply (case_tac c)
              apply (auto)
(*
   apply (case_tac c)
                apply (auto)
  apply (case_tac c)
               apply (auto)*)
  done

lemma well_typed_empty_state: "well_typed_state empty_env empty_env empty_env"
  apply (simp add: well_typed_state_def)
  apply (auto)
    apply (simp add: sub_env_def)
    apply (simp add: empty_env_def)
   apply (simp add: valid_nres_map_def)(*
   apply (simp add: disj_res_map_def)
   apply (auto)
     apply (simp add: lookup_res_def)
     apply (rule_tac empty_strong_disj_use_env1)*)
   apply (auto)
     apply (simp add: full_nres_map_def)
     apply (simp add: empty_env_def)
    apply (simp add: disj_nres_map_def)
    apply (auto)
    apply (simp add: nres_lookup_def)
    apply (simp add: empty_env_def)
    apply (rule_tac empty_strong_disj_use_env1)
   apply (simp add: sub_nres_map_def)
   apply (simp add: sub_use_env_def)
   apply (simp add: nres_lookup_def)
   apply (simp add: empty_env_def)
   apply (simp add: empty_use_env_def)
  apply (simp add: empty_env_def)
  done

fun state_vars where
  "state_vars s = { x | x. s x \<noteq> None }"

definition fv_restr_env where
  "fv_restr_env e s = (\<lambda> x. if x \<in> free_vars e then s x else None)"

lemma fv_restr_env_use: "\<lbrakk> x \<in> free_vars e \<rbrakk> \<Longrightarrow> fv_restr_env e s x = s x"
  apply (simp add: fv_restr_env_def)
  done

lemma dist_rem_contain_env: "\<lbrakk> contain_env s s' \<rbrakk> \<Longrightarrow> contain_env (rem_env s x) (rem_env s' x)"
  apply (simp add: contain_env_def)
  apply (simp add: rem_env_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (case_tac "s' xa")
   apply (auto)
  apply (simp add: rem_env_def)
  done

lemma fv_contain_env: "\<lbrakk> free_vars e' \<subseteq> free_vars e \<rbrakk> \<Longrightarrow> contain_env (fv_restr_env e s) (fv_restr_env e' s)"
  apply (simp add: contain_env_def)
  apply (simp add: fv_restr_env_def)
  apply (auto)
  apply (case_tac "s x")
   apply (auto)
  apply (simp add: fv_restr_env_def)
  apply (auto)
  done

lemma rem_fv_contain_env: "\<lbrakk> free_vars e' - {x} \<subseteq> free_vars e \<rbrakk> \<Longrightarrow> contain_env (fv_restr_env e (rem_env s x)) (fv_restr_env e' (rem_env s x))"
  apply (simp add: contain_env_def)
  apply (simp add: fv_restr_env_def)
  apply (auto)
  apply (simp add: rem_env_def)
  apply (auto)
  apply (case_tac "s xa")
   apply (auto)
  apply (simp add: fv_restr_env_def)
  apply (simp add: rem_env_def)
  apply (auto)
  done

lemma rem_fv_restr_env: "rem_env (fv_restr_env e s) x = fv_restr_env e (rem_env s x)"
  apply (case_tac "\<not> (\<forall> y. rem_env (fv_restr_env e s) x y = fv_restr_env e (rem_env s x) y)")
   apply (auto)
  apply (simp add: rem_env_def)
  apply (simp add: fv_restr_env_def)
  apply (case_tac "x = y")
   apply (auto)
   apply (case_tac "x \<in> free_vars e")
    apply (auto)
  apply (simp add: fv_restr_env_def)
  apply (case_tac "y \<in> free_vars e")
   apply (auto)
  done

    (* the question is, how do we allow for replicable pairs while enforcing full resource disjointness?
        i guess the "natural" way to do it based on what we already have is to simply allow pairs that contain
        values that are not unique to also be values.

        - if x is in the end perms, x is in the reqs. if r is own, (lift rx r) subtracts it out.
        - if r is not own, it means that e is replicable, in which case it is again not a var,
        - x is not in the end perms, which is trivial

        an even cleaner solution is to make a "replicable" pair value and type accordingly.
        in this case e is still a var, however at the level of reduction semantics, we can keep
        the var out of the name set.
     *)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "Additional Syntax for Word Bit Operations"

theory Word_Syntax
imports
  "~~/src/HOL/Word/WordBitwise"
  WordBitwise_Signed
  Hex_Words
  Norm_Words
begin

text \<open>Additional bit and type syntax that forces word types.\<close>

type_synonym word8 = "8 word"
type_synonym word16 = "16 word"
type_synonym word32 = "32 word"
type_synonym word64 = "64 word"

lemma len8: "len_of (x :: 8 itself) = 8" by simp
lemma len16: "len_of (x :: 16 itself) = 16" by simp
lemma len32: "len_of (x :: 32 itself) = 32" by simp
lemma len64: "len_of (x :: 64 itself) = 64" by simp

abbreviation
  wordNOT  :: "'a::len0 word \<Rightarrow> 'a word"      ("~~ _" [70] 71)
where
  "~~ x == NOT x"

abbreviation
  wordAND  :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "&&" 64)
where
  "a && b == a AND b"

abbreviation
  wordOR   :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "||"  59)
where
  "a || b == a OR b"

abbreviation
  wordXOR  :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "xor" 59)
where
  "a xor b == a XOR b"

(* testing for presence of word_bitwise *)
lemma "((x :: word32) >> 3) AND 7 = (x AND 56) >> 3"
  by word_bitwise

(* FIXME: move to Word distribution *)
lemma bin_nth_minus_Bit0[simp]:
  "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit0 w)) n = bin_nth (numeral w) (n - 1)"
  by (cases n; simp)

lemma bin_nth_minus_Bit1[simp]:
  "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit1 w)) n = bin_nth (numeral w) (n - 1)"
  by (cases n; simp)

end


section \<open>\isaheader{Generic Map To Set Converter}\<close>
theory Gen_Map2Set
imports
  "../Intf/Intf_Map"
  "../Intf/Intf_Set"
  "../Intf/Intf_Comp"
  "../../Iterator/Iterator"
begin

lemma map_fst_unit_distinct_eq[simp]:
  fixes l :: "('k\<times>unit) list"
  shows "distinct (map fst l) \<longleftrightarrow> distinct l"
  by (induct l) auto

definition
  map2set_rel :: "
    (('ki\<times>'k) set \<Rightarrow> (unit\<times>unit) set \<Rightarrow> ('mi\<times>('k\<rightharpoonup>unit))set) \<Rightarrow>
    ('ki\<times>'k) set \<Rightarrow>
    ('mi\<times>('k set)) set"
  where
  map2set_rel_def_internal:
  "map2set_rel R Rk \<equiv> \<langle>Rk,Id::(unit\<times>_) set\<rangle>R O {(m,dom m)| m. True}"

lemma map2set_rel_def: "\<langle>Rk\<rangle>(map2set_rel R)
  = \<langle>Rk,Id::(unit\<times>_) set\<rangle>R O {(m,dom m)| m. True}"
  unfolding map2set_rel_def_internal[abs_def] by (simp add: relAPP_def)

lemma map2set_relI:
  assumes "(s,m')\<in>\<langle>Rk,Id\<rangle>R" and "s'=dom m'"
  shows "(s,s')\<in>\<langle>Rk\<rangle>map2set_rel R"
  using assms unfolding map2set_rel_def by blast

lemma map2set_relE:
  assumes "(s,s')\<in>\<langle>Rk\<rangle>map2set_rel R"
  obtains m' where "(s,m')\<in>\<langle>Rk,Id\<rangle>R" and "s'=dom m'"
  using assms unfolding map2set_rel_def by blast

lemma map2set_rel_sv[relator_props]:
  "single_valued (\<langle>Rk,Id\<rangle>Rm) \<Longrightarrow> single_valued (\<langle>Rk\<rangle>map2set_rel Rm)"
  unfolding map2set_rel_def
  by (auto intro: single_valuedI dest: single_valuedD)

lemma map2set_empty[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP e op_map_empty (\<langle>Rk,Id\<rangle>R)"
  shows "(e,{})\<in>\<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def
  by auto

lemmas [autoref_rel_intf] =
  REL_INTFI[of "map2set_rel R" i_set] for R

definition "map2set_insert i k s \<equiv> i k () s"
lemma map2set_insert[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP i op_map_update (Rk \<rightarrow> Id \<rightarrow> \<langle>Rk,Id\<rangle>R \<rightarrow> \<langle>Rk,Id\<rangle>R)"
  shows
    "(map2set_insert i,Set.insert)\<in>Rk\<rightarrow>\<langle>Rk\<rangle>map2set_rel R \<rightarrow> \<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def map2set_insert_def[abs_def]
  by (force dest: fun_relD)

definition "map2set_memb l k s \<equiv> case l k s of None \<Rightarrow> False | Some _ \<Rightarrow> True"
lemma map2set_memb[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP l op_map_lookup (Rk \<rightarrow> \<langle>Rk,Id\<rangle>R \<rightarrow> \<langle>Id\<rangle>option_rel)"
  shows "(map2set_memb l ,(\<in>))
    \<in> Rk\<rightarrow>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>Id"
  using assms
  unfolding map2set_rel_def map2set_memb_def[abs_def]
  by (force dest: fun_relD split: option.splits)

lemma map2set_delete[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP d op_map_delete (Rk\<rightarrow>\<langle>Rk,Id\<rangle>R\<rightarrow>\<langle>Rk,Id\<rangle>R)"
  shows "(d,op_set_delete)\<in>Rk\<rightarrow>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>\<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def
  by (force dest: fun_relD)

lemma map2set_to_sorted_list[autoref_ga_rules]:
  fixes it :: "'m \<Rightarrow> ('k\<times>unit) list"
  assumes A: "GEN_ALGO_tag (is_map_to_sorted_list ordR Rk Id R it)"
  shows "is_set_to_sorted_list ordR Rk (map2set_rel R)
    (it_to_list (map_iterator_dom o (foldli o it)))"
proof -
  {
    fix l::"('k\<times>unit) list"
    have "\<And>l0. foldli l (\<lambda>_. True) (\<lambda>x \<sigma>. \<sigma> @ [fst x]) l0 = l0@map fst l"
      by (induct l) auto
  }
  hence S: "it_to_list (map_iterator_dom o (foldli o it)) = map fst o it"
    unfolding it_to_list_def[abs_def] map_iterator_dom_def[abs_def]
      set_iterator_image_def set_iterator_image_filter_def
    by (auto)
  show ?thesis
    unfolding S
    using assms
    unfolding is_map_to_sorted_list_def is_set_to_sorted_list_def
    apply clarsimp
    apply (erule map2set_relE)
    apply (drule spec, drule spec)
    apply (drule (1) mp)
    apply (elim exE conjE)
    apply (rule_tac x="map fst l'" in exI)
    apply (rule conjI)
    apply parametricity

    unfolding it_to_sorted_list_def
    apply (simp add: map_to_set_dom)
    apply (simp add: sorted_wrt_map key_rel_def[abs_def])
    done
qed

lemma map2set_to_list[autoref_ga_rules]:
  fixes it :: "'m \<Rightarrow> ('k\<times>unit) list"
  assumes A: "GEN_ALGO_tag (is_map_to_list Rk Id R it)"
  shows "is_set_to_list Rk (map2set_rel R)
    (it_to_list (map_iterator_dom o (foldli o it)))"
  using assms unfolding is_set_to_list_def is_map_to_list_def
  by (rule map2set_to_sorted_list)

(*lemma map2set_it_simp[iterator_simps]:
  "foldli ((map fst o it) x) c f s = foldli (it x) c (\<lambda>(k,v) s. f k s) s"
  by (simp add: foldli_map comp_def fn_fst_conv)
*)

text \<open>Transfering also non-basic operations results in specializations
  of map-algorithms to also be used for sets\<close>
lemma map2set_union[autoref_rules_raw]:
  assumes "MINOR_PRIO_TAG (- 9)"
  assumes "GEN_OP u (++) (\<langle>Rk,Id\<rangle>R\<rightarrow>\<langle>Rk,Id\<rangle>R\<rightarrow>\<langle>Rk,Id\<rangle>R)"
  shows "(u,(\<union>))\<in>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>\<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def
  by (force dest: fun_relD)

lemmas [autoref_ga_rules] = cmp_unit_eq_linorder
lemmas [autoref_rules_raw] = param_cmp_unit

lemma cmp_lex_zip_unit[simp]:
  "cmp_lex (cmp_prod cmp cmp_unit) (map (\<lambda>k. (k, ())) l)
           (map (\<lambda>k. (k, ())) m) =
          cmp_lex cmp l m"
  apply (induct cmp l m rule: cmp_lex.induct)
  apply (auto split: comp_res.split)
  done

lemma cmp_img_zip_unit[simp]:
  "cmp_img (\<lambda>m. map (\<lambda>k. (k,())) (f m)) (cmp_lex (cmp_prod cmp1 cmp_unit))
    = cmp_img f (cmp_lex cmp1)"
  unfolding cmp_img_def[abs_def]
  apply (intro ext)
  apply simp
  done

(* TODO: Move *)

lemma map2set_finite[relator_props]:
  assumes "finite_map_rel (\<langle>Rk,Id\<rangle>R)"
  shows "finite_set_rel (\<langle>Rk\<rangle>map2set_rel R)"
  using assms
  unfolding map2set_rel_def finite_set_rel_def finite_map_rel_def
  by auto

lemma map2set_cmp[autoref_rules_raw]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmpk)"
  assumes MPAR:
    "GEN_OP cmp (cmp_map cmpk cmp_unit) (\<langle>Rk,Id\<rangle>R \<rightarrow> \<langle>Rk,Id\<rangle>R \<rightarrow> Id)"
  assumes FIN: "PREFER finite_map_rel (\<langle>Rk, Id\<rangle>R)"
  shows "(cmp,cmp_set cmpk)\<in>\<langle>Rk\<rangle>map2set_rel R \<rightarrow> \<langle>Rk\<rangle>map2set_rel R \<rightarrow> Id"
proof -
  interpret linorder "comp2le cmpk" "comp2lt cmpk"
    using ELO by (simp add: eq_linorder_class_conv)

  show ?thesis
    using MPAR
    unfolding cmp_map_def cmp_set_def
    apply simp
    apply parametricity
    apply (drule cmp_extend_paramD)
    apply (insert FIN, fastforce simp add: finite_map_rel_def) []
    apply (simp add: sorted_list_of_map_def[abs_def])
    apply (auto simp: map2set_rel_def cmp_img_def[abs_def] dest: fun_relD) []

    apply (insert map2set_finite[OF FIN[unfolded autoref_tag_defs]],
      fastforce simp add: finite_set_rel_def)
    done
qed

end