(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Early_Sim
  imports Weak_Early_Semantics Strong_Early_Sim_Pres
begin

definition weakSimulation :: "pi \<Rightarrow> (pi \<times> pi) set \<Rightarrow> pi \<Rightarrow> bool" ("_ \<leadsto><_> _" [80, 80, 80] 80)
  where "P \<leadsto><Rel> Q \<equiv> (\<forall>a x Q'. Q \<longmapsto>a<\<nu>x> \<prec> Q' \<and> x \<sharp> P \<longrightarrow> (\<exists>P'. P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel)) \<and>
                       (\<forall>\<alpha> Q'. Q \<longmapsto>\<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel))"

  assumes "P \<leadsto><A> P'"
  and     "A \<subseteq> B"

  shows "P \<leadsto><B> P'"
using assms
by(simp add: weakSimulation_def) blast

lemma simCasesCont[consumes 1, case_names Bound Free]:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   C   :: "'a::fs_name"

  assumes Eqvt:  "eqvt Rel"
  and     Bound: "\<And>a x Q'. \<lbrakk>Q \<longmapsto> a<\<nu>x> \<prec> Q'; x \<sharp> P; x \<sharp> Q; x \<noteq> a; x \<sharp> C\<rbrakk> \<Longrightarrow> \<exists>P'. P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and     Free:  "\<And>\<alpha> Q'. Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"

  shows "P \<leadsto><Rel> Q"
proof(auto simp add: weakSimulation_def)
  fix a x Q'
  assume QTrans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'" and "x \<sharp> P"
  obtain c::name where "c \<sharp> P" and "c \<sharp> Q" and "c \<noteq> a" and "c \<sharp> Q'" and "c \<sharp> C" and "c \<noteq> x"
    by(generate_fresh "name") auto

  from QTrans \<open>c \<sharp> Q'\<close> have "Q \<longmapsto> a<\<nu>c> \<prec> ([(x, c)] \<bullet> Q')" by(simp add: alphaBoundOutput)
  then obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>c> \<prec> P'" and P'RelQ': "(P', [(x, c)] \<bullet> Q') \<in> Rel"
    using \<open>c \<sharp> P\<close> \<open>c \<sharp> Q\<close> \<open>c \<noteq> a\<close> \<open>c \<sharp> C\<close>
    by(drule_tac Bound) auto

  from PTrans \<open>x \<sharp> P\<close> \<open>c \<noteq> x\<close> have "P \<Longrightarrow>a<\<nu>x> \<prec> ([(x, c)] \<bullet> P')"
    by(force intro: weakTransitionAlpha simp add: name_swap)
  moreover from Eqvt P'RelQ' have "([(x, c)] \<bullet> P', [(x, c)] \<bullet> [(x, c)] \<bullet> Q') \<in> Rel"
    by(rule eqvtRelI)
  hence "([(x, c)] \<bullet> P', Q') \<in> Rel" by simp
  ultimately show "\<exists>P'. P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
    by blast
next
  fix \<alpha> Q'
  assume "Q \<longmapsto>\<alpha> \<prec> Q'"
  thus "\<exists>P'. P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
    by(rule Free)
qed

lemma simCases[case_names Bound Free]:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   C   :: "'a::fs_name"

  assumes "\<And>Q' a x. \<lbrakk>Q \<longmapsto> a<\<nu>x> \<prec> Q'; x \<sharp> P\<rbrakk> \<Longrightarrow> \<exists>P'. P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and     "\<And>Q' \<alpha>. Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"

  shows "P \<leadsto><Rel> Q"
using assms
by(auto simp add: weakSimulation_def)

lemma simE:
  fixes P   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   Q   :: pi
  and   a   :: name
  and   x   :: name
  and   Q'  :: pi

  assumes "P \<leadsto><Rel> Q"

  shows "Q \<longmapsto>a<\<nu>x> \<prec> Q' \<Longrightarrow> x \<sharp> P \<Longrightarrow> \<exists>P'. P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and   "Q \<longmapsto>\<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
using assms by(simp add: weakSimulation_def)+

lemma weakSimTauChain:
  fixes P   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   Rel' :: "(pi \<times> pi) set"
  and   Q   :: pi
  and   Q'  :: pi

  assumes QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q'"
  and     PRelQ: "(P, Q) \<in> Rel"
  and     PSimQ: "\<And>R S. (R, S) \<in> Rel \<Longrightarrow> R \<leadsto><Rel> S"

  shows "\<exists>P'. P \<Longrightarrow>\<^sub>\<tau> P' \<and> (P', Q') \<in> Rel"
proof -
  from QChain show ?thesis
  proof(induct rule: tauChainInduct)
    case id
    moreover have "P \<Longrightarrow>\<^sub>\<tau> P" by simp
    ultimately show ?case using PSimQ PRelQ by blast
  next
    case(ih Q' Q'')
    have "\<exists>P'. P \<Longrightarrow>\<^sub>\<tau> P' \<and> (P', Q') \<in> Rel" by fact
    then obtain P' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'" and P'Rel'Q': "(P', Q') \<in> Rel" by blast
    from P'Rel'Q' have "P' \<leadsto><Rel> Q'" by(rule PSimQ)
    moreover have Q'Trans: "Q' \<longmapsto>\<tau> \<prec> Q''" by fact
    ultimately obtain P'' where P'Trans: "P' \<Longrightarrow>\<^sup>^\<tau> \<prec> P''" and P''RelQ'': "(P'', Q'') \<in> Rel"
      by(blast dest: simE)
    from P'Trans have "P' \<Longrightarrow>\<^sub>\<tau> P''" by simp
    with PChain have "P \<Longrightarrow>\<^sub>\<tau> P''" by auto
    with P''RelQ'' show ?case by blast
  qed
qed

lemma simE2:
  fixes P   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   Q   :: pi
  and   a   :: name
  and   x   :: name
  and   Q'  :: pi

  assumes Sim: "\<And>R S. (R, S) \<in> Rel \<Longrightarrow> R \<leadsto><Rel> S"
  and     Eqvt: "eqvt Rel"
  and     PRelQ: "(P, Q) \<in> Rel"

  shows "Q \<Longrightarrow>a<\<nu>x> \<prec> Q' \<Longrightarrow> x \<sharp> P \<Longrightarrow> \<exists>P'. P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and   "Q \<Longrightarrow>\<^sup>^\<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
proof -
  assume QTrans: "Q \<Longrightarrow>a<\<nu>x> \<prec> Q'" and "x \<sharp> P"
  from QTrans obtain Q'' Q''' where QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q'''"
                                and Q'''Trans: "Q''' \<longmapsto>a<\<nu>x> \<prec> Q''"
                                and Q''Chain: "Q'' \<Longrightarrow>\<^sub>\<tau> Q'"
    by(blast dest: transitionE)

  from QChain PRelQ Sim obtain P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''" and P'''RelQ''': "(P''', Q''') \<in> Rel"
    by(blast dest: weakSimTauChain)

  from PChain \<open>x \<sharp> P\<close> have "x \<sharp> P'''" by(rule freshChain)

  from P'''RelQ''' have "P''' \<leadsto><Rel> Q'''" by(rule Sim)
  with Q'''Trans \<open>x \<sharp> P'''\<close> obtain P'' where P'''Trans: "P''' \<Longrightarrow>a<\<nu>x> \<prec> P''"
                                         and P''RelQ'': "(P'', Q'') \<in> Rel"
    by(blast dest: simE)

  from Q''Chain P''RelQ'' Sim obtain P' where P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'" and P'RelQ': "(P', Q') \<in> Rel"
    by(blast dest: weakSimTauChain)
  from PChain P'''Trans P''Chain  have "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
    by(blast dest: Weak_Early_Step_Semantics.chainTransitionAppend)
  with P'RelQ' show "\<exists>P'. P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel" by blast
next
  assume "Q \<Longrightarrow>\<^sup>^\<alpha> \<prec> Q'"
  thus "\<exists>P'. P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
  proof(induct rule: transitionCases)
    case Step
    have "Q \<Longrightarrow>\<alpha> \<prec> Q'" by fact
    then obtain Q'' Q''' where QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q''"
                           and Q''Trans: "Q'' \<longmapsto>\<alpha> \<prec> Q'''"
                           and Q'''Chain: "Q''' \<Longrightarrow>\<^sub>\<tau> Q'"
      by(blast dest: transitionE)

    from QChain PRelQ Sim have "\<exists>P''. P \<Longrightarrow>\<^sub>\<tau> P'' \<and> (P'', Q'') \<in> Rel"
      by(rule weakSimTauChain)
    then obtain P'' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P''" and P''RelQ'': "(P'', Q'') \<in> Rel" by blast
    from P''RelQ'' have "P'' \<leadsto><Rel> Q''" by(rule Sim)
    with Q''Trans obtain P''' where P''Trans: "P'' \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'''"
                                and P'''RelQ''': "(P''', Q''') \<in> Rel"
      by(blast dest: simE)

    have "\<exists>P'. P''' \<Longrightarrow>\<^sub>\<tau> P' \<and> (P', Q') \<in> Rel" using Q'''Chain P'''RelQ''' Sim
      by(rule weakSimTauChain)
    then obtain P' where P'''Chain: "P''' \<Longrightarrow>\<^sub>\<tau> P'" and P'RelQ': "(P', Q') \<in> Rel" by blast

    from PChain P''Trans P'''Chain have "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'"
      by(blast dest: chainTransitionAppend)
    with P'RelQ' show ?case by blast
  next
    case Stay
    have "P \<Longrightarrow>\<^sup>^\<tau> \<prec> P" by simp
    thus ?case using PRelQ by blast
  qed
qed

lemma eqvtI:
  fixes P    :: pi
  and   Q    :: pi
  and   Rel  :: "(pi \<times> pi) set"
  and   perm :: "name prm"

  assumes PSimQ: "P \<leadsto><Rel> Q"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     EqvtRel': "eqvt Rel'"

  shows "(perm \<bullet> P) \<leadsto><Rel'> (perm \<bullet> Q)"
proof(induct rule: simCases)
  case(Bound Q' a x)
  have xFreshP: "x \<sharp> perm \<bullet> P" by fact
  have QTrans: "(perm \<bullet> Q) \<longmapsto> a<\<nu>x> \<prec> Q'" by fact

  hence "(rev perm \<bullet> (perm \<bullet> Q)) \<longmapsto> rev perm \<bullet> (a<\<nu>x> \<prec> Q')" by(rule eqvts)
  hence "Q \<longmapsto> (rev perm \<bullet> a)<\<nu>(rev perm \<bullet> x)> \<prec> (rev perm \<bullet> Q')"
    by(simp add: name_rev_per)
  moreover from xFreshP have "(rev perm \<bullet> x) \<sharp> P" by(simp add: name_fresh_left)
  ultimately obtain P' where PTrans: "P \<Longrightarrow>(rev perm \<bullet> a)<\<nu>(rev perm \<bullet> x)> \<prec> P'"
                         and P'RelQ': "(P', rev perm \<bullet> Q') \<in> Rel" using PSimQ
    by(blast dest: simE)

  from PTrans have "(perm \<bullet> P) \<Longrightarrow>(perm \<bullet> rev perm \<bullet> a)<\<nu>(perm \<bullet> rev perm \<bullet> x)> \<prec> perm \<bullet> P'"
    by(rule eqvts)
  hence "(perm \<bullet> P) \<Longrightarrow>a<\<nu>x> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
  moreover from P'RelQ' RelRel' have "(P', rev perm \<bullet> Q') \<in> Rel'" by blast
  with EqvtRel' have "(perm \<bullet> P', perm \<bullet> (rev perm \<bullet> Q')) \<in> Rel'"
    by(rule eqvtRelI)
  hence "(perm \<bullet> P', Q') \<in> Rel'" by(simp add: name_per_rev)
  ultimately show ?case by blast
next
  case(Free Q' \<alpha>)
  have QTrans: "(perm \<bullet> Q) \<longmapsto> \<alpha> \<prec> Q'" by fact

  hence "(rev perm \<bullet> (perm \<bullet> Q)) \<longmapsto> rev perm \<bullet> (\<alpha> \<prec> Q')" by(rule eqvts)
  hence "Q \<longmapsto> (rev perm \<bullet> \<alpha>) \<prec> (rev perm \<bullet> Q')"  by(simp add: name_rev_per)
  with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sup>^ (rev perm \<bullet> \<alpha>) \<prec> P'"
                         and PRel: "(P', (rev perm \<bullet> Q')) \<in> Rel"
    by(blast dest: simE)

  from PTrans have "(perm \<bullet> P) \<Longrightarrow>\<^sup>^ (perm \<bullet> rev perm \<bullet> \<alpha>) \<prec> perm \<bullet> P'"
    by(rule Weak_Early_Semantics.eqvtI)
  hence L1: "(perm \<bullet> P) \<Longrightarrow>\<^sup>^ \<alpha> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
  from PRel EqvtRel' RelRel'  have "((perm \<bullet> P'), (perm \<bullet> (rev perm \<bullet> Q'))) \<in> Rel'"
    by(force intro: eqvtRelI)
  hence "((perm \<bullet> P'), Q') \<in> Rel'" by(simp add: name_per_rev)
  with L1 show ?case by blast
qed

(*****************Reflexivity and transitivity*********************)

lemma reflexive:
  fixes P   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes "Id \<subseteq> Rel"

  shows "P \<leadsto><Rel> P"
using assms
by(auto intro: Weak_Early_Step_Semantics.singleActionChain
   simp add: weakSimulation_def weakFreeTransition_def)

  assumes QSimR: "Q \<leadsto><Rel'> R"
  and     Eqvt: "eqvt Rel"
  and     Eqvt'': "eqvt Rel''"
  and     Trans: "Rel O Rel' \<subseteq> Rel''"
  and     Sim: "\<And>S T. (S, T) \<in> Rel \<Longrightarrow> S \<leadsto><Rel> T"
  and     PRelQ: "(P, Q) \<in> Rel"

  shows "P \<leadsto><Rel''> R"
proof -
  from Eqvt'' show ?thesis
  proof(induct rule: simCasesCont[where C=Q])
    case(Bound a x R')
    have RTrans: "R \<longmapsto>a<\<nu>x> \<prec> R'" by fact
    from \<open>x \<sharp> Q\<close> QSimR RTrans obtain Q' where QTrans: "Q \<Longrightarrow>a<\<nu>x> \<prec> Q'"
                                          and Q'Rel'R': "(Q', R') \<in> Rel'"
      by(blast dest: simE)

    from Sim Eqvt PRelQ QTrans \<open>x \<sharp> P\<close>
    obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(drule_tac simE2) auto
(*      by(blast dest: simE2)*)
    moreover from P'RelQ' Q'Rel'R' Trans have "(P', R') \<in> Rel''" by blast
    ultimately show ?case by blast
  next
    case(Free \<alpha> R')
    have RTrans: "R \<longmapsto> \<alpha> \<prec> R'" by fact
    with QSimR obtain Q' where QTrans: "Q \<Longrightarrow>\<^sup>^ \<alpha> \<prec> Q'" and Q'RelR': "(Q', R') \<in> Rel'"
      by(blast dest: simE)
    from Sim Eqvt PRelQ QTrans have "\<exists>P'. P \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
      by(blast intro: simE2)
    then obtain P' where PTrans: "P \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel" by blast
    from P'RelQ' Q'RelR' Trans have "(P', R') \<in> Rel''" by blast
    with PTrans show ?case by blast
  qed
qed

lemma strongAppend:
  fixes P     :: pi
  and   Q     :: pi
  and   R     :: pi
  and   Rel   :: "(pi \<times> pi) set"
  and   Rel'  :: "(pi \<times> pi) set"
  and   Rel'' :: "(pi \<times> pi) set"

  assumes PSimQ: "P \<leadsto><Rel> Q"
  and     QSimR: "Q \<leadsto>[Rel'] R"
  and     Eqvt'': "eqvt Rel''"
  and     Trans: "Rel O Rel' \<subseteq> Rel''"

  shows "P \<leadsto><Rel''> R"
proof -
  from Eqvt'' show ?thesis
  proof(induct rule: simCasesCont[where C=Q])
    case(Bound a x R')
    have RTrans: "R \<longmapsto>a<\<nu>x> \<prec> R'" by fact
    from QSimR RTrans \<open>x \<sharp> Q\<close> obtain Q' where QTrans: "Q \<longmapsto>a<\<nu>x> \<prec> Q'"
                                          and Q'Rel'R': "(Q', R') \<in> Rel'"
      by(blast dest: Strong_Early_Sim.elim)

    with PSimQ QTrans \<open>x \<sharp> P\<close> obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    moreover from P'RelQ' Q'Rel'R' Trans have "(P', R') \<in> Rel''" by blast
    ultimately show ?case by blast
  next
    case(Free \<alpha> R')
    have RTrans: "R \<longmapsto> \<alpha> \<prec> R'" by fact
    with QSimR obtain Q' where QTrans: "Q \<longmapsto>\<alpha> \<prec> Q'" and Q'RelR': "(Q', R') \<in> Rel'"
      by(blast dest: Strong_Early_Sim.elim)
    from PSimQ QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from P'RelQ' Q'RelR' Trans have "(P', R') \<in> Rel''" by blast
    with PTrans show ?case by blast
  qed
qed

lemma strongSimWeakSim:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes PSimQ: "P \<leadsto>[Rel] Q"

  shows "P \<leadsto><Rel> Q"
proof(induct rule: simCases)
  case(Bound Q' a x)
  have "Q \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
  with PSimQ \<open>x \<sharp> P\<close> obtain P' where PTrans: "P \<longmapsto>a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
    by(blast dest: Strong_Early_Sim.elim)
  from PTrans have "P \<Longrightarrow>a<\<nu>x> \<prec>  P'"
    by(force intro: Weak_Early_Step_Semantics.singleActionChain simp add: weakFreeTransition_def)
  with P'RelQ' show ?case by blast
next
  case(Free Q' \<alpha>)
  have "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  with PSimQ obtain P' where PTrans: "P \<longmapsto>\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
    by(blast dest: Strong_Early_Sim.elim)
  from PTrans have "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" by(rule Weak_Early_Semantics.singleActionChain)
  with P'RelQ' show ?case by blast
qed

end


(* The value setup for reviewer confidentiality *)
theory Review_Value_Setup
imports Review_Intro
begin

consts PID :: paperID  consts N :: nat

text \<open>\<^term>\<open>(PID,N)\<close> identifies uniquely the review under scrutiny\<close>

subsection \<open>Preliminaries\<close>

declare updates_commute_paper[simp]

text \<open>Auxiliary definitions:\<close>

definition eqExcNth where
"eqExcNth xs ys n \<equiv>
 length xs = length ys \<and> (\<forall> i < length xs. i \<noteq> n \<longrightarrow> xs!i = ys!i)"

lemma eqExcNth_eq[simp,intro!]: "eqExcNth xs xs n"
unfolding eqExcNth_def by auto

lemma eqExcNth_sym:
assumes "eqExcNth xs xs1 n"
shows "eqExcNth xs1 xs n"
using assms unfolding eqExcNth_def by auto

lemma eqExcNth_trans:
assumes "eqExcNth xs xs1 n" and "eqExcNth xs1 xs2 n"
shows "eqExcNth xs xs2 n"
using assms unfolding eqExcNth_def by auto

fun eqExcD :: "paper \<Rightarrow> paper \<Rightarrow> bool" where
"eqExcD (Paper name info ct reviews dis decs)
        (Paper name1 info1 ct1 reviews1 dis1 decs1) =
 (name = name1 \<and> info = info1 \<and> ct = ct1 \<and> dis = dis1 \<and> decs = decs1 \<and>
  eqExcNth reviews reviews1 N)"

lemma eqExcD:
"eqExcD pap pap1 =
 (titlePaper pap = titlePaper pap1 \<and> abstractPaper pap = abstractPaper pap1 \<and>
  contentPaper pap = contentPaper pap1 \<and>
  disPaper pap = disPaper pap1 \<and> decsPaper pap = decsPaper pap1 \<and>
  eqExcNth (reviewsPaper pap) (reviewsPaper pap1) N)"
by(cases pap, cases pap1, auto)

lemma eqExcD_eq[simp,intro!]: "eqExcD pap pap"
unfolding eqExcD using eqExcNth_eq by auto

lemma eqExcD_sym:
assumes "eqExcD pap pap1"
shows "eqExcD pap1 pap"
using assms unfolding eqExcD using eqExcNth_sym by auto

lemma eqExcD_trans:
assumes "eqExcD pap pap1" and "eqExcD pap1 pap2"
shows "eqExcD pap pap2"
using assms unfolding eqExcD using eqExcNth_trans by auto

definition eeqExcPID_N where
"eeqExcPID_N paps paps1 \<equiv>
 \<forall> pid. if pid = PID then eqExcD (paps pid) (paps1 pid) else paps pid = paps1 pid"

lemma eeqExcPID_N_eeq[simp,intro!]: "eeqExcPID_N s s"
unfolding eeqExcPID_N_def by auto

lemma eeqExcPID_N_sym:
assumes "eeqExcPID_N s s1" shows "eeqExcPID_N s1 s"
using assms eqExcD_sym unfolding eeqExcPID_N_def by auto

lemma eeqExcPID_N_trans:
assumes "eeqExcPID_N s s1" and "eeqExcPID_N s1 s2" shows "eeqExcPID_N s s2"
using assms eqExcD_trans unfolding eeqExcPID_N_def by simp blast

lemma eeqExcPID_N_imp:
"eeqExcPID_N paps paps1 \<Longrightarrow> eqExcD (paps PID) (paps1 PID)"
"\<lbrakk>eeqExcPID_N paps paps1; pid \<noteq> PID\<rbrakk> \<Longrightarrow> paps pid = paps1 pid"
unfolding eeqExcPID_N_def by auto

lemma eeqExcPID_N_cong:
assumes "eeqExcPID_N paps paps1"
and "pid = PID \<Longrightarrow> eqExcD uu uu1"
and "pid \<noteq> PID \<Longrightarrow> uu = uu1"
shows "eeqExcPID_N (paps (pid := uu)) (paps1(pid := uu1))"
using assms unfolding eeqExcPID_N_def by auto

lemma eeqExcPID_N_RDD:
"eeqExcPID_N paps paps1 \<Longrightarrow>
 titlePaper (paps PID) = titlePaper (paps1 PID) \<and>
 abstractPaper (paps PID) = abstractPaper (paps1 PID) \<and>
 contentPaper (paps PID) = contentPaper (paps1 PID) \<and>
 disPaper (paps PID) = disPaper (paps1 PID) \<and>
 decsPaper (paps PID) = decsPaper (paps1 PID)"
using eeqExcPID_N_def unfolding eqExcD by auto

text \<open>The notion of two states being equal everywhere except on the the review \<^term>\<open>(N,PID)\<close>:\<close>

definition eqExcPID_N :: "state \<Rightarrow> state \<Rightarrow> bool" where
"eqExcPID_N s s1 \<equiv>
 confIDs s = confIDs s1 \<and> conf s = conf s1 \<and>
 userIDs s = userIDs s1 \<and> pass s = pass s1 \<and> user s = user s1 \<and> roles s = roles s1 \<and>
 paperIDs s = paperIDs s1
 \<and>
 eeqExcPID_N (paper s) (paper s1)
 \<and>
 pref s = pref s1 \<and>
 voronkov s = voronkov s1 \<and>
 news s = news s1 \<and> phase s = phase s1"

lemma eqExcPID_N_eq[simp,intro!]: "eqExcPID_N s s"
unfolding eqExcPID_N_def by auto

lemma eqExcPID_N_sym:
assumes "eqExcPID_N s s1" shows "eqExcPID_N s1 s"
using assms eeqExcPID_N_sym unfolding eqExcPID_N_def by auto

lemma eqExcPID_N_trans:
assumes "eqExcPID_N s s1" and "eqExcPID_N s1 s2" shows "eqExcPID_N s s2"
using assms eeqExcPID_N_trans unfolding eqExcPID_N_def by auto

text \<open>Implications from \<^term>\<open>eqExcPID_N\<close>, including w.r.t. auxiliary operations:\<close>

lemma eqExcPID_N_imp:
"eqExcPID_N s s1 \<Longrightarrow>
 confIDs s = confIDs s1 \<and> conf s = conf s1 \<and>
 userIDs s = userIDs s1 \<and> pass s = pass s1 \<and> user s = user s1 \<and> roles s = roles s1 \<and>
 paperIDs s = paperIDs s1
 \<and>
 eeqExcPID_N (paper s) (paper s1)
 \<and>
 pref s = pref s1 \<and>
 voronkov s = voronkov s1 \<and>
 news s = news s1 \<and> phase s = phase s1 \<and>

 getAllPaperIDs s = getAllPaperIDs s1 \<and>
 isRev s cid uid pid = isRev s1 cid uid pid \<and>
 getReviewIndex s cid uid pid = getReviewIndex s1 cid uid pid \<and>
 getRevRole s cid uid pid = getRevRole s1 cid uid pid \<and>
 length (reviewsPaper (paper s pid)) = length (reviewsPaper (paper s1 pid))"
unfolding eqExcPID_N_def getAllPaperIDs_def
unfolding isRev_def getReviewIndex_def getRevRole_def apply auto
unfolding eeqExcPID_N_def eqExcD eqExcNth_def by (cases "pid = PID") auto

lemma eqExcPID_N_imp1:
"eqExcPID_N s s1 \<Longrightarrow> eqExcD (paper s pid) (paper s1 pid)"
"eqExcPID_N s s1 \<Longrightarrow> pid \<noteq> PID \<or> PID \<noteq> pid \<Longrightarrow>
    paper s pid = paper s1 pid \<and>
    getNthReview s pid n = getNthReview s1 pid n"
unfolding eqExcPID_N_def eeqExcPID_N_def getNthReview_def
apply auto by (metis eqExcD_eq)

lemma eqExcPID_N_imp2:
assumes "eqExcPID_N s s1" and "pid \<noteq> PID \<or> PID \<noteq> pid"
shows "getReviewersReviews s cid pid = getReviewersReviews s1 cid pid"
proof-
  have
  "(\<lambda>uID. if isRev s cid uID pid then [(uID, getNthReview s pid (getReviewIndex s cid uID pid))] else []) =
   (\<lambda>uID. if isRev s1 cid uID pid then [(uID, getNthReview s1 pid (getReviewIndex s1 cid uID pid))] else [])"
  apply(rule ext)
  using assms by (auto simp: eqExcPID_N_imp eqExcPID_N_imp1)
  thus ?thesis unfolding getReviewersReviews_def using assms by (simp add: eqExcPID_N_imp)
qed

lemma eqExcPID_N_imp3:
"eqExcPID_N s s1 \<Longrightarrow> pid \<noteq> PID \<or> PID \<noteq> pid \<or> (n < length (reviewsPaper (paper s PID)) \<and> n \<noteq> N)
 \<Longrightarrow>
 getNthReview s pid n = getNthReview s1 pid n"
  unfolding eqExcPID_N_def
  apply auto
   apply (metis eeqExcPID_N_imp(2) getNthReview_def)
  unfolding eeqExcPID_N_def apply simp unfolding eqExcD eqExcNth_def
  by (metis getNthReview_def)

lemma eqExcPID_N_imp3':
assumes s: "reach s"
and "eqExcPID_N s s1" and "pid \<noteq> PID \<or> (isRevNth s cid uid pid n \<and> n \<noteq> N)"
shows "getNthReview s pid n = getNthReview s1 pid n"
proof-
  have "isRevNth s cid uid pid n \<Longrightarrow> pid \<noteq> PID \<or> n < length (reviewsPaper (paper s PID))"
  using s by (metis isRevNth_less_length)
  thus ?thesis using eqExcPID_N_imp3 assms by auto
qed

lemma eqExcPID_N_RDD:
"eqExcPID_N s s1 \<Longrightarrow>
 titlePaper (paper s PID) = titlePaper (paper s1 PID) \<and>
 abstractPaper (paper s PID) = abstractPaper (paper s1 PID) \<and>
 contentPaper (paper s PID) = contentPaper (paper s1 PID) \<and>
 disPaper (paper s PID) = disPaper (paper s1 PID) \<and>
 decsPaper (paper s PID) = decsPaper (paper s1 PID)"
using eqExcPID_N_imp eeqExcPID_N_RDD by auto

lemma eqExcPID_N_cong[simp, intro]:
"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>confIDs := uu1\<rparr>) (s1 \<lparr>confIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>conf := uu1\<rparr>) (s1 \<lparr>conf := uu2\<rparr>)"

"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>userIDs := uu1\<rparr>) (s1 \<lparr>userIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>pass := uu1\<rparr>) (s1 \<lparr>pass := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>user := uu1\<rparr>) (s1 \<lparr>user := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>roles := uu1\<rparr>) (s1 \<lparr>roles := uu2\<rparr>)"

"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>paperIDs := uu1\<rparr>) (s1 \<lparr>paperIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> eeqExcPID_N uu1 uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>paper := uu1\<rparr>) (s1 \<lparr>paper := uu2\<rparr>)"

"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>pref := uu1\<rparr>) (s1 \<lparr>pref := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>voronkov := uu1\<rparr>) (s1 \<lparr>voronkov := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>news := uu1\<rparr>) (s1 \<lparr>news := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N (s \<lparr>phase := uu1\<rparr>) (s1 \<lparr>phase := uu2\<rparr>)"

unfolding eqExcPID_N_def by auto

lemma eqExcPID_N_Paper:
assumes s's1': "eqExcPID_N s s1"
and "paper s pid = Paper title abstract content reviews dis decs"
and "paper s1 pid = Paper title1 abstract1 content1 reviews1 dis1 decs1"
shows "title = title1 \<and> abstract = abstract1 \<and> content = content1 \<and> dis = dis1 \<and> decs = decs1"
using assms unfolding eqExcPID_N_def apply (auto simp: eqExcD eeqExcPID_N_def)
by (metis titlePaper.simps abstractPaper.simps contentPaper.simps disPaper.simps decsPaper.simps)+

text \<open>Auxiliary definitions for a slightly weaker equivalence relation defined below:\<close>

definition eqExcNth2 where
"eqExcNth2 rl rl1 n \<equiv>
 length rl = length rl1 \<and>
 (\<forall> i < length rl. i \<noteq> n \<longrightarrow> rl!i = rl1!i) \<and>
 hd (rl!n) = hd (rl1!n)"

lemma eqExcNth2_eq[simp,intro!]: "eqExcNth2 rl rl n"
unfolding eqExcNth2_def by auto

lemma eqExcNth2_sym:
assumes "eqExcNth2 rl rl1 n"
shows "eqExcNth2 rl1 rl n"
using assms unfolding eqExcNth2_def by auto

lemma eqExcNth2_trans:
assumes "eqExcNth2 rl rl1 n" and "eqExcNth2 rl1 rl2 n"
shows "eqExcNth2 rl rl2 n"
using assms unfolding eqExcNth2_def by auto

fun eqExcD2 :: "paper \<Rightarrow> paper \<Rightarrow> bool" where
"eqExcD2 (Paper title abstract ct reviews dis decs)
         (Paper title1 abstract1 ct1 reviews1 dis1 decs1) =
 (title = title1 \<and> abstract = abstract1 \<and> ct = ct1 \<and> dis = dis1 \<and> decs = decs1 \<and>
  eqExcNth2 reviews reviews1 N)"

lemma eqExcD2:
"eqExcD2 pap pap1 =
 (titlePaper pap = titlePaper pap1 \<and> abstractPaper pap = abstractPaper pap1 \<and>
  contentPaper pap = contentPaper pap1 \<and>
  disPaper pap = disPaper pap1 \<and> decsPaper pap = decsPaper pap1 \<and>
  eqExcNth2 (reviewsPaper pap) (reviewsPaper pap1) N)"
by(cases pap, cases pap1, auto)

lemma eqExcD2_eq[simp,intro!]: "eqExcD2 pap pap"
unfolding eqExcD2 using eqExcNth2_eq by auto

lemma eqExcD2_sym:
assumes "eqExcD2 pap pap1"
shows "eqExcD2 pap1 pap"
using assms unfolding eqExcD2 using eqExcNth2_sym by auto

lemma eqExcD2_trans:
assumes "eqExcD2 pap pap1" and "eqExcD2 pap1 pap2"
shows "eqExcD2 pap pap2"
using assms unfolding eqExcD2 using eqExcNth2_trans by auto

definition eeqExcPID_N2 where
"eeqExcPID_N2 paps paps1 \<equiv>
 \<forall> pid. if pid = PID then eqExcD2 (paps pid) (paps1 pid) else paps pid = paps1 pid"

lemma eeqExcPID_N2_eeq[simp,intro!]: "eeqExcPID_N2 s s"
unfolding eeqExcPID_N2_def by auto

lemma eeqExcPID_N2_sym:
assumes "eeqExcPID_N2 s s1" shows "eeqExcPID_N2 s1 s"
using assms eqExcD2_sym unfolding eeqExcPID_N2_def by auto

lemma eeqExcPID_N2_trans:
assumes "eeqExcPID_N2 s s1" and "eeqExcPID_N2 s1 s2" shows "eeqExcPID_N2 s s2"
using assms eqExcD2_trans unfolding eeqExcPID_N2_def by simp blast

lemma eeqExcPID_N2_imp:
"eeqExcPID_N2 paps paps1 \<Longrightarrow> eqExcD2 (paps PID) (paps1 PID)"
"\<lbrakk>eeqExcPID_N2 paps paps1; pid \<noteq> PID\<rbrakk> \<Longrightarrow> paps pid = paps1 pid"
unfolding eeqExcPID_N2_def by auto

lemma eeqExcPID_N2_cong:
assumes "eeqExcPID_N2 paps paps1"
and "pid = PID \<Longrightarrow> eqExcD2 uu uu1"
and "pid \<noteq> PID \<Longrightarrow> uu = uu1"
shows "eeqExcPID_N2 (paps (pid := uu)) (paps1(pid := uu1))"
using assms unfolding eeqExcPID_N2_def by auto

lemma eeqExcPID_N2_RDD:
"eeqExcPID_N2 paps paps1 \<Longrightarrow>
 titlePaper (paps PID) = titlePaper (paps1 PID) \<and>
 abstractPaper (paps PID) = abstractPaper (paps1 PID) \<and>
 contentPaper (paps PID) = contentPaper (paps1 PID) \<and>
 disPaper (paps PID) = disPaper (paps1 PID) \<and>
 decsPaper (paps PID) = decsPaper (paps1 PID)"
using eeqExcPID_N2_def unfolding eqExcD2 by auto

text \<open>A weaker state equivalence that allows differences in old versions of the score and comments
of the review \<^term>\<open>(N, PID)\<close>.  It is used for the confidentiality property that does not cover
PC members in the discussion phase, when they will learn about scores and comments.\<close>

definition eqExcPID_N2 :: "state \<Rightarrow> state \<Rightarrow> bool" where
"eqExcPID_N2 s s1 \<equiv>
 confIDs s = confIDs s1 \<and> conf s = conf s1 \<and>
 userIDs s = userIDs s1 \<and> pass s = pass s1 \<and> user s = user s1 \<and> roles s = roles s1 \<and>
 paperIDs s = paperIDs s1
 \<and>
 eeqExcPID_N2 (paper s) (paper s1)
 \<and>
 pref s = pref s1 \<and>
 voronkov s = voronkov s1 \<and>
 news s = news s1 \<and> phase s = phase s1"

lemma eqExcPID_N2_eq[simp,intro!]: "eqExcPID_N2 s s"
unfolding eqExcPID_N2_def by auto

lemma eqExcPID_N2_sym:
assumes "eqExcPID_N2 s s1" shows "eqExcPID_N2 s1 s"
using assms eeqExcPID_N2_sym unfolding eqExcPID_N2_def by auto

lemma eqExcPID_N2_trans:
assumes "eqExcPID_N2 s s1" and "eqExcPID_N2 s1 s2" shows "eqExcPID_N2 s s2"
using assms eeqExcPID_N2_trans unfolding eqExcPID_N2_def by auto

text \<open>Implications from \<^term>\<open>eqExcPID_N2\<close>, including w.r.t. auxiliary operations:\<close>

lemma eqExcPID_N2_imp:
"eqExcPID_N2 s s1 \<Longrightarrow>
 confIDs s = confIDs s1 \<and> conf s = conf s1 \<and>
 userIDs s = userIDs s1 \<and> pass s = pass s1 \<and> user s = user s1 \<and> roles s = roles s1 \<and>
 paperIDs s = paperIDs s1
 \<and>
 eeqExcPID_N2 (paper s) (paper s1)
 \<and>
 pref s = pref s1 \<and>
 voronkov s = voronkov s1 \<and>
 news s = news s1 \<and> phase s = phase s1 \<and>

 getAllPaperIDs s = getAllPaperIDs s1 \<and>
 isRev s cid uid pid = isRev s1 cid uid pid \<and>
 getReviewIndex s cid uid pid = getReviewIndex s1 cid uid pid \<and>
 getRevRole s cid uid pid = getRevRole s1 cid uid pid \<and>
 length (reviewsPaper (paper s pid)) = length (reviewsPaper (paper s1 pid))"
unfolding eqExcPID_N2_def getAllPaperIDs_def
unfolding isRev_def getReviewIndex_def getRevRole_def apply auto
unfolding eeqExcPID_N2_def eqExcD2 eqExcNth2_def by simp metis

lemma eqExcPID_N2_imp1:
"eqExcPID_N2 s s1 \<Longrightarrow> eqExcD2 (paper s pid) (paper s1 pid)"
"eqExcPID_N2 s s1 \<Longrightarrow> pid \<noteq> PID \<or> PID \<noteq> pid \<Longrightarrow>
    paper s pid = paper s1 pid \<and>
    getNthReview s pid n = getNthReview s1 pid n"
unfolding eqExcPID_N2_def getNthReview_def eeqExcPID_N2_def
apply auto
by (metis eqExcD2_eq)

lemma eqExcPID_N2_imp2:
assumes "eqExcPID_N2 s s1" and "pid \<noteq> PID \<or> PID \<noteq> pid"
shows "getReviewersReviews s cid pid = getReviewersReviews s1 cid pid"
proof-
  have
  "(\<lambda>uID. if isRev s cid uID pid then [(uID, getNthReview s pid (getReviewIndex s cid uID pid))] else []) =
   (\<lambda>uID. if isRev s1 cid uID pid then [(uID, getNthReview s1 pid (getReviewIndex s1 cid uID pid))] else [])"
  apply(rule ext)
  using assms by (auto simp: eqExcPID_N2_imp eqExcPID_N2_imp1)
  thus ?thesis unfolding getReviewersReviews_def using assms by (simp add: eqExcPID_N2_imp)
qed

lemma eqExcPID_N2_eqExcPID_N:
"eqExcPID_N2 s s1 \<Longrightarrow> eqExcPID_N s s1"
unfolding eqExcPID_N_def eqExcPID_N2_def eeqExcPID_N_def eeqExcPID_N2_def eqExcD2 eqExcD
by (auto simp: eqExcNth_def eqExcNth2_def)

lemma eqExcPID_N2_imp3:
"eqExcPID_N2 s s1 \<Longrightarrow> pid \<noteq> PID \<or> PID \<noteq> pid \<or> (n < length (reviewsPaper (paper s PID)) \<and> n \<noteq> N)
 \<Longrightarrow>
 getNthReview s pid n = getNthReview s1 pid n"
by (metis eqExcPID_N2_eqExcPID_N eqExcPID_N_imp3)

lemma eqExcPID_N2_imp3':
assumes s: "reach s"
and "eqExcPID_N2 s s1" and "pid \<noteq> PID \<or> (isRevNth s cid uid pid n \<and> n \<noteq> N)"
shows "getNthReview s pid n = getNthReview s1 pid n"
by (metis assms eqExcPID_N2_eqExcPID_N eqExcPID_N_imp3')

lemma eqExcPID_N2_imp33:
assumes "eqExcPID_N2 s s1"
shows "hd (getNthReview s pid N) = hd (getNthReview s1 pid N)"
proof(cases "pid = PID")
  case False thus ?thesis using eqExcPID_N2_imp3[OF assms] by auto
next
  case True thus ?thesis apply simp
  using assms unfolding eqExcPID_N2_def eeqExcPID_N2_def eqExcD2 eqExcNth2_def getNthReview_def by auto
qed

lemma eqExcPID_N2_RDD:
"eqExcPID_N2 s s1 \<Longrightarrow>
 titlePaper (paper s PID) = titlePaper (paper s1 PID) \<and>
 abstractPaper (paper s PID) = abstractPaper (paper s1 PID) \<and>
 contentPaper (paper s PID) = contentPaper (paper s1 PID) \<and>
 disPaper (paper s PID) = disPaper (paper s1 PID) \<and>
 decsPaper (paper s PID) = decsPaper (paper s1 PID)"
using eqExcPID_N2_imp eeqExcPID_N2_RDD by auto

lemma eqExcPID_N2_cong[simp, intro]:
"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>confIDs := uu1\<rparr>) (s1 \<lparr>confIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>conf := uu1\<rparr>) (s1 \<lparr>conf := uu2\<rparr>)"

"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>userIDs := uu1\<rparr>) (s1 \<lparr>userIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>pass := uu1\<rparr>) (s1 \<lparr>pass := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>user := uu1\<rparr>) (s1 \<lparr>user := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>roles := uu1\<rparr>) (s1 \<lparr>roles := uu2\<rparr>)"

"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>paperIDs := uu1\<rparr>) (s1 \<lparr>paperIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> eeqExcPID_N2 uu1 uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>paper := uu1\<rparr>) (s1 \<lparr>paper := uu2\<rparr>)"

"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>pref := uu1\<rparr>) (s1 \<lparr>pref := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>voronkov := uu1\<rparr>) (s1 \<lparr>voronkov := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>news := uu1\<rparr>) (s1 \<lparr>news := uu2\<rparr>)"
"\<And> uu1 uu2. eqExcPID_N2 s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqExcPID_N2 (s \<lparr>phase := uu1\<rparr>) (s1 \<lparr>phase := uu2\<rparr>)"

unfolding eqExcPID_N2_def by auto

lemma eqExcPID_N2_Paper:
assumes s's1': "eqExcPID_N2 s s1"
and "paper s pid = Paper title abstract content reviews dis decs"
and "paper s1 pid = Paper title1 abstract1 content1 reviews1 dis1 decs1"
shows "title = title1 \<and> abstract = abstract1 \<and> content = content1 \<and> dis = dis1 \<and> decs = decs1"
using assms unfolding eqExcPID_N2_def apply (auto simp: eqExcD2 eeqExcPID_N2_def)
by (metis titlePaper.simps abstractPaper.simps contentPaper.simps disPaper.simps decsPaper.simps)+

(* major *) lemma eqExcPID_N2_step:
assumes ss1: "eqExcPID_N2 s s1"
and step: "step s a = (ou,s')"
and step1: "step s1 a = (ou1,s1')"
and s: "reach s" and r: "isRevNth s cid uid PID N" (* new *)
shows "eqExcPID_N2 s' s1'"
proof -
  note eqs = eqExcPID_N2_imp[OF ss1]
  note eqs' = eqExcPID_N2_imp1[OF ss1]
  have r: "N < length (reviewsPaper (paper s PID))" using s r by (metis isRevNth_less_length)
  have r1: "N < length (reviewsPaper (paper s1 PID))"
  using r eqs unfolding eeqExcPID_N2_def eqExcD2 eqExcNth2_def by simp

  note simps[simp] = c_defs u_defs uu_defs r_defs l_defs Paper_dest_conv eqExcPID_N2_def eeqExcPID_N2_def eqExcD2 eqExcNth2_def
  note * = step step1 eqs eqs' r r1

  then show ?thesis
  proof (cases a)
    case (Cact x1)
    with * show ?thesis
    proof (cases x1)
      case (cReview x81 x82 x83 x84 x85)
      with Cact * show ?thesis
        by (clarsimp; metis (no_types, lifting) less_SucE nth_append_length right_cons_left)
    qed auto
  next
    case (Uact x2)
    with * show ?thesis
    proof (cases x2)
      case (uReview x71 x72 x73 x74 x75 x76)
      with Uact * show ?thesis
        by (clarsimp; metis (no_types, lifting) nth_list_update nth_list_update_neq)
    qed auto
  next
    case (UUact x3)
    with * show ?thesis
    proof (cases x3)
      case (uuReview x31 x32 x33 x34 x35 x36)
      with UUact * show ?thesis
        by (clarsimp; smt list.sel(1) nth_list_update nth_list_update_neq)
    qed auto
  qed auto
qed

subsection \<open>Value Setup\<close>

fun \<phi> :: "(state,act,out) trans \<Rightarrow> bool" where
"\<phi> (Trans _ (Uact (uReview cid uid p pid n rc)) ou _) =
 (pid = PID \<and> n = N \<and> ou = outOK)"
|
"\<phi> (Trans _ (UUact (uuReview cid uid p pid n rc)) ou _) =
 (pid = PID \<and> n = N \<and> ou = outOK)"
|
"\<phi> _ = False"

lemma \<phi>_def2:
"\<phi> (Trans s a ou s') =
 (ou = outOK \<and>
 (\<exists> cid uid p rc.
     a = Uact (uReview cid uid p PID N rc)
     \<or>
    a = UUact (uuReview cid uid p PID N rc)
 ))"
  apply(cases a)
  subgoal by simp
  subgoal for x2 apply (cases x2, auto) .
  subgoal for x3  apply(cases x3, auto) .
  by simp_all

lemma uReview_uuReview_step_eqExcPID_N:
assumes a:
"a = Uact (uReview cid uid p PID N rc) \<or>
 a = UUact (uuReview cid uid p PID N rc)"
and "step s a = (ou,s')"
shows "eqExcPID_N s s'"
using assms unfolding eqExcPID_N_def eeqExcPID_N_def by (auto simp: u_defs uu_defs eqExcNth_def)

lemma \<phi>_step_eqExcPID_N:
assumes \<phi>: "\<phi> (Trans s a ou s')"
and s: "step s a = (ou,s')"
shows "eqExcPID_N s s'"
using \<phi> uReview_uuReview_step_eqExcPID_N[OF _ s] unfolding \<phi>_def2 by blast

(* major *) lemma eqExcPID_N_step:
assumes s's1': "eqExcPID_N s s1"
and step: "step s a = (ou,s')"
and step1: "step s1 a = (ou1,s1')"
shows "eqExcPID_N s' s1'"
proof -
  note eqs = eqExcPID_N_imp[OF s's1']
  note eqs' = eqExcPID_N_imp1[OF s's1']

  note simps[simp] = c_defs u_defs uu_defs r_defs l_defs Paper_dest_conv eqExcPID_N_def eeqExcPID_N_def eqExcD eqExcNth_def
  note * = step step1 eqs eqs'

  then show ?thesis
  proof (cases a)
    case (Cact x1)
    with * show ?thesis
    proof (cases x1)
      case (cReview x81 x82 x83 x84 x85)
      with Cact * show ?thesis
        by (clarsimp; metis (no_types, lifting) less_SucE nth_append_length right_cons_left)
    qed auto
  next
    case (Uact x2)
    with * show ?thesis
    proof (cases x2)
      case (uReview x71 x72 x73 x74 x75 x76)
      with Uact * show ?thesis
        by (clarsimp; metis (no_types, lifting) nth_list_update nth_list_update_neq)
    qed auto
  next
    case (UUact x3)
    with * show ?thesis
    proof (cases x3)
      case (uuReview x31 x32 x33 x34 x35 x36)
      with UUact * show ?thesis
        by (clarsimp; metis (no_types, lifting) nth_list_update nth_list_update_neq)
    qed auto
  qed auto
qed

lemma eqExcPID_N_step_\<phi>_imp:
assumes ss1: "eqExcPID_N s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and \<phi>: "\<phi> (Trans s a ou s')"
shows "\<phi> (Trans s1 a ou1 s1')"
using assms unfolding \<phi>_def2 by (auto simp add: u_defs uu_defs eqExcPID_N_imp)

lemma eqExcPID_N_step_\<phi>:
assumes s's1': "eqExcPID_N s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
shows "\<phi> (Trans s a ou s') = \<phi> (Trans s1 a ou1 s1')"
by (metis eqExcPID_N_step_\<phi>_imp eqExcPID_N_sym assms)

lemma eqExcPID_N2_step_\<phi>_imp:
assumes ss1: "eqExcPID_N2 s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and r: "N < length (reviewsPaper (paper s PID))" (* new *)
and \<phi>: "\<phi> (Trans s a ou s')"
shows "\<phi> (Trans s1 a ou1 s1')"
using assms unfolding \<phi>_def2 by (auto simp add: u_defs uu_defs eqExcPID_N2_imp)

(* More complex, roundabout proof than for other types of documents: *)
lemma eqExcPID_N2_step_\<phi>:
assumes s: "reach s" and s1: "reach s1"
and ss1: "eqExcPID_N2 s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
shows "\<phi> (Trans s a ou s') = \<phi> (Trans s1 a ou1 s1')"
proof(cases "\<exists> cid uid. isRevNth s cid uid PID N")
  case False
  hence "\<not> \<phi> (Trans s a ou s')" unfolding \<phi>_def2 using step
  by (auto simp add: u_defs uu_defs) (metis isRev_imp_isRevNth_getReviewIndex)+
  moreover have "\<not> \<phi> (Trans s1 a ou1 s1')" using step1 False unfolding \<phi>_def2
  by (auto simp add: u_defs uu_defs) (metis eqExcPID_N2_def isRev_imp_isRevNth_getReviewIndex ss1)+
  ultimately show ?thesis by auto
next
  case True note r = True
  note eqs = eqExcPID_N2_imp[OF ss1]
  have r: "N < length (reviewsPaper (paper s PID))"
  using isRevNth_less_length[OF s] r by auto
  have r1: "N < length (reviewsPaper (paper s1 PID))"
  using eqs r unfolding eeqExcPID_N2_def eqExcD2 eqExcNth2_def by simp
  thus ?thesis by (metis eqExcPID_N2_step_\<phi>_imp eqExcPID_N2_sym assms r)
qed

end


section \<open>Deterministic Co-Büchi Automata Combinations\<close>

theory DCA_Combine
imports DCA DGCA
begin

  global_interpretation degeneralization: automaton_degeneralization_run
    dgca dgca.alphabet dgca.initial dgca.transition dgca.rejecting "\<lambda> P w r p. cogen fins P (p ## r)"
    dca dca.alphabet dca.initial dca.transition dca.rejecting "\<lambda> P w r p. fins P (p ## r)"
    fst id
    defines degeneralize = degeneralization.degeneralize
    by (unfold_locales) (auto simp flip: sscan_smap)

  lemmas degeneralize_language[simp] = degeneralization.degeneralize_language[folded DCA.language_def]
  lemmas degeneralize_nodes_finite[iff] = degeneralization.degeneralize_nodes_finite[folded DCA.nodes_def]
  lemmas degeneralize_nodes_card = degeneralization.degeneralize_nodes_card[folded DCA.nodes_def]

  global_interpretation intersection: automaton_intersection_run
    dca.dca dca.alphabet dca.initial dca.transition dca.rejecting "\<lambda> P w r p. fins P (p ## r)"
    dca.dca dca.alphabet dca.initial dca.transition dca.rejecting "\<lambda> P w r p. fins P (p ## r)"
    dca.dca dca.alphabet dca.initial dca.transition dca.rejecting "\<lambda> P w r p. fins P (p ## r)"
    "\<lambda> c\<^sub>1 c\<^sub>2 pq. (c\<^sub>1 \<circ> fst) pq \<or> (c\<^sub>2 \<circ> snd) pq"
    defines intersect = intersection.product
    by (unfold_locales) (simp del: comp_apply)

  lemmas intersect_language = intersection.product_language
  lemmas intersect_nodes_finite = intersection.product_nodes_finite
  lemmas intersect_nodes_card = intersection.product_nodes_card

  global_interpretation union: automaton_union_run
    dca.dca dca.alphabet dca.initial dca.transition dca.rejecting "\<lambda> P w r p. fins P (p ## r)"
    dca.dca dca.alphabet dca.initial dca.transition dca.rejecting "\<lambda> P w r p. fins P (p ## r)"
    dgca.dgca dgca.alphabet dgca.initial dgca.transition dgca.rejecting "\<lambda> P w r p. cogen fins P (p ## r)"
    "\<lambda> c\<^sub>1 c\<^sub>2. [c\<^sub>1 \<circ> fst, c\<^sub>2 \<circ> snd]"
    defines union' = union.product
    by unfold_locales auto

  lemmas union'_language[simp] = union.product_language[folded DGCA.language_def]
  lemmas union'_nodes_finite = union.product_nodes_finite[folded DGCA.nodes_def]
  lemmas union'_nodes_card = union.product_nodes_card[folded DGCA.nodes_def]

  global_interpretation intersection_list: automaton_intersection_list_run
    dca.dca dca.alphabet dca.initial dca.transition dca.rejecting "\<lambda> P w r p. fins P (p ## r)"
    dca.dca dca.alphabet dca.initial dca.transition dca.rejecting "\<lambda> P w r p. fins P (p ## r)"
    "\<lambda> cs pp. \<exists> k < length cs. (cs ! k) (pp ! k)"
    defines intersect_list = intersection_list.product
    by (unfold_locales) (simp add: comp_def)

  lemmas intersect_list_language = intersection_list.product_language
  lemmas intersect_list_nodes_finite = intersection_list.product_nodes_finite
  lemmas intersect_list_nodes_card = intersection_list.product_nodes_card

  global_interpretation union_list: automaton_union_list_run
    dca.dca dca.alphabet dca.initial dca.transition dca.rejecting "\<lambda> P w r p. fins P (p ## r)"
    dgca.dgca dgca.alphabet dgca.initial dgca.transition dgca.rejecting "\<lambda> P w r p. cogen fins P (p ## r)"
    "\<lambda> cs. map (\<lambda> k pp. (cs ! k) (pp ! k)) [0 ..< length cs]"
    defines union_list' = union_list.product
    by (unfold_locales) (auto simp: cogen_def comp_def)

  lemmas union_list'_language[simp] = union_list.product_language[folded DGCA.language_def]
  lemmas union_list'_nodes_finite = union_list.product_nodes_finite[folded DGCA.nodes_def]
  lemmas union_list'_nodes_card = union_list.product_nodes_card[folded DGCA.nodes_def]

  abbreviation union where "union A B \<equiv> degeneralize (union' A B)"

  lemma union_language[simp]:
    assumes "dca.alphabet A = dca.alphabet B"
    shows "DCA.language (union A B) = DCA.language A \<union> DCA.language B"
    using assms by simp
  lemma union_nodes_finite:
    assumes "finite (DCA.nodes A)" "finite (DCA.nodes B)"
    shows "finite (DCA.nodes (union A B))"
    using union'_nodes_finite assms by simp
  lemma union_nodes_card:
    assumes "finite (DCA.nodes A)" "finite (DCA.nodes B)"
    shows "card (DCA.nodes (union A B)) \<le> 2 * card (DCA.nodes A) * card (DCA.nodes B)"
  proof -
    have "card (DCA.nodes (union A B)) \<le>
      max 1 (length (dgca.rejecting (union' A B))) * card (DGCA.nodes (union' A B))"
      using degeneralize_nodes_card by this
    also have "length (dgca.rejecting (union' A B)) = 2" by simp
    also have "card (DGCA.nodes (union' A B)) \<le> card (DCA.nodes A) * card (DCA.nodes B)"
      using union'_nodes_card assms by this
    finally show ?thesis by simp
  qed

  abbreviation union_list where "union_list AA \<equiv> degeneralize (union_list' AA)"

  lemma union_list_language[simp]:
    assumes "\<Inter> (dca.alphabet ` set AA) = \<Union> (dca.alphabet ` set AA)"
    shows "DCA.language (union_list AA) = \<Union> (DCA.language ` set AA)"
    using assms by simp
  lemma union_list_nodes_finite:
    assumes "list_all (finite \<circ> DCA.nodes) AA"
    shows "finite (DCA.nodes (union_list AA))"
    using union_list'_nodes_finite assms by simp
  lemma union_list_nodes_card:
    assumes "list_all (finite \<circ> DCA.nodes) AA"
    shows "card (DCA.nodes (union_list AA)) \<le> max 1 (length AA) * prod_list (map (card \<circ> DCA.nodes) AA)"
  proof -
    have "card (DCA.nodes (union_list AA)) \<le>
      max 1 (length (dgca.rejecting (union_list' AA))) * card (DGCA.nodes (union_list' AA))"
      using degeneralize_nodes_card by this
    also have "length (dgca.rejecting (union_list' AA)) = length AA" by simp
    also have "card (DGCA.nodes (union_list' AA)) \<le> prod_list (map (card \<circ> DCA.nodes) AA)"
      using union_list'_nodes_card assms by this
    finally show ?thesis by simp
  qed

end


theory Refine_Invar
  imports
    Refine_Unions
    Refine_Intersection
begin

consts i_invar::"interface \<Rightarrow> interface \<Rightarrow> interface"

definition [simp]: "uninvar X = X"

definition with_invar::"'invar \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where [simp]: "with_invar i X = X"

definition get_invar::"('invar \<Rightarrow> 'a set) \<Rightarrow> 'a set \<Rightarrow> ('a set \<times> 'invar) nres"
  where [refine_vcg_def]: "get_invar a X = SPEC (\<lambda>(Y, invar). Y = X \<and> Y \<subseteq> a invar)"
lemma get_invar_pat[autoref_op_pat_def]: "get_invar i \<equiv> Autoref_Tagging.OP (get_invar i)"
  by auto

definition split_with_invar::"('c \<Rightarrow> 'a set) \<Rightarrow> 'a set \<Rightarrow> (('a set \<times> 'c) \<times> 'a set) nres"
  where [refine_vcg_def]: "split_with_invar i X = SPEC (\<lambda>((Y, sctn), YS). X = Y \<union> YS \<and> Y \<subseteq> i sctn)"
lemma split_with_invar_pat[autoref_op_pat_def]:
  "split_with_invar i \<equiv> Autoref_Tagging.OP (split_with_invar i)"
  by auto

context includes autoref_syntax begin

definition invar_rel_internal:
  "invar_rel a X S = {((x, s'), y). \<exists>s. (s', s) \<in> X \<and> (x, y) \<in> S \<and> y \<subseteq> a s}"
lemma invar_rel_def: "\<langle>X, S\<rangle>invar_rel a = {((x, s'), y). \<exists>s. (s', s) \<in> X \<and> (x, y) \<in> S \<and> y \<subseteq> a s}"
  by (auto simp: invar_rel_internal relAPP_def)
lemmas [autoref_rel_intf] = REL_INTFI[of "invar_rel a" i_invar for a]

lemma invar_rel_br: "\<langle>(br a' I'), (br a I)\<rangle>invar_rel b =
  br (\<lambda>(x, s). a x) (\<lambda>(x, s). I x \<and> I' s \<and> (a x \<subseteq> b (a' s)))"
  by (auto simp: invar_rel_def br_def)

lemma sv_appr_invar_rel[relator_props]: "single_valued S \<Longrightarrow> single_valued (\<langle>X, S\<rangle>invar_rel a)"
  and sv_inter_rel[relator_props]: "single_valued S \<Longrightarrow> single_valued T \<Longrightarrow> single_valued (\<langle>T, S\<rangle>inter_rel)"
  unfolding relAPP_def
   apply (auto simp: invar_rel_internal inter_rel_internal single_valued_def set_rel_def)
     apply blast
    apply blast
  done

lemma with_invar_impl[autoref_rules]:
  assumes "(sctni, sctn) \<in> S"
  assumes "(Xi, X) \<in> clw_rel A"
  assumes "PREFER single_valued A"
  assumes "SIDE_PRECOND (X \<subseteq> a sctn)"
  shows "(map (\<lambda>x. (x, sctni)) Xi, with_invar $ sctn $ X) \<in> clw_rel (\<langle>S,A\<rangle>invar_rel a)"
  unfolding autoref_tag_defs
  using assms
  apply (auto simp: clw_rel_def elim!: single_valued_as_brE)
  subgoal for a i Y Z
    apply (rule relcompI)
    apply (force simp: lw_rel_def br_def)
    apply (rule relcompI[where b=Z])
    apply (auto simp: set_rel_def lw_rel_def invar_rel_def br_def)
    apply (metis Sup_le_iff)
    apply (metis Sup_le_iff)
    done
  done

lemma get_invar_autoref[autoref_rules]:
  "(\<lambda>x. RETURN x, get_invar a) \<in> \<langle>X, S\<rangle>invar_rel a \<rightarrow> \<langle>S \<times>\<^sub>r X\<rangle>nres_rel"
  by (force simp: get_invar_def invar_rel_def nres_rel_def intro!: RETURN_SPEC_refine)

lemma uninvar_autoref[autoref_rules]:
  assumes "PREFER single_valued A"
  assumes "PREFER single_valued X"
  shows "(map fst, uninvar) \<in> clw_rel (\<langle>X, A\<rangle>invar_rel b) \<rightarrow> clw_rel A"
  using assms
  by (force simp: lw_rel_def Union_rel_br invar_rel_br elim!: single_valued_as_brE
      dest!: brD
      intro!: brI)

abbreviation "splitbysndimpl xs \<equiv> do {
  let s = snd (hd xs);
  let (ys, zs) = List.partition (\<lambda>(_, sctn). sctn = s) xs;
  RETURN ((map fst ys, s), zs)
}"

lemma split_with_invar_autoref[autoref_rules]:
  assumes "PREFER single_valued A"
  assumes "PREFER single_valued S"
  assumes "(xs, X) \<in> clw_rel (\<langle>S, A\<rangle>invar_rel a)"
  shows
    "(if xs \<noteq> [] then do { ((xs, sctn), ys) \<leftarrow> splitbysndimpl xs; RETURN ((xs, sctn), ys) } else SUCCEED,
    split_with_invar a $ X) \<in>
    \<langle>(clw_rel A \<times>\<^sub>r S) \<times>\<^sub>r clw_rel (\<langle>S, A\<rangle>invar_rel a)\<rangle>nres_rel"
  using assms
  by (fastforce simp: Let_def split_with_invar_def split_beta'
      lw_rel_def Union_rel_br ex_br_conj_iff invar_rel_br
      elim!: single_valued_as_brE
      intro!: nres_relI RETURN_SPEC_refine
      dest!: brD)

end

definition
  "explicit_sctn_set po X0 =
    do {
      e \<leftarrow> isEmpty_spec X0;
      (_, _, Xis) \<leftarrow> WHILE\<^bsup>\<lambda>(e, X, Y).
          (e \<longrightarrow> X = {}) \<and>
          X0 = X \<union> (\<Union>(sctn, IS)\<in>Y. IS) \<and>
          (\<forall>(sctn, IS) \<in> Y. IS \<subseteq> po sctn)\<^esup>
        (\<lambda>(e, X, Y). \<not>e)
        (\<lambda>(e, X, Y).
          do {
            ((S, sctn), X') \<leftarrow> split_with_invar po X;
            e \<leftarrow> isEmpty_spec X';
            RETURN (e, X', insert (sctn, S) Y)
          }
        )
        (e,
          X0,
          {});
      RETURN Xis
    }"
lemma explicit_sctn_set_pat[autoref_op_pat_def]: "explicit_sctn_set po \<equiv> Autoref_Tagging.OP (explicit_sctn_set po)"
  by auto

context includes autoref_syntax begin

lemma pfi: "PREFER single_valued R \<Longrightarrow> ((#), OP insert ::: R \<rightarrow> \<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel) \<in> R \<rightarrow> \<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel"
  using list_set_autoref_insert[of R]
  by auto

schematic_goal explicit_sctn_setc:
  fixes po :: "'d \<Rightarrow> 'a::executable_euclidean_space set"
  assumes [THEN PREFER_sv_D, relator_props]: "PREFER single_valued A"
  assumes [THEN PREFER_sv_D, relator_props]: "PREFER single_valued S"
  assumes [autoref_rules]: "(XSi, XS) \<in> clw_rel (\<langle>S, A\<rangle>invar_rel po)"
  shows "(nres_of ?f, explicit_sctn_set po $ XS) \<in> \<langle>\<langle>S \<times>\<^sub>r clw_rel A\<rangle>list_wset_rel\<rangle>nres_rel"
  unfolding autoref_tag_defs
  unfolding explicit_sctn_set_def
  by autoref_monadic

concrete_definition explicit_sctn_setc for XSi uses explicit_sctn_setc
lemmas [autoref_rules] = explicit_sctn_setc.refine

lemma explicit_sctn_set[THEN order_trans, refine_vcg]:
  "explicit_sctn_set po X \<le> SPEC (\<lambda>R. X = (\<Union>(sctn, IS) \<in> R. IS) \<and> (\<forall>(sctn, IS) \<in> R. IS \<subseteq> po sctn))"
  unfolding explicit_sctn_set_def
  by (refine_vcg) (auto simp: split_beta' subset_iff)
end

end


section \<open>Sequential pattern matching\<close>

theory Rewriting_Sterm
imports Rewriting_Pterm
begin

type_synonym srule = "name \<times> sterm"

abbreviation closed_srules :: "srule list \<Rightarrow> bool" where
"closed_srules \<equiv> list_all (closed \<circ> snd)"

primrec srule :: "srule \<Rightarrow> bool" where
"srule (_, rhs) \<longleftrightarrow> wellformed rhs \<and> closed rhs \<and> is_abs rhs"

lemma sruleI[intro!]: "wellformed rhs \<Longrightarrow> closed rhs \<Longrightarrow> is_abs rhs \<Longrightarrow> srule (name, rhs)"
by simp

locale srules = constants C_info "fst |`| fset_of_list rs" for C_info and rs :: "srule list" +
  assumes all_rules: "list_all srule rs"
  assumes distinct: "distinct (map fst rs)"
  assumes not_shadows: "list_all (\<lambda>(_, rhs). \<not> shadows_consts rhs) rs"
  assumes swelldefined_rs: "list_all (\<lambda>(_, rhs). welldefined rhs) rs"
begin

lemma map: "is_map (set rs)"
using distinct by (rule distinct_is_map)

lemma clausesE:
  assumes "(name, rhs) \<in> set rs"
  obtains cs where "rhs = Sabs cs"
proof -
  from assms have "is_abs rhs"
    using all_rules unfolding list_all_iff by auto
  then obtain cs where "rhs = Sabs cs"
    by (cases rhs) (auto simp: is_abs_def term_cases_def)
  with that show thesis .
qed

end

subsubsection \<open>Rewriting\<close>

inductive srewrite_step where
cons_match: "srewrite_step ((name, rhs) # rest) name rhs" |
cons_nomatch: "name \<noteq> name' \<Longrightarrow> srewrite_step rs name rhs \<Longrightarrow> srewrite_step ((name', rhs') # rs) name rhs"

lemma srewrite_stepI0:
  assumes "(name, rhs) \<in> set rs" "is_map (set rs)"
  shows "srewrite_step rs name rhs"
using assms proof (induction rs)
  case (Cons r rs)
  then obtain name' rhs' where "r = (name', rhs')" by force
  show ?case
    proof (cases "name = name'")
      case False
      show ?thesis
        unfolding \<open>r = _\<close>
        apply (rule srewrite_step.cons_nomatch)
        subgoal by fact
        apply (rule Cons)
        using False Cons(2) \<open>r = _\<close> apply force
        using Cons(3) unfolding is_map_def by auto
    next
      case True
      have "rhs = rhs'"
        apply (rule is_mapD)
          apply fact
        unfolding \<open>r = _\<close>
        using Cons(2) \<open>r = _\<close> apply simp
        using True apply simp
        done
      show ?thesis
        unfolding \<open>r = _\<close> \<open>name = _\<close> \<open>rhs = _\<close>
        by (rule srewrite_step.cons_match)
    qed
qed auto

lemma (in srules) srewrite_stepI: "(name, rhs) \<in> set rs \<Longrightarrow> srewrite_step rs name rhs"
using map
by (metis srewrite_stepI0)

hide_fact srewrite_stepI0

inductive srewrite :: "srule list \<Rightarrow> sterm \<Rightarrow> sterm \<Rightarrow> bool" ("_/ \<turnstile>\<^sub>s/ _ \<longrightarrow>/ _" [50,0,50] 50) for rs where
step: "srewrite_step rs name rhs \<Longrightarrow> rs \<turnstile>\<^sub>s Sconst name \<longrightarrow> rhs" |
beta: "rewrite_first cs t t' \<Longrightarrow> rs \<turnstile>\<^sub>s Sabs cs $\<^sub>s t \<longrightarrow> t'" |
"fun": "rs \<turnstile>\<^sub>s t \<longrightarrow> t' \<Longrightarrow> rs \<turnstile>\<^sub>s t $\<^sub>s u \<longrightarrow> t' $\<^sub>s u" |
arg: "rs \<turnstile>\<^sub>s u \<longrightarrow> u' \<Longrightarrow> rs \<turnstile>\<^sub>s t $\<^sub>s u \<longrightarrow> t $\<^sub>s u'"

code_pred srewrite .

abbreviation srewrite_rt :: "srule list \<Rightarrow> sterm \<Rightarrow> sterm \<Rightarrow> bool" ("_/ \<turnstile>\<^sub>s/ _ \<longrightarrow>*/ _" [50,0,50] 50) where
"srewrite_rt rs \<equiv> (srewrite rs)\<^sup>*\<^sup>*"

global_interpretation srewrite: rewriting "srewrite rs" for rs
by standard (auto intro: srewrite.intros simp: app_sterm_def)+

code_pred (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) srewrite_step .
code_pred (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) srewrite .

subsubsection \<open>Translation from @{typ pterm} to @{typ sterm}\<close>

text \<open>
  In principle, any function of type @{typ \<open>('a \<times> 'b) fset \<Rightarrow> ('a \<times> 'b) list\<close>} that orders
  by keys would do here. However, For simplicity's sake, we choose a fixed one
  (@{const ordered_fmap}) here.
\<close>

primrec pterm_to_sterm :: "pterm \<Rightarrow> sterm" where
"pterm_to_sterm (Pconst name) = Sconst name" |
"pterm_to_sterm (Pvar name) = Svar name" |
"pterm_to_sterm (t $\<^sub>p u) = pterm_to_sterm t $\<^sub>s pterm_to_sterm u" |
"pterm_to_sterm (Pabs cs) = Sabs (ordered_fmap (map_prod id pterm_to_sterm |`| cs))"

lemma pterm_to_sterm:
  assumes "no_abs t"
  shows "pterm_to_sterm t = convert_term t"
using assms proof induction
  case (free name)
  show ?case
    apply simp
    apply (simp add: free_sterm_def free_pterm_def)
    done
next
  case (const name)
  show ?case
    apply simp
    apply (simp add: const_sterm_def const_pterm_def)
    done
next
  case (app t\<^sub>1 t\<^sub>2)
  then show ?case
    apply simp
    apply (simp add: app_sterm_def app_pterm_def)
    done
qed

text \<open>
  @{const sterm_to_pterm} has to be defined, for technical reasons, in
  @{theory CakeML_Codegen.Pterm}.
\<close>

lemma pterm_to_sterm_wellformed:
  assumes "wellformed t"
  shows "wellformed (pterm_to_sterm t)"
using assms proof (induction t rule: pterm_induct)
  case (Pabs cs)
  show ?case
    apply simp
    unfolding map_prod_def id_apply
    apply (intro conjI)
    subgoal
      apply (subst list_all_iff_fset)
      apply (subst ordered_fmap_set_eq)
       apply (rule is_fmap_image)
      using Pabs apply simp
      apply (rule fBallI)
      apply (erule fimageE)
      apply auto[]
      using Pabs(2) apply auto[]
      apply (rule Pabs)
      using Pabs(2) by auto
    subgoal
      apply (rule ordered_fmap_distinct)
      apply (rule is_fmap_image)
      using Pabs(2) by simp
    subgoal
      apply (subgoal_tac "cs \<noteq> {||}")
      including fset.lifting apply transfer
      unfolding ordered_map_def
      using Pabs(2) by auto
    done
qed auto

lemma pterm_to_sterm_sterm_to_pterm:
  assumes "wellformed t"
  shows "sterm_to_pterm (pterm_to_sterm t) = t"
using assms proof (induction t)
  case (Pabs cs)
  note fset_of_list_map[simp del]
  show ?case
    apply simp
    unfolding map_prod_def id_apply
    apply (subst ordered_fmap_image)
    subgoal
      apply (rule is_fmap_image)
      using Pabs by simp
    apply (subst ordered_fmap_set_eq)
    subgoal
      apply (rule is_fmap_image)
      apply (rule is_fmap_image)
      using Pabs by simp
    subgoal
      apply (subst fset.map_comp)
      apply (subst map_prod_def[symmetric])+
      unfolding o_def
      apply (subst prod.map_comp)
      apply (subst id_def[symmetric])+
      apply simp
      apply (subst map_prod_def)
      unfolding id_def
      apply (rule fset_map_snd_id)
      apply simp
      apply (rule Pabs)
      using Pabs(2) by (auto simp: fmember.rep_eq snds.simps)
    done
qed auto

corollary pterm_to_sterm_frees: "wellformed t \<Longrightarrow> frees (pterm_to_sterm t) = frees t"
by (metis pterm_to_sterm_sterm_to_pterm sterm_to_pterm_frees)

corollary pterm_to_sterm_closed:
  "closed_except t S \<Longrightarrow> wellformed t \<Longrightarrow> closed_except (pterm_to_sterm t) S"
unfolding closed_except_def
by (simp add: pterm_to_sterm_frees)

corollary pterm_to_sterm_consts: "wellformed t \<Longrightarrow> consts (pterm_to_sterm t) = consts t"
by (metis pterm_to_sterm_sterm_to_pterm sterm_to_pterm_consts)

corollary (in constants) pterm_to_sterm_shadows:
  "wellformed t \<Longrightarrow> shadows_consts t \<longleftrightarrow> shadows_consts (pterm_to_sterm t)"
unfolding shadows_consts_def
by (metis pterm_to_sterm_sterm_to_pterm sterm_to_pterm_all_frees)

definition compile :: "prule fset \<Rightarrow> srule list" where
"compile rs = ordered_fmap (map_prod id pterm_to_sterm |`| rs)"

subsubsection \<open>Correctness of translation\<close>

context prules begin

lemma compile_heads: "fst |`| fset_of_list (compile rs) = fst |`| rs"
  unfolding compile_def
  apply (subst ordered_fmap_set_eq)
   apply (subst map_prod_def, subst id_apply)
   apply (rule is_fmap_image)
   apply (rule fmap)
  apply simp
  done

lemma compile_rules: "srules C_info (compile rs)"
proof
  show "list_all srule (compile rs)"
    using fmap all_rules
    unfolding compile_def list_all_iff
    including fset.lifting
    apply transfer
    apply (subst ordered_map_set_eq)
    subgoal by simp
    subgoal
      unfolding map_prod_def id_def
      by (erule is_map_image)
    subgoal
      apply (rule ballI)
      apply safe
      subgoal
        apply (rule pterm_to_sterm_wellformed)
        apply fastforce
        done
      subgoal
        apply (rule pterm_to_sterm_closed)
         apply fastforce
        apply fastforce
        done
      subgoal for _ _ a b
        apply (erule ballE[where x = "(a, b)"])
         apply (cases b; auto)
            apply (auto simp: is_abs_def term_cases_def)
        done
      done
    done
next
  show "distinct (map fst (compile rs))"
    unfolding compile_def
    apply (rule ordered_fmap_distinct)
    unfolding map_prod_def id_def
    apply (rule is_fmap_image)
    apply (rule fmap)
    done
next
  have "list_all (\<lambda>(_, rhs). welldefined rhs) (compile rs)"
    unfolding compile_def
    apply (subst ordered_fmap_list_all)
    subgoal
      apply (subst map_prod_def)
      apply (subst id_apply)
      apply (rule is_fmap_image)
      by (fact fmap)
    apply simp
    apply (rule fBallI)
    subgoal for x
      apply (cases x, simp)
      apply (subst pterm_to_sterm_consts)
      using all_rules apply force
      using welldefined_rs by force
    done
  thus "list_all (\<lambda>(_, rhs). consts rhs |\<subseteq>| pre_constants.all_consts C_info (fst |`| fset_of_list (compile rs))) (compile rs)"
    by (simp add: compile_heads)
next
  interpret c: constants _ "fset_of_list (map fst (compile rs))"
    by (simp add: constants_axioms compile_heads)
  have all_consts: "c.all_consts = all_consts"
    by (simp add: compile_heads)

  note fset_of_list_map[simp del]
  have "list_all (\<lambda>(_, rhs). \<not> shadows_consts rhs) (compile rs)"
    unfolding compile_def
    apply (subst list_all_iff_fset)
    apply (subst ordered_fmap_set_eq)
     apply (subst map_prod_def)
    unfolding id_apply
     apply (rule is_fmap_image)
     apply (fact fmap)
    apply simp
    apply (rule fBall_pred_weaken[where P = "\<lambda>(_, rhs). \<not> shadows_consts rhs"])
    subgoal for x
      apply (cases x, simp)
      apply (subst (asm) pterm_to_sterm_shadows)
      using all_rules apply force
      by simp
    subgoal
      using not_shadows by force
    done
  thus "list_all (\<lambda>(_, rhs). \<not> pre_constants.shadows_consts C_info (fst |`| fset_of_list (compile rs)) rhs) (compile rs)"
    unfolding compile_heads all_consts .
next
  show "fdisjnt (fst |`| fset_of_list (compile rs)) C"
    unfolding compile_def
    apply (subst fset_of_list_map[symmetric])
    apply (subst ordered_fmap_keys)
     apply (subst map_prod_def)
     apply (subst id_apply)
     apply (rule is_fmap_image)
    using fmap disjnt by auto
next
  show "distinct all_constructors"
    by (fact distinct_ctr)
qed

sublocale prules_as_srules: srules C_info "compile rs"
by (fact compile_rules)

end

global_interpretation srelated: term_struct_rel_strong "(\<lambda>p s. p = sterm_to_pterm s)"
proof (standard, goal_cases)
  case (5 name t)
  then show ?case by (cases t) (auto simp: const_sterm_def const_pterm_def split: option.splits)
next
  case (6 u\<^sub>1 u\<^sub>2 t)
  then show ?case by (cases t) (auto simp: app_sterm_def app_pterm_def split: option.splits)
qed (auto simp: const_sterm_def const_pterm_def app_sterm_def app_pterm_def)

context begin

private lemma srewrite_step_non_empty: "srewrite_step rs' name rhs \<Longrightarrow> rs' \<noteq> []"
by (induct rule: srewrite_step.induct) auto

private lemma compile_consE:
  assumes "(name, rhs') # rest = compile rs" "is_fmap rs"
  obtains rhs where "rhs' = pterm_to_sterm rhs" "(name, rhs) |\<in>| rs" "rest = compile (rs - {| (name, rhs) |})"
proof -
  from assms have "ordered_fmap (map_prod id pterm_to_sterm |`| rs) = (name, rhs') # rest"
    unfolding compile_def
    by simp
  hence "(name, rhs') \<in> set (ordered_fmap (map_prod id pterm_to_sterm |`| rs))"
    by simp

  have "(name, rhs') |\<in>| map_prod id pterm_to_sterm |`| rs"
    apply (rule ordered_fmap_sound)
    subgoal
      unfolding map_prod_def id_apply
      apply (rule is_fmap_image)
      apply fact
      done
    subgoal by fact
    done
  then obtain rhs where "rhs' = pterm_to_sterm rhs" "(name, rhs) |\<in>| rs"
    by auto

  have "rest = compile (rs - {| (name, rhs) |})"
    unfolding compile_def
    apply (subst inj_on_fimage_set_diff[where C = rs])
    subgoal
      apply (rule inj_onI)
      apply safe
       apply auto
      apply (subst (asm) fmember.rep_eq[symmetric])+
      using \<open>is_fmap rs\<close> by (blast dest: is_fmapD)
    subgoal by simp
    subgoal using \<open>(name, rhs) |\<in>| rs\<close> by simp
    subgoal
      apply simp
      apply (subst ordered_fmap_remove)
        apply (subst map_prod_def)
      unfolding id_apply
        apply (rule is_fmap_image)
        apply fact
      using \<open>(name, rhs) |\<in>| rs\<close> apply force
      apply (subst \<open>rhs' = pterm_to_sterm rhs\<close>[symmetric])
      apply (subst \<open>ordered_fmap _ = _\<close>[unfolded id_def])
      by simp
    done

  show thesis
    by (rule that) fact+
qed

private lemma compile_correct_step:
  assumes "srewrite_step (compile rs) name rhs" "is_fmap rs" "fBall rs prule"
  shows "(name, sterm_to_pterm rhs) |\<in>| rs"
using assms proof (induction "compile rs" name rhs arbitrary: rs)
  case (cons_match name rhs' rest)
  then obtain rhs where "rhs' = pterm_to_sterm rhs" "(name, rhs) |\<in>| rs"
    by (auto elim: compile_consE)

  show ?case
    unfolding \<open>rhs' = _\<close>
    apply (subst pterm_to_sterm_sterm_to_pterm)
    using fbspec[OF \<open>fBall rs prule\<close> \<open>(name, rhs) |\<in>| rs\<close>] apply force
    by fact
next
  case (cons_nomatch name name\<^sub>1 rest rhs rhs\<^sub>1')
  then obtain rhs\<^sub>1 where "rhs\<^sub>1' = pterm_to_sterm rhs\<^sub>1" "(name\<^sub>1, rhs\<^sub>1) |\<in>| rs" "rest = compile (rs - {| (name\<^sub>1, rhs\<^sub>1) |})"
    by (auto elim: compile_consE)

  let ?rs' = "rs - {| (name\<^sub>1, rhs\<^sub>1) |}"
  have "(name, sterm_to_pterm rhs) |\<in>| ?rs'"
    proof (intro cons_nomatch)
      show "rest = compile ?rs'"
        by fact

      show "is_fmap (rs |-| {|(name\<^sub>1, rhs\<^sub>1)|})"
        using \<open>is_fmap rs\<close>
        by (rule is_fmap_subset) auto

      show "fBall ?rs' prule"
        using cons_nomatch by blast
    qed
  thus ?case
    by simp
qed

lemma compile_correct0:
  assumes "compile rs \<turnstile>\<^sub>s u \<longrightarrow> u'" "prules C rs"
  shows "rs \<turnstile>\<^sub>p sterm_to_pterm u \<longrightarrow> sterm_to_pterm u'"
using assms proof induction
  case (beta cs t t')
  then obtain pat rhs env where "(pat, rhs) \<in> set cs" "match pat t = Some env" "t' = subst rhs env"
    by (auto elim: rewrite_firstE)

  then obtain env' where "match pat (sterm_to_pterm t) = Some env'" "srelated.P_env env' env"
    by (metis option.distinct(1) option.inject option.rel_cases srelated.match_rel)
  hence "subst (sterm_to_pterm rhs) env' = sterm_to_pterm (subst rhs env)"
    by (simp add: srelated_subst)

  let ?rhs' = "sterm_to_pterm rhs"

  have "(pat, ?rhs') |\<in>| fset_of_list (map (map_prod id sterm_to_pterm) cs)"
    using \<open>(pat, rhs) \<in> set cs\<close>
    including fset.lifting
    by transfer' force

  note fset_of_list_map[simp del]
  show ?case
    apply simp
    apply (rule prewrite.intros)
     apply fact
    unfolding rewrite_step.simps
    apply (subst map_option_eq_Some)
    apply (intro exI conjI)
     apply fact
    unfolding \<open>t' = _\<close>
    by fact
next
  case (step name rhs)
  hence "(name, sterm_to_pterm rhs) |\<in>| rs"
    unfolding prules_def prules_axioms_def
    by (metis compile_correct_step)
  thus ?case
    by (auto intro: prewrite.intros)
qed (auto intro: prewrite.intros)

end

lemma (in prules) compile_correct:
  assumes "compile rs \<turnstile>\<^sub>s u \<longrightarrow> u'"
  shows "rs \<turnstile>\<^sub>p sterm_to_pterm u \<longrightarrow> sterm_to_pterm u'"
by (rule compile_correct0) (fact | standard)+

hide_fact compile_correct0

subsubsection \<open>Completeness of translation\<close>

global_interpretation srelated': term_struct_rel_strong "(\<lambda>p s. pterm_to_sterm p = s)"
proof (standard, goal_cases)
  case (1 t name)
  then show ?case by (cases t) (auto simp: const_sterm_def const_pterm_def split: option.splits)
next
  case (3 t u\<^sub>1 u\<^sub>2)
  then show ?case by (cases t) (auto simp: app_sterm_def app_pterm_def split: option.splits)
qed (auto simp: const_sterm_def const_pterm_def app_sterm_def app_pterm_def)

corollary srelated_env_unique:
  "srelated'.P_env penv senv \<Longrightarrow> srelated'.P_env penv senv' \<Longrightarrow> senv = senv'"
apply (subst (asm) fmrel_iff)+
apply (subst (asm) option.rel_sel)+
apply (rule fmap_ext)
by (metis option.exhaust_sel)

lemma srelated_subst':
  assumes "srelated'.P_env penv senv" "wellformed t"
  shows "pterm_to_sterm (subst t penv) = subst (pterm_to_sterm t) senv"
using assms proof (induction t arbitrary: penv senv)
  case (Pvar name)
  thus ?case
    by (cases rule: fmrel_cases[where x = name]) auto
next
  case (Pabs cs)
  hence "is_fmap cs"
    by force

  show ?case
    apply simp
    unfolding map_prod_def id_apply
    apply (subst ordered_fmap_image[symmetric])
     apply fact
    apply (subst fset.map_comp[symmetric])
    apply (subst ordered_fmap_image[symmetric])
    subgoal by (rule is_fmap_image) fact
    apply (subst ordered_fmap_image[symmetric])
     apply fact
    apply auto
    apply (drule ordered_fmap_sound[OF \<open>is_fmap cs\<close>])
    subgoal for pat rhs
      apply (rule Pabs)
         apply (subst (asm) fmember.rep_eq)
         apply assumption
        apply auto
      using Pabs by force+
    done
qed auto

lemma srelated_find_match:
  assumes "find_match cs t = Some (penv, pat, rhs)" "srelated'.P_env penv senv"
  shows "find_match (map (map_prod id pterm_to_sterm) cs) (pterm_to_sterm t) = Some (senv, pat, pterm_to_sterm rhs)"
proof -
  let ?cs' = "map (map_prod id pterm_to_sterm) cs"
  let ?t' = "pterm_to_sterm t"
  have *: "list_all2 (rel_prod (=) (\<lambda>p s. pterm_to_sterm p = s)) cs ?cs'"
    unfolding list.rel_map
    by (auto intro: list.rel_refl)

  obtain senv0
    where "find_match ?cs' ?t' = Some (senv0, pat, pterm_to_sterm rhs)" "srelated'.P_env penv senv0"
    using srelated'.find_match_rel[OF * refl, where t = t, unfolded assms]
    unfolding option_rel_Some1 rel_prod_conv
    by auto
  with assms have "senv = senv0"
    by (metis srelated_env_unique)
  show ?thesis
    unfolding \<open>senv = _\<close> by fact
qed

lemma (in prules) compile_complete:
  assumes "rs \<turnstile>\<^sub>p t \<longrightarrow> t'" "wellformed t"
  shows "compile rs \<turnstile>\<^sub>s pterm_to_sterm t \<longrightarrow> pterm_to_sterm t'"
using assms proof induction
  case (step name rhs)
  then show ?case
    apply simp
    apply rule
    apply (rule prules_as_srules.srewrite_stepI)
    unfolding compile_def
    apply (subst fset_of_list_elem[symmetric])
    apply (subst ordered_fmap_set_eq)
     apply (insert fmap)
     apply (rule is_fmapI)
     apply (force dest: is_fmapD)
    by (simp add: rev_fimage_eqI)
next
  case (beta c cs t t')
  from beta obtain pat rhs penv where "c = (pat, rhs)" "match pat t = Some penv" "subst rhs penv = t'"
    by (metis (no_types, lifting) map_option_eq_Some rewrite_step.simps surj_pair)
  then obtain senv where "match pat (pterm_to_sterm t) = Some senv" "srelated'.P_env penv senv"
    by (metis option_rel_Some1 srelated'.match_rel)
  have "wellformed rhs"
    using beta \<open>c = _\<close> prules.all_rules prule.simps
    by force
  then have "subst (pterm_to_sterm rhs) senv = pterm_to_sterm t'"
    using srelated_subst' \<open>_ = t'\<close> \<open>srelated'.P_env _ _\<close>
    by metis
  have "(pat, pterm_to_sterm rhs) |\<in>| map_prod id pterm_to_sterm |`| cs"
    using beta \<open>c = _\<close>
    by (metis fimage_eqI id_def map_prod_simp)
  have "is_fmap cs"
    using beta
    by auto
  have "find_match (ordered_fmap cs) t = Some (penv, pat, rhs)"
    apply (rule compatible_find_match)
    subgoal
      apply (subst ordered_fmap_set_eq[OF \<open>is_fmap cs\<close>])+
      using beta by simp
    subgoal
      unfolding list_all_iff
      apply rule
      apply (rename_tac x, case_tac x)
      apply simp
      apply (drule ordered_fmap_sound[OF \<open>is_fmap cs\<close>])
      using beta by auto
    subgoal
      apply (subst ordered_fmap_set_eq)
      by fact
    subgoal
      by fact
    subgoal
      using beta(1) \<open>c = _\<close> \<open>is_fmap cs\<close>
      using fset_of_list_elem ordered_fmap_set_eq by fast
    done

  show ?case
    apply simp
    apply rule
    apply (subst \<open>_ = pterm_to_sterm t'\<close>[symmetric])
    apply (rule find_match_rewrite_first)
    unfolding map_prod_def id_apply
    apply (subst ordered_fmap_image[symmetric])
     apply fact
    apply (subst map_prod_def[symmetric])
    apply (subst id_def[symmetric])
    apply (rule srelated_find_match)
    by fact+
qed (auto intro: srewrite.intros)

subsubsection \<open>Computability\<close>

export_code compile
  checking Scala

end