(*
   Title: Psi-calculi
   Based on the AFP entry by 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 weak_stat_impMonotonic)
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 weak_stat_impMonotonic)

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 weak_stat_impReflexive)
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 `\<Psi> \<rhd> P \<approx> Q` 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 weak_stat_impMonotonic, auto)
        by(rule_tac x="[]::name prm" in exI) auto
      with `eqvt ?X` have "((p::name prm) \<bullet> \<Psi>) \<rhd> (p \<bullet> P) \<lessapprox><?X> (p \<bullet> Q)"
        by(rule weak_stat_impClosed)
    }
    with `(\<Psi>, P, Q) \<in> ?X` 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 `eqvt ?X` have "((p::name prm) \<bullet> \<Psi>) \<rhd> (p \<bullet> P) \<leadsto><?X> (p \<bullet> Q)"
        by(rule_tac weakSimClosed)
    }
    with `(\<Psi>, P, Q) \<in> ?X` 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 `(\<Psi>, P, Q) \<in> ?X` 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 `\<Psi> \<rhd> P \<approx> Q` `\<Psi> \<simeq> \<Psi>'` have "(\<Psi>', P, Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cStatImp \<Psi>' P Q)
    from `(\<Psi>', P, Q) \<in> ?X` obtain \<Psi> where "\<Psi> \<rhd> P \<approx> Q" and "\<Psi> \<simeq> \<Psi>'"
      by auto
    from `\<Psi> \<rhd> P \<approx> Q` have "\<Psi> \<rhd> P \<lessapprox><weakBisim> Q" by(rule weakBisimE)
    moreover note `\<Psi> \<simeq> \<Psi>'`
    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 weak_stat_impStatEq)
  next
    case(cSim \<Psi>' P Q)
    from `(\<Psi>', P, Q) \<in> ?X` obtain \<Psi> where "\<Psi> \<rhd> P \<approx> Q" and "\<Psi> \<simeq> \<Psi>'"
      by auto
    from `\<Psi> \<rhd> P \<approx> Q` have "\<Psi> \<rhd> P \<leadsto><weakBisim> Q" by(blast dest: weakBisimE)
    moreover have "eqvt ?X"
      by(auto simp add: eqvt_def) (metis weakBisimClosed Assertion_stat_eq_closed)
    hence "eqvt(?X \<union> weakBisim)" by auto
    moreover note `\<Psi> \<simeq> \<Psi>'`
    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 `(\<Psi>', P, Q) \<in> ?X` obtain \<Psi> where "\<Psi> \<rhd> P \<approx> Q" and "\<Psi> \<simeq> \<Psi>'"
      by auto
    from `\<Psi> \<rhd> P \<approx> Q` have "\<Psi> \<otimes> \<Psi>'' \<rhd> P \<approx> Q" by(rule weakBisimE)
    moreover from `\<Psi> \<simeq> \<Psi>'` have "\<Psi> \<otimes> \<Psi>'' \<simeq> \<Psi>' \<otimes> \<Psi>''" by(rule Composition)
    ultimately show ?case by blast
  next
    case(cSym \<Psi>' P Q)
    from `(\<Psi>', P, Q) \<in> ?X` obtain \<Psi> where "\<Psi> \<rhd> P \<approx> Q" and "\<Psi> \<simeq> \<Psi>'"
      by auto
    from `\<Psi> \<rhd> P \<approx> Q` have "\<Psi> \<rhd> Q \<approx> P" by(rule weakBisimE)
    thus ?case using `\<Psi> \<simeq> \<Psi>'` 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 `(\<Psi>, P, R) \<in> ?X` obtain Q where "\<Psi> \<rhd> P \<approx> Q" and  "\<Psi> \<rhd> Q \<approx> R" by blast
    from `\<Psi> \<rhd> P \<approx> Q` have "\<Psi> \<rhd> P \<lessapprox><weakBisim> Q" by(rule weakBisimE)
    moreover note `\<Psi> \<rhd> Q \<approx> R`
    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 weak_stat_impTransitive)
  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 `(\<Psi>, P, R) \<in> ?X` 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 `\<Psi> \<rhd> P \<sim> Q`
  show ?thesis
  proof(coinduct rule: weakBisimWeakCoinduct)
    case(cStatImp \<Psi> P Q)
    from `\<Psi> \<rhd> P \<sim> Q` have "insert_assertion(extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion(extract_frame Q) \<Psi>"
      by(metis bisimE Frame_stat_eq_def)
    moreover from `\<Psi> \<rhd> P \<sim> Q` 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 `\<Psi> \<rhd> P \<sim> Q`
    moreover have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> insert_assertion(extract_frame Q) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion(extract_frame P) \<Psi>"
      by(drule_tac bisimE) (simp add: Frame_stat_eq_def)
    ultimately show ?case using bisimE(2) bisimE(3)
      by(rule strongSimWeakSim)
  next
    case(cExt \<Psi> P Q \<Psi>')
    from `\<Psi> \<rhd> P \<sim> Q` show ?case
      by(rule bisimE)
  next
    case(cSym \<Psi> P Q)
    from `\<Psi> \<rhd> P \<sim> Q` 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 struct_cong_bisim 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 `\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'` `(\<Psi>, P, Q) \<in> Rel` A show ?thesis
  proof(induct arbitrary: P thesis rule: tau_chain_induct)
    case(tau_base Q P)
    moreover have "\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P" by simp
    ultimately show ?case by blast
  next
    case(tau_step Q Q' Q'' P)
    from `(\<Psi>, P, Q) \<in> Rel` obtain P' where PChain: "\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'" and "(\<Psi>, P', Q') \<in> Rel"
      by(rule tau_step)
    from `(\<Psi>, P', Q') \<in> Rel` have "\<Psi> \<rhd> P' \<leadsto>[Rel] Q'" by(rule Sim)
    then obtain P'' where P'Chain: "\<Psi> \<rhd> P' \<longmapsto>None @ \<tau> \<prec> P''" and "(\<Psi>, P'', Q'') \<in> Rel"
      using `\<Psi> \<rhd> Q' \<longmapsto>None @ \<tau> \<prec> Q''` by(drule_tac simE) (auto dest: tau_no_provenance)
    from PChain P'Chain have "\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P''" by(auto dest: tau_act_tau_chain)
    thus ?case using `(\<Psi>, P'', Q'') \<in> Rel` by(rule tau_step)
  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 `quiet P` have "(\<Psi>, P, \<zero>) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimWeakCoinduct)
    case(cStatImp \<Psi> P Q)
    thus ?case
      apply(simp add: weak_stat_imp_def)
      apply(rule allI)
      apply(rule_tac x=Q in exI)
      apply auto
      apply(drule_tac \<Psi>=\<Psi> in quiet_frame)
      apply(rule_tac G="\<langle>\<epsilon>, \<Psi>\<rangle>" in Frame_stat_imp_trans)
      using Identity
      apply(simp add: Assertion_stat_eq_def)
      apply(simp add: Frame_stat_eq_def)
      apply(drule_tac \<Psi>=\<Psi> in quiet_frame)
      apply(rule_tac G="\<langle>\<epsilon>, \<Psi>\<rangle>" in Frame_stat_imp_trans)
      apply auto
      defer
      using Identity
      apply(simp add: Assertion_stat_eq_def)
      apply(simp add: Frame_stat_eq_def)
      done
  next
    case(cSim \<Psi> P Q)
    moreover have "eqvt ?X" by(auto simp add: eqvt_def intro: quiet_eqvt)
    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: bisim_reflexive)
  thus ?thesis
  proof(coinduct rule: weakBisimWeakCoinduct)
    case(cStatImp \<Psi> P Q)
    {
      fix \<Psi>'
      from `(\<Psi> , P, Q) \<in> ?X` obtain P' Q' where "\<Psi> \<rhd> P \<sim> P'" and "(\<Psi>, P', Q') \<in> X" and "\<Psi> \<rhd> Q' \<sim> Q" by auto
      from `(\<Psi>, P', Q') \<in> X` obtain Q'' Q''' where Q'Chain: "\<Psi> \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''"
                                               and PImpQ: "insert_assertion (extract_frame P') \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame 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: weak_stat_imp_def) blast
      from `\<Psi> \<rhd> Q' \<sim> Q` 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  `\<Psi> \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''` bisimE(2)
        by(rule simTauChain)
      note `\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''''`
      moreover have "insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame Q'''') \<Psi>"
      proof -
        from `\<Psi> \<rhd> P \<sim> P'` have "insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame P') \<Psi>"
          by(drule_tac bisimE) (simp add: Frame_stat_eq_def)
        moreover from `\<Psi> \<rhd> Q'''' \<sim> Q''` have "insert_assertion (extract_frame Q'') \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame Q'''') \<Psi>"
          by(drule_tac bisimE) (simp add: Frame_stat_eq_def)
        ultimately show ?thesis using PImpQ by(blast intro: Frame_stat_imp_trans)
      qed
      moreover from `\<Psi> \<rhd> Q'''' \<sim> Q''` 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 `\<Psi> \<rhd> P \<sim> P'` `(\<Psi> \<otimes> \<Psi>' , P', Q''') \<in> X` `\<Psi> \<otimes> \<Psi>' \<rhd> Q''''' \<sim> Q'''` 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> insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame Q'') \<Psi> \<and> \<Psi> \<otimes> \<Psi>' \<rhd> Q'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q' \<and> (\<Psi> \<otimes> \<Psi>', P, Q') \<in> ?X" by blast
    }
    with `(\<Psi>, P, Q) \<in> ?X` show ?case by(simp add: weak_stat_imp_def) blast
  next
    case(cSim \<Psi> P Q)
    from `(\<Psi>, P, Q) \<in> ?X` obtain P' Q' where "\<Psi> \<rhd> P \<sim> P'" and "(\<Psi>, P', Q') \<in> X" and "\<Psi> \<rhd> Q' \<sim> Q" by auto
    from `(\<Psi>, P', Q') \<in> X` have "\<Psi> \<rhd> P' \<leadsto><?X> Q'"
      by(rule rSim)
    moreover from `\<Psi> \<rhd> Q' \<sim> Q` have "\<Psi> \<rhd> Q' \<leadsto>[bisim] Q" by(rule bisimE)
    moreover from `eqvt X` have "eqvt ?X"
      apply(auto simp add: eqvt_def)
      apply(drule_tac p=p in bisim_closed)
      apply(drule_tac p=p in bisim_closed)
      apply(rule_tac x="p \<bullet> P'" in exI, simp)
      by(rule_tac x="p \<bullet> Q'" in exI, auto)
    moreover from `\<Psi> \<rhd> Q' \<sim> Q` have "insert_assertion (extract_frame Q) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame Q') \<Psi>"
      by(drule_tac bisimE) (simp add: Frame_stat_eq_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: bisim_transitive)
    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: bisim_transitive)
    moreover {
      fix \<Psi> P Q

      assume "\<Psi> \<rhd> P \<sim> Q"
      moreover have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> insert_assertion (extract_frame Q) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame P) \<Psi>"
        by(drule_tac bisimE) (simp add: Frame_stat_eq_def)
      ultimately have "\<Psi> \<rhd> P \<leadsto><bisim> Q" using bisimE(2) bisimE(3)
        by(rule strongSimWeakSim)
    }
    ultimately show ?case using `\<Psi> \<rhd> P \<sim> P'` `eqvt ?X`
      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 `eqvt X` 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) weak_stat_impMonotonic)
  next
    case(cSim \<Psi> P Q)
    thus ?case by(fastforce intro: rSim weakBisimE(2) weakSimMonotonic bisim_reflexive)
  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 `eqvt X` have "eqvt ?X"
    apply(auto simp add: eqvt_def)
    apply(drule_tac p=p in bisim_closed)
    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 `eqvt X` 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 `\<Psi> \<rhd> P \<approx> P'`
    moreover from `(\<Psi>, P', Q') \<in> X` have "\<Psi> \<rhd> P' \<leadsto><?X> Q'" by(rule rSim)
    moreover note `eqvt ?X`
    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 `\<Psi> \<rhd> Q' \<sim> Q` have "\<Psi> \<rhd> Q' \<leadsto>[bisim] Q" by(rule bisimE)
    moreover note `eqvt ?X`
    moreover from `\<Psi> \<rhd> Q' \<sim> Q` have "insert_assertion (extract_frame Q) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame Q') \<Psi>"
      by(drule_tac bisimE) (simp add: Frame_stat_eq_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: bisim_transitive)
    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 bisim_reflexive rSym)
  thus ?thesis
  proof(coinduct rule: weakBisimWeakCoinduct)
  next
    case(cStatImp \<Psi> P Q)
    {
      fix \<Psi>'

      from `(\<Psi>, P, Q) \<in> ?Y` obtain R S where "\<Psi> \<rhd> P \<approx> R" and "(\<Psi>, R, S) \<in> X" and "\<Psi> \<rhd> S \<approx> Q" by auto
      from `\<Psi> \<rhd> P \<approx> R` obtain R'' R'
        where RChain: "\<Psi> \<rhd> R \<Longrightarrow>\<^sup>^\<^sub>\<tau> R''"
          and PImpR'': "insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame 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: weak_stat_imp_def) blast

      from `(\<Psi>, R, S) \<in> X` have "(\<Psi>, S, R) \<in> ?X" by(blast intro: weakBisimReflexive bisim_reflexive 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 `(\<Psi>, S'', R'') \<in> ?X` obtain T U where "\<Psi> \<rhd> S'' \<approx> T" and "(\<Psi>, T, U) \<in> X" and "\<Psi> \<rhd> U \<sim> R''"
        by auto
      from `\<Psi> \<rhd> U \<sim> R''` have R''ImpU: "insert_assertion (extract_frame R'') \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame U) \<Psi>"
        by(drule_tac bisimE) (simp add: Frame_stat_eq_def)

      from `(\<Psi>, T, U) \<in> X` weak_stat_imp_def
      obtain T'' T' where TChain: "\<Psi> \<rhd> T \<Longrightarrow>\<^sup>^\<^sub>\<tau> T''"
                      and UImpT'': "insert_assertion (extract_frame U) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame 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 `\<Psi> \<rhd> S'' \<approx> T` 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 `\<Psi> \<rhd> S''' \<approx> T''` weak_stat_imp_def
      obtain S''''' S'''' where S'''Chain: "\<Psi> \<rhd> S''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> S'''''"
                            and T''ImpS''''': "insert_assertion (extract_frame T'') \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame 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 `\<Psi> \<rhd> S \<approx> Q` 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 `\<Psi> \<rhd> Q''' \<approx> S'''''` 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'': "insert_assertion (extract_frame S''''') \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame Q'') \<Psi>"
                           and Q''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> Q'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'"
                           and "\<Psi> \<otimes> \<Psi>' \<rhd> S''''' \<approx> Q'" using weak_stat_imp_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 "insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame Q'') \<Psi>"
        by(blast dest: Frame_stat_imp_trans)

      moreover from `\<Psi> \<rhd> U \<sim> R''` 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 `\<Psi> \<otimes> \<Psi>' \<rhd> U' \<approx> R'` have "\<Psi> \<otimes> \<Psi>' \<rhd> R' \<approx> U'" by(rule weakBisimE)
      from `(\<Psi> \<otimes> \<Psi>', U, T') \<in> X` have "(\<Psi> \<otimes> \<Psi>', T', U) \<in> ?X" by(blast intro: rSym weakBisimReflexive bisim_reflexive)
      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 `(\<Psi> \<otimes> \<Psi>', T''', U') \<in> ?X` 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  `\<Psi> \<otimes> \<Psi>' \<rhd> T'' \<approx> S''''` 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 `\<Psi> \<otimes> \<Psi>' \<rhd> S''''' \<approx> Q'`
      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 `\<Psi> \<otimes> \<Psi>' \<rhd> P \<approx> R'` `\<Psi> \<otimes> \<Psi>' \<rhd> R' \<approx> U'` `(\<Psi> \<otimes> \<Psi>', U', T''') \<in> ?Y` `\<Psi> \<otimes> \<Psi>' \<rhd> T''' \<approx> S''''''`
                    `\<Psi> \<otimes> \<Psi>' \<rhd> S'''''' \<approx> Q''''`
      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> insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame 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: weak_stat_imp_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 `(\<Psi>, P', Q') \<in> X` have "(\<Psi>, P', Q') \<in> ?X"
        by(blast intro: weakBisimReflexive bisim_reflexive)
      moreover from `\<Psi> \<rhd> Q' \<approx> Q` have "\<Psi> \<rhd> Q' \<leadsto><weakBisim> Q" by(rule weakBisimE)
      moreover note `eqvt ?Y`
      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 `\<Psi> \<rhd> P \<approx> P'` this `eqvt ?Y`
      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


section \<open>\isaheader{Iterators}\<close>
theory Gen_Iterator
imports "../../Refine_Monadic/Refine_Monadic" Proper_Iterator
begin
  text \<open>
    Iterators are realized by to-list functions followed by folding.
    A post-optimization step then replaces these constructions by
    real iterators.\<close>

  lemma param_it_to_list[param]: "(it_to_list,it_to_list) \<in>
    (Rs \<rightarrow> (Ra \<rightarrow> bool_rel) \<rightarrow>
    (Rb \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> \<langle>Rb\<rangle>list_rel) \<rightarrow> \<langle>Rc\<rangle>list_rel \<rightarrow> Rd) \<rightarrow> Rs \<rightarrow> Rd"
    unfolding it_to_list_def[abs_def]
    by parametricity

  definition key_rel :: "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> ('k\<times>'v) \<Rightarrow> ('k\<times>'v) \<Rightarrow> bool"
    where "key_rel R a b \<equiv> R (fst a) (fst b)"

  lemma key_rel_UNIV[simp]: "key_rel (\<lambda>_ _. True) = (\<lambda>_ _. True)"
    unfolding key_rel_def[abs_def] by auto

  subsection \<open>Setup for Autoref\<close>
  text \<open>Default pattern rules for \<open>it_to_sorted_list\<close>\<close>
  definition "set_to_sorted_list R S \<equiv> it_to_sorted_list R S"

context begin interpretation autoref_syn .
  lemma set_to_sorted_list_pat[autoref_op_pat]:
    "it_to_sorted_list R S \<equiv> OP (set_to_sorted_list R) S"
    unfolding set_to_sorted_list_def[abs_def] by auto
end

  definition "map_to_sorted_list R M
    \<equiv> it_to_sorted_list (key_rel R) (map_to_set M)"
  lemma map_to_sorted_list_itype[autoref_itype]:
    "map_to_sorted_list R ::\<^sub>i \<langle>Rk,Rv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>Rk,Rv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_list\<rangle>\<^sub>ii_nres"
    by simp

context begin interpretation autoref_syn .
  lemma map_to_sorted_list_pat[autoref_op_pat]:
    "it_to_sorted_list (key_rel R) (map_to_set M)
      \<equiv> OP (map_to_sorted_list R) M"
    "it_to_sorted_list (\<lambda>_ _. True) (map_to_set M)
      \<equiv> OP (map_to_sorted_list (\<lambda>_ _. True)) M"
    unfolding map_to_sorted_list_def[abs_def] by auto
end

  subsection \<open>Set iterators\<close>
  (*definition "is_set_to_sorted_list_deprecated ordR Rk Rs tsl \<equiv> \<forall>s s'.
    (s,s')\<in>\<langle>Rk\<rangle>Rs \<longrightarrow>
      (RETURN (tsl s),it_to_sorted_list ordR s')\<in>\<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
    *)

  definition "is_set_to_sorted_list ordR Rk Rs tsl \<equiv> \<forall>s s'.
    (s,s')\<in>\<langle>Rk\<rangle>Rs
      \<longrightarrow> ( \<exists>l'. (tsl s,l')\<in>\<langle>Rk\<rangle>list_rel
            \<and> RETURN l' \<le> it_to_sorted_list ordR s')"

  definition "is_set_to_list \<equiv> is_set_to_sorted_list (\<lambda>_ _. True)"

  lemma is_set_to_sorted_listE:
    assumes "is_set_to_sorted_list ordR Rk Rs tsl"
    assumes "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    obtains l' where "(tsl s,l')\<in>\<langle>Rk\<rangle>list_rel"
    and "RETURN l' \<le> it_to_sorted_list ordR s'"
    using assms unfolding is_set_to_sorted_list_def by blast

  (* TODO: Move *)
  lemma it_to_sorted_list_weaken:
    "R\<le>R' \<Longrightarrow> it_to_sorted_list R s \<le> it_to_sorted_list R' s"
    unfolding it_to_sorted_list_def
    by (auto intro!: sorted_wrt_mono_rel[where P=R])

  lemma set_to_list_by_set_to_sorted_list[autoref_ga_rules]:
    assumes "GEN_ALGO_tag (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "is_set_to_list Rk Rs tsl"
    using assms
    unfolding is_set_to_list_def is_set_to_sorted_list_def autoref_tag_defs
    apply (safe)
    apply (drule spec, drule spec, drule (1) mp)
    apply (elim exE conjE)
    apply (rule exI, rule conjI, assumption)
    apply (rule order_trans, assumption)
    apply (rule it_to_sorted_list_weaken)
    by blast

  definition "det_fold_set R c f \<sigma> result \<equiv>
    \<forall>l. distinct l \<and> sorted_wrt R l \<longrightarrow> foldli l c f \<sigma> = result (set l)"

  lemma det_fold_setI[intro?]:
    assumes "\<And>l. \<lbrakk>distinct l; sorted_wrt R l\<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (set l)"
    shows "det_fold_set R c f \<sigma> result"
    using assms unfolding det_fold_set_def by auto

  text \<open>Template lemma for generic algorithm using set iterator\<close>
  lemma det_fold_sorted_set:
    assumes 1: "det_fold_set ordR c' f' \<sigma>' result"
    assumes 2: "is_set_to_sorted_list ordR Rk Rs tsl"
    assumes SREF[param]: "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    assumes [param]:  "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes [param]: "(f,f')\<in>Rk \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes [param]: "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl s) c f \<sigma>, result s') \<in> R\<sigma>"
  proof -
    obtain tsl' where
      [param]: "(tsl s,tsl') \<in> \<langle>Rk\<rangle>list_rel"
      and IT: "RETURN tsl' \<le> it_to_sorted_list ordR s'"
      using 2 SREF
      by (rule is_set_to_sorted_listE)

    have "(foldli (tsl s) c f \<sigma>, foldli tsl' c' f' \<sigma>') \<in> R\<sigma>"
      by parametricity
    also have "foldli tsl' c' f' \<sigma>' = result s'"
      using 1 IT
      unfolding det_fold_set_def it_to_sorted_list_def
      by simp
    finally show ?thesis .
  qed

  lemma det_fold_set:
    assumes "det_fold_set (\<lambda>_ _. True) c' f' \<sigma>' result"
    assumes "is_set_to_list Rk Rs tsl"
    assumes "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    assumes "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes "(f,f')\<in>Rk \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl s) c f \<sigma>, result s') \<in> R\<sigma>"
    using assms
    unfolding  is_set_to_list_def
    by (rule det_fold_sorted_set)

  subsection \<open>Map iterators\<close>

  text \<open>Build relation on keys\<close>

  (*definition "is_map_to_sorted_list_deprecated ordR Rk Rv Rm tsl \<equiv> \<forall>m m'.
    (m,m')\<in>\<langle>Rk,Rv\<rangle>Rm \<longrightarrow>
      (RETURN (tsl m),it_to_sorted_list (key_rel ordR) (map_to_set m'))
      \<in>\<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"*)

  definition "is_map_to_sorted_list ordR Rk Rv Rm tsl \<equiv> \<forall>m m'.
    (m,m')\<in>\<langle>Rk,Rv\<rangle>Rm \<longrightarrow> (
      \<exists>l'. (tsl m,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel
        \<and> RETURN l' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m'))"

  definition "is_map_to_list Rk Rv Rm tsl
    \<equiv> is_map_to_sorted_list (\<lambda>_ _. True) Rk Rv Rm tsl"

  lemma is_map_to_sorted_listE:
    assumes "is_map_to_sorted_list ordR Rk Rv Rm tsl"
    assumes "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    obtains l' where "(tsl m,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
    and "RETURN l' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m')"
    using assms unfolding is_map_to_sorted_list_def by blast

  lemma map_to_list_by_map_to_sorted_list[autoref_ga_rules]:
    assumes "GEN_ALGO_tag (is_map_to_sorted_list ordR Rk Rv Rm tsl)"
    shows "is_map_to_list Rk Rv Rm tsl"
    using assms
    unfolding is_map_to_list_def is_map_to_sorted_list_def autoref_tag_defs
    apply (safe)
    apply (drule spec, drule spec, drule (1) mp)
    apply (elim exE conjE)
    apply (rule exI, rule conjI, assumption)
    apply (rule order_trans, assumption)
    apply (rule it_to_sorted_list_weaken)
    unfolding key_rel_def[abs_def]
    by blast

  definition "det_fold_map R c f \<sigma> result \<equiv>
    \<forall>l. distinct (map fst l) \<and> sorted_wrt (key_rel R) l
      \<longrightarrow> foldli l c f \<sigma> = result (map_of l)"

  lemma det_fold_mapI[intro?]:
    assumes "\<And>l. \<lbrakk>distinct (map fst l); sorted_wrt (key_rel R) l\<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (map_of l)"
    shows "det_fold_map R c f \<sigma> result"
    using assms unfolding det_fold_map_def by auto

  lemma det_fold_map_aux:
    assumes 1: "\<lbrakk>distinct (map fst l); sorted_wrt (key_rel R) l \<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (map_of l)"
    assumes 2: "RETURN l \<le> it_to_sorted_list (key_rel R) (map_to_set m)"
    shows "foldli l c f \<sigma> = result m"
  proof -
    from 2 have "distinct l" and "set l = map_to_set m"
      and SORTED: "sorted_wrt (key_rel R) l"
      unfolding it_to_sorted_list_def by simp_all
    hence "\<forall>(k,v)\<in>set l. \<forall>(k',v')\<in>set l. k=k' \<longrightarrow> v=v'"
      apply simp
      unfolding map_to_set_def
      apply auto
      done
    with \<open>distinct l\<close> have DF: "distinct (map fst l)"
      apply (induct l)
      apply simp
      apply force
      done
    with \<open>set l = map_to_set m\<close> have [simp]: "m = map_of l"
      by (metis map_of_map_to_set)

    from 1[OF DF SORTED] show ?thesis by simp
  qed

  text \<open>Template lemma for generic algorithm using map iterator\<close>
  lemma det_fold_sorted_map:
    assumes 1: "det_fold_map ordR c' f' \<sigma>' result"
    assumes 2: "is_map_to_sorted_list ordR Rk Rv Rm tsl"
    assumes MREF[param]: "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    assumes [param]:  "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes [param]: "(f,f')\<in>\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes [param]: "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl m) c f \<sigma>, result m') \<in> R\<sigma>"
  proof -
    obtain tsl' where
      [param]: "(tsl m,tsl') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
      and IT: "RETURN tsl' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m')"
      using 2 MREF by (rule is_map_to_sorted_listE)

    have "(foldli (tsl m) c f \<sigma>, foldli tsl' c' f' \<sigma>') \<in> R\<sigma>"
      by parametricity
    also have "foldli tsl' c' f' \<sigma>' = result m'"
      using det_fold_map_aux[of tsl' ordR c' f' \<sigma>' result] 1 IT
      unfolding det_fold_map_def
      by clarsimp
    finally show ?thesis .
  qed

  lemma det_fold_map:
    assumes "det_fold_map (\<lambda>_ _. True) c' f' \<sigma>' result"
    assumes "is_map_to_list Rk Rv Rm tsl"
    assumes "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    assumes "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes "(f,f')\<in>\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl m) c f \<sigma>, result m') \<in> R\<sigma>"
    using assms
    unfolding is_map_to_list_def
    by (rule det_fold_sorted_map)

lemma set_to_sorted_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 11)"
  assumes TSL: "SIDE_GEN_ALGO (is_set_to_sorted_list R Rk Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), set_to_sorted_list R)
    \<in> \<langle>Rk\<rangle>Rs \<rightarrow> \<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
proof (intro fun_relI nres_relI)
  fix s s'
  assume "(s,s')\<in>\<langle>Rk\<rangle>Rs"
  with TSL obtain l' where
    R1: "(tsl s, l') \<in> \<langle>Rk\<rangle>list_rel"
      and R2: "RETURN l' \<le> set_to_sorted_list R s'"
    unfolding is_set_to_sorted_list_def set_to_sorted_list_def autoref_tag_defs
    by blast

  have "RETURN (tsl s) \<le> \<Down>(\<langle>Rk\<rangle>list_rel) (RETURN l')"
    by (rule RETURN_refine) fact
  also note R2
  finally show "RETURN (tsl s) \<le> \<Down> (\<langle>Rk\<rangle>list_rel) (set_to_sorted_list R s')" .
qed

lemma map_to_sorted_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 11)"
  assumes TSL: "SIDE_GEN_ALGO (is_map_to_sorted_list R Rk Rv Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), map_to_sorted_list R)
    \<in> \<langle>Rk,Rv\<rangle>Rs \<rightarrow> \<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"
proof (intro fun_relI nres_relI)
  fix s s'
  assume "(s,s')\<in>\<langle>Rk,Rv\<rangle>Rs"
  with TSL obtain l' where
    R1: "(tsl s, l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
      and R2: "RETURN l' \<le> map_to_sorted_list R s'"
    unfolding is_map_to_sorted_list_def map_to_sorted_list_def autoref_tag_defs
    by blast

  have "RETURN (tsl s) \<le> \<Down>(\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel) (RETURN l')"
    apply (rule RETURN_refine)
    by fact
  also note R2
  finally show
    "RETURN (tsl s) \<le> \<Down> (\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel) (map_to_sorted_list R s')" .
qed

lemma map_to_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 10)"
  assumes TSL: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), map_to_sorted_list (\<lambda>_ _. True))
    \<in> \<langle>Rk,Rv\<rangle>Rs \<rightarrow> \<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"
  using assms(2-) unfolding is_map_to_list_def
  by (rule map_to_sorted_list_by_tsl[OF PRIO_TAGI])

(*lemma dres_it_FOREACH_it_simp[iterator_simps]:
  "dres_it_FOREACH (\<lambda>s. dRETURN (i s)) s c f \<sigma>
    = foldli (i s) (case_dres False False c) (\<lambda>x s. s \<bind> f x) (dRETURN \<sigma>)"
  unfolding dres_it_FOREACH_def
  by simp
*)

text \<open>
  TODO/FIXME:
    * Integrate mono-prover properly into solver-infrastructure,
        i.e. tag a mono-goal.
    * Tag iterators, such that, for the mono-prover, we can just convert
        a proper iterator back to its foldli-equivalent!
\<close>
lemma proper_it_mono_dres_pair:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>k v x. f k v x \<le> f' k v x"
  shows "
    it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>
    \<le> it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>" (is "?a \<le> ?b")
proof -
  from proper_itE[OF PR[THEN proper_it'D]] obtain l where
    A_FMT:
      "?a = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>"
        (is "_ = ?a'")
    and B_FMT:
      "?b = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>"
        (is "_ = ?b'")
    by metis

  from A have A': "\<And>kv x. case_prod f kv x \<le> case_prod f' kv x"
    by auto

  note A_FMT
  also have
    "?a' = foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f kv) \<sigma>"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note foldli_mono_dres[OF A']
  also have
    "foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f' kv) \<sigma> = ?b'"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note B_FMT[symmetric]
  finally show ?thesis .
qed

lemma proper_it_mono_dres_pair_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>k v x. flat_ge (f k v x) (f' k v x)"
  shows "
    flat_ge (it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>)
      (it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>)"
      (is "flat_ge ?a ?b")
proof -
  from proper_itE[OF PR[THEN proper_it'D]] obtain l where
    A_FMT:
      "?a = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>"
        (is "_ = ?a'")
    and B_FMT:
      "?b = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>"
        (is "_ = ?b'")
    by metis

  from A have A': "\<And>kv x. flat_ge (case_prod f kv x) (case_prod f' kv x)"
    by auto

  note A_FMT
  also have
    "?a' = foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f kv) \<sigma>"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note foldli_mono_dres_flat[OF A']
  also have
    "foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f' kv) \<sigma> = ?b'"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note B_FMT[symmetric]
  finally show ?thesis .
qed

lemma proper_it_mono_dres:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. f kv x \<le> f' kv x"
  shows "
    it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>
    \<le> it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>"
  apply (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
  apply (erule_tac t="it' s" in ssubst)
  apply (rule foldli_mono_dres[OF A])
  done

lemma proper_it_mono_dres_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. flat_ge (f kv x) (f' kv x)"
  shows "
    flat_ge (it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>)
      (it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>)"
  apply (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
  apply (erule_tac t="it' s" in ssubst)
  apply (rule foldli_mono_dres_flat[OF A])
  done

lemma pi'_dom[icf_proper_iteratorI]: "proper_it' it it'
  \<Longrightarrow> proper_it' (map_iterator_dom o it) (map_iterator_dom o it')"
  apply (rule proper_it'I)
  apply (simp add: comp_def)
  apply (rule icf_proper_iteratorI)
  apply (erule proper_it'D)
  done

lemma proper_it_mono_dres_dom:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. f kv x \<le> f' kv x"
  shows "
    (map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>
    \<le>
    (map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>"

  apply (rule proper_it_mono_dres)
  apply (rule icf_proper_iteratorI)
  by fact+

lemma proper_it_mono_dres_dom_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. flat_ge (f kv x) (f' kv x)"
  shows "flat_ge
    ((map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>)
    ((map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>)"
  apply (rule proper_it_mono_dres_flat)
  apply (rule icf_proper_iteratorI)
  by fact+

(* TODO/FIXME: Hack! Mono-prover should be able to find proper-iterators itself
*)
lemmas proper_it_monos =
  proper_it_mono_dres_pair proper_it_mono_dres_pair_flat
  proper_it_mono_dres proper_it_mono_dres_flat
  proper_it_mono_dres_dom proper_it_mono_dres_dom_flat

(* TODO: Conceptually, this leads to some kind of bundles:
  Each bundle has a list of processors, that are invoked for every registered
  theorem. *)

attribute_setup "proper_it" = \<open>
  Scan.succeed (Thm.declaration_attribute (fn thm => fn context =>
    let
      val mono_thms = map_filter (try (curry (RS) thm)) @{thms proper_it_monos}
      (*val mono_thms = map (fn mt => thm RS mt) @{thms proper_it_monos}*)
      val context = context
        |> Icf_Proper_Iterator.add_thm thm
        |> fold Refine_Mono_Prover.add_mono_thm mono_thms
    in
      context
    end
  ))
\<close>
  "Proper iterator declaration"

end