(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Step_Sim
  imports Weak_Late_Step_Semantics Weak_Late_Sim Strong_Late_Sim
begin

definition weakStepSimAct :: "pi \<Rightarrow> residual \<Rightarrow> ('a::fs_name) \<Rightarrow> (pi \<times> pi) set \<Rightarrow> bool" where
  "weakStepSimAct P Rs C Rel \<equiv> (\<forall>Q' a x. Rs = a<\<nu>x> \<prec> Q' \<longrightarrow> x \<sharp> C \<longrightarrow> (\<exists>P' . P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel)) \<and>
                           (\<forall>Q' a x. Rs = a<x> \<prec> Q' \<longrightarrow> x \<sharp> C \<longrightarrow> (\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel)) \<and>
                           (\<forall>Q' \<alpha>. Rs = \<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel))"

definition weakStepSimAux :: "pi \<Rightarrow> (pi \<times> pi) set \<Rightarrow> pi \<Rightarrow> bool" where
  "weakStepSimAux P Rel Q \<equiv> (\<forall>Q' a x. (Q \<longmapsto>a<\<nu>x> \<prec> Q' \<and> x \<sharp> P) \<longrightarrow> (\<exists>P' . P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel)) \<and>
                           (\<forall>Q' a x. (Q \<longmapsto>a<x> \<prec> Q'  \<and> x \<sharp> P) \<longrightarrow> (\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel)) \<and>
                           (\<forall>Q' \<alpha>. Q \<longmapsto>\<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel))"

definition weakStepSim :: "pi \<Rightarrow> (pi \<times> pi) set \<Rightarrow> pi \<Rightarrow> bool" ("_ \<leadsto><_> _" [80, 80, 80] 80) where
  "P \<leadsto><Rel> Q \<equiv> (\<forall>Rs. Q \<longmapsto> Rs \<longrightarrow> weakStepSimAct P Rs P Rel)"

lemmas weakStepSimDef = weakStepSimAct_def weakStepSim_def
lemma "weakStepSimAux P Rel Q = weakStepSim P Rel Q"
by(auto simp add: weakStepSimDef weakStepSimAux_def)

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

  shows "P \<leadsto><B> P'"
using assms
apply(auto simp add: weakStepSimDef)
apply blast
apply(erule_tac x="a<x> \<prec> Q'" in allE)
apply(clarsimp)
apply(rotate_tac 4)
apply(erule_tac x=Q' in allE)
apply(erule_tac x=a in allE)
apply(erule_tac x=x in allE)
by blast+

  assumes Eqvt:  "eqvt Rel"
  and     Bound: "\<And>Q' a x. \<lbrakk>x \<sharp> C; Q \<longmapsto>a<\<nu>x> \<prec> Q'\<rbrakk> \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and     Input: "\<And>Q' a x. \<lbrakk>x \<sharp> C; Q \<longmapsto>a<x> \<prec> Q'\<rbrakk> \<Longrightarrow> \<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
  and     Free:  "\<And>Q' \<alpha>. Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sub>l \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel)"

  shows "P \<leadsto><Rel> Q"
using Free
proof(auto simp add: weakStepSimDef)
  fix Q' a x
  assume xFreshP: "(x::name) \<sharp> P"
  assume Trans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'"
  have "\<exists>c::name. c \<sharp> (P, Q', x, C)" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP: "c \<sharp> P" and cFreshQ': "c \<sharp> Q'" and cFreshC: "c \<sharp> C"
                        and cineqx: "c \<noteq> x"
    by(force simp add: fresh_prod)

  from Trans cFreshQ' have "Q \<longmapsto> a<\<nu>c> \<prec> ([(x, c)] \<bullet> Q')" by(simp add: alphaBoundResidual)
  with cFreshC have "\<exists>P'. P \<Longrightarrow>\<^sub>l a<\<nu>c> \<prec> P' \<and> (P', [(x, c)] \<bullet> Q') \<in> Rel"
    by(rule Bound)
  then obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l a<\<nu>c> \<prec> P'" and P'RelQ': "(P', [(x, c)] \<bullet> Q') \<in> Rel"
    by blast

  from PTrans xFreshP cineqx have xFreshP': "x \<sharp> P'" by(force dest: Weak_Late_Step_Semantics.freshTransition)
  with PTrans have "P \<Longrightarrow>\<^sub>l a<\<nu>x> \<prec> ([(x, c)] \<bullet> P')" by(simp add: alphaBoundResidual name_swap)
  moreover have "([(x, c)] \<bullet> P', Q') \<in> Rel" (is "?goal")
  proof -
    from Eqvt P'RelQ' have "([(x, c)] \<bullet> P', [(x, c)] \<bullet> [(x, c)] \<bullet> Q') \<in> Rel"
      by(rule eqvtRelI)
    with cineqx show ?goal by(simp add: name_calc)
  qed
  ultimately show "\<exists>P'. P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel" by blast
next
  fix Q' a x u
  assume QTrans: "Q \<longmapsto>a<x> \<prec> (Q'::pi)"
     and xFreshP: "x \<sharp> P"

  have "\<exists>c::name. c \<sharp> (P, Q', C, x)" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP: "c \<sharp> P" and cFreshQ': "c \<sharp> Q'" and cFreshC: "c \<sharp> C"
                        and cineqx: "c \<noteq> x"
    by(force simp add: fresh_prod)

  from QTrans cFreshQ' have "Q \<longmapsto>a<c> \<prec> ([(x, c)] \<bullet> Q')" by(simp add: alphaBoundResidual)
  with cFreshC have "\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<c> \<prec> P' \<and> (P', ([(x, c)] \<bullet> Q')[c::=u]) \<in> Rel"
    by(rule Input)

  then obtain P'' where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<c> \<prec> P' \<and> (P', ([(x, c)] \<bullet> Q')[c::=u]) \<in> Rel" by blast

  have "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in ([(c, x)] \<bullet> P'')\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
  proof(auto)
    fix u
    from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<c> \<prec> P'" and P'RelQ': "(P', ([(x, c)] \<bullet> Q')[c::=u]) \<in> Rel"
      by blast

    from PTrans xFreshP have "P \<Longrightarrow>\<^sub>lu in ([(c, x)] \<bullet> P'')\<rightarrow>a<x> \<prec> P'" by(rule alphaInput)
    moreover from P'RelQ' cFreshQ' have "(P', Q'[x::=u]) \<in> Rel" by(simp add: renaming[THEN sym] name_swap)

    ultimately show "\<exists>P'. P \<Longrightarrow>\<^sub>lu in ([(c, x)] \<bullet> P'')\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel" by blast
  qed

  thus "\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel" by blast
qed

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

  assumes Bound: "\<And>Q' a x. \<lbrakk>Q \<longmapsto>a<\<nu>x> \<prec> Q'; x \<sharp> P\<rbrakk> \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and     Input: "\<And>Q' a x. \<lbrakk>Q \<longmapsto>a<x> \<prec> Q'; x \<sharp> P\<rbrakk> \<Longrightarrow> \<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
  and     Free:  "\<And>Q' \<alpha>. Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sub>l \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel)"

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

lemma simActBoundCases[consumes 1, case_names Input BoundOutput]:
  fixes P   :: pi
  and   a   :: subject
  and   x   :: name
  and   Q'  :: pi
  and   C   :: "'a::fs_name"
  and   Rel :: "(pi \<times> pi) set"

  assumes EqvtRel: "eqvt Rel"
  and     DerInput: "\<And>b. a = InputS b \<Longrightarrow> (\<exists>P''. \<forall>u. \<exists>P'. (P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>b<x> \<prec> P') \<and> (P', Q'[x::=u]) \<in> Rel)"
  and     DerBoundOutput: "\<And>b. a = BoundOutputS b \<Longrightarrow> (\<exists>P'. (P \<Longrightarrow>\<^sub>lb<\<nu>x> \<prec> P') \<and> (P', Q') \<in> Rel)"

  shows "weakStepSimAct P (a\<guillemotleft>x\<guillemotright> \<prec> Q') P Rel"
proof(simp add: weakStepSimAct_def fresh_prod, auto)
  fix Q'' b y
  assume Eq: "a\<guillemotleft>x\<guillemotright> \<prec> Q' = b<\<nu>y> \<prec> Q''"
  assume yFreshP: "y \<sharp> P"

  from Eq have "a = BoundOutputS b" by(simp add: residual.inject)

  from yFreshP DerBoundOutput[OF this] Eq show "\<exists>P'. P \<Longrightarrow>\<^sub>lb<\<nu>y> \<prec> P' \<and> (P', Q'') \<in> Rel"
  proof(cases "x=y", auto simp add: residual.inject name_abs_eq)
    fix P'
    assume PTrans: "P \<Longrightarrow>\<^sub>lb<\<nu>x> \<prec> P'"
    assume P'RelQ': "(P', ([(x, y)] \<bullet> Q'')) \<in> Rel"
    assume xineqy: "x \<noteq> y"

    with PTrans yFreshP have yFreshP': "y \<sharp> P'"
      by(force intro: Weak_Late_Step_Semantics.freshTransition)

    hence "b<\<nu>x> \<prec> P' = b<\<nu>y> \<prec> [(x, y)] \<bullet> P'" by(rule alphaBoundResidual)
    moreover have "([(x, y)] \<bullet> P', Q'') \<in> Rel"
    proof -
      from EqvtRel P'RelQ' have "([(x, y)] \<bullet> P', [(x, y)] \<bullet> ([(x, y)] \<bullet> Q''))\<in> Rel"
        by(rule eqvtRelI)
      thus ?thesis by(simp add: name_calc)
    qed

    ultimately show "\<exists>P'. P \<Longrightarrow>\<^sub>lb<\<nu>y> \<prec> P' \<and> (P', Q'') \<in> Rel" using PTrans by auto
  qed
next
  fix Q'' b y u
  assume Eq: "a\<guillemotleft>x\<guillemotright> \<prec> Q' = b<y> \<prec> Q''"
  assume yFreshP: "y \<sharp> P"

  from Eq have "a = InputS b" by(simp add: residual.inject)
  from DerInput[OF this] obtain P'' where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>b<x> \<prec> P' \<and>
                                                        (P', Q'[x::=u]) \<in> Rel"
    by blast
  have "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P'')\<rightarrow>b<y> \<prec> P' \<and> (P', Q''[y::=u]) \<in> Rel"
  proof(rule allI)
    fix u
    from L1 Eq show "\<exists>P'. P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P'')\<rightarrow>b<y> \<prec> P' \<and> (P', Q''[y::=u]) \<in> Rel"
    proof(cases "x=y", auto simp add: residual.inject name_abs_eq)
      assume Der: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>b<x> \<prec> P' \<and> (P', ([(x, y)] \<bullet> Q'')[x::=u]) \<in> Rel"
      assume xFreshQ'': "x \<sharp> Q''"

      from Der obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>b<x> \<prec> P'"
                          and P'RelQ': "(P', ([(x, y)] \<bullet> Q'')[x::=u]) \<in> Rel"
        by force

      from PTrans yFreshP have "P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P'')\<rightarrow>b<y> \<prec> P'" by(rule alphaInput)
      moreover from xFreshQ'' P'RelQ' have "(P', Q''[y::=u]) \<in> Rel"
        by(simp add: renaming)
      ultimately show ?thesis by force
    qed
  qed
  thus  "\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>b<y> \<prec> P' \<and> (P', Q''[y::=u]) \<in> Rel"
    by blast
qed

lemma simActFreeCases[consumes 0, case_names Free]:
  fixes P   :: pi
  and   \<alpha>   :: freeRes
  and   C   :: "'a::fs_name"
  and   Rel :: "(pi \<times> pi) set"

  assumes Der: "\<exists>P'. (P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P') \<and> (P', Q') \<in> Rel"

  shows "weakStepSimAct P (\<alpha> \<prec> Q') P Rel"
using assms
by(simp add: weakStepSimAct_def residual.inject)

lemma simE:
  fixes P   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   Q   :: pi
  and   a   :: name
  and   x   :: name
  and   u   :: 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>\<^sub>la<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and   "Q \<longmapsto>a<x> \<prec> Q' \<Longrightarrow> x \<sharp> P \<Longrightarrow> \<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
  and   "Q \<longmapsto>\<alpha> \<prec> Q' \<Longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel)"
using assms by(simp add: weakStepSimDef)+

lemma weakSimTauChain:
  fixes P   :: pi
  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     Sim: "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> P \<leadsto><Rel> Q"

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

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

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

  shows "P \<leadsto><Rel> Q"
proof(auto simp add: weakStepSimDef)
  fix Q' a x
  assume "Q \<longmapsto>a<\<nu>x> \<prec> Q'" and "x \<sharp> P"
  with PSimQ have "\<exists>P'. P \<longmapsto>a<\<nu>x> \<prec> P' \<and> derivative P' Q' (BoundOutputS a) x Rel"
    by(rule Strong_Late_Sim.simE)
  then obtain P' where PTrans: "P \<longmapsto>a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
    by(force simp add: derivative_def)

  from PTrans have "P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'" by(rule Weak_Late_Step_Semantics.singleActionChain)
  thus "\<exists>P'. P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel" using P'RelQ' by blast
next
  fix Q' a x u
  assume "Q \<longmapsto>a<x> \<prec> Q'" and "x \<sharp> P"
  with PSimQ have L1: "\<exists>P'. P \<longmapsto>a<x> \<prec> P' \<and> derivative P' Q' (InputS a) x Rel"
    by(blast intro: Strong_Late_Sim.simE)
  then obtain P' where PTrans: "P \<longmapsto>a<x> \<prec> P'" and PDer: "derivative P' Q' (InputS a) x Rel"
    by blast

  have "\<forall>u. \<exists>P''. P \<Longrightarrow>\<^sub>lu in P'\<rightarrow>a<x> \<prec> P'' \<and> (P'', Q'[x::=u]) \<in> Rel"
  proof(rule allI)
    fix u
    from PTrans have "P \<Longrightarrow>\<^sub>lu in P'\<rightarrow>a<x> \<prec> P'[x::=u]" by(blast intro: Weak_Late_Step_Semantics.singleActionChain)
    moreover from PDer have "(P'[x::=u], Q'[x::=u]) \<in> Rel" by(force simp add: derivative_def)
    ultimately show "\<exists>P''. P \<Longrightarrow>\<^sub>lu in P'\<rightarrow>a<x> \<prec> P'' \<and> (P'', Q'[x::=u]) \<in> Rel" by auto
  qed
  thus "\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel" by blast
next
  fix Q' \<alpha>
  assume "Q \<longmapsto>\<alpha> \<prec> Q'"
  with PSimQ have "\<exists>P'. P \<longmapsto>\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel" by(rule Strong_Late_Sim.simE)
  then obtain P' where PTrans: "P \<longmapsto>\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel" by blast

  from PTrans have "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" by(rule Weak_Late_Step_Semantics.singleActionChain)
  thus "\<exists>P'. P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel" using P'RelQ' by blast
qed

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

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

  shows "P \<leadsto>\<^sup>^<Rel> Q"
using assms
by(force simp add: weakStepSimDef simDef weakTransition_def)

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

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

  shows "(perm \<bullet> P) \<leadsto><Rel'> (perm \<bullet> Q)"
using EqvtRel'
proof(induct rule: simCasesCont[of _ "perm \<bullet> P"])
  case(Bound Q' a x)
  have QTrans: "(perm \<bullet> Q) \<longmapsto> a<\<nu>x> \<prec> Q'" by fact
  have xFreshP: "x \<sharp> perm \<bullet> P" by fact

  from QTrans have "(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>\<^sub>l (rev perm \<bullet> a)<\<nu>(rev perm \<bullet> x)> \<prec> P'"
                         and P'RelQ': "(P', rev perm \<bullet> Q') \<in> Rel" using Sim
    by(blast dest: simE)

  from PTrans have "(perm \<bullet> P) \<Longrightarrow>\<^sub>l perm \<bullet> ((rev perm \<bullet> a)<\<nu>(rev perm \<bullet> x)> \<prec> P')"
    by(rule Weak_Late_Step_Semantics.eqvtI)
  hence "(perm \<bullet> P) \<Longrightarrow>\<^sub>l a<\<nu>x> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
  moreover have "(perm \<bullet> P', Q') \<in> Rel'"
  proof -
    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)
    thus ?thesis by(simp add: name_per_rev)
  qed
  ultimately show ?case by blast
next
  case(Input Q' a x)
  have QTrans: "(perm \<bullet> Q) \<longmapsto>a<x> \<prec> Q'" by fact
  have xFreshP: "x \<sharp> perm \<bullet> P" by fact

  from QTrans have "(rev perm \<bullet> (perm \<bullet> Q)) \<longmapsto> rev perm \<bullet> (a<x> \<prec> Q')"
    by(rule eqvts)
  hence "Q \<longmapsto> (rev perm \<bullet> a)<(rev perm \<bullet> x)> \<prec> (rev perm \<bullet> Q')"
    by(simp add: name_rev_per)
  moreover from xFreshP have xFreshP: "(rev perm \<bullet> x) \<sharp> P" by(simp add: name_fresh_left)
  ultimately obtain P''
    where L1:  "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>(rev perm \<bullet> a)<(rev perm \<bullet> x)> \<prec> P' \<and>
                         (P', (rev perm \<bullet> Q')[(rev perm \<bullet> x)::=u]) \<in> Rel" using Sim
    by(blast dest: simE)
  have "\<forall>u. \<exists>P'. (perm \<bullet> P) \<Longrightarrow>\<^sub>lu in (perm \<bullet> P'')\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
  proof(rule allI)
    fix u
    from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l(rev perm \<bullet> u) in P''\<rightarrow>(rev perm \<bullet> a)<(rev perm \<bullet> x)> \<prec> P'"
                        and P'RelQ': "(P', (rev perm \<bullet> Q')[(rev perm \<bullet> x)::=(rev perm \<bullet> u)]) \<in> Rel" by blast
    from PTrans have "(perm \<bullet> P) \<Longrightarrow>\<^sub>l(perm \<bullet> (rev perm \<bullet> u)) in (perm \<bullet> P'')\<rightarrow>(perm \<bullet> rev perm \<bullet> a)<(perm \<bullet> rev perm \<bullet> x)> \<prec> (perm \<bullet> P')"
      by(rule_tac Weak_Late_Step_Semantics.eqvtI, auto)
    hence "(perm \<bullet> P) \<Longrightarrow>\<^sub>lu in (perm \<bullet> P'')\<rightarrow>a<x> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
    moreover have "(perm \<bullet> P', Q'[x::=u]) \<in> Rel'"
    proof -
      from P'RelQ' RelRel' have "(P', (rev perm \<bullet> Q')[(rev perm \<bullet> x)::=(rev perm \<bullet> u)]) \<in> Rel'" by blast
      with EqvtRel' have "(perm \<bullet> P', perm \<bullet> ((rev perm \<bullet> Q')[(rev perm \<bullet> x)::=(rev perm \<bullet> u)])) \<in> Rel'"
        by(rule eqvtRelI)
      thus ?thesis by(simp add: name_per_rev eqvt_subs[THEN sym] name_calc)
    qed
    ultimately show "\<exists>P'. (perm \<bullet> P) \<Longrightarrow>\<^sub>lu in (perm \<bullet> P'')\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'" by blast
  qed
  thus ?case by blast
next
  case(Free Q' \<alpha>)
  have QTrans: "(perm \<bullet> Q) \<longmapsto> \<alpha> \<prec> Q'" by fact

  from QTrans have "(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 Sim obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l (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>\<^sub>l perm \<bullet> ((rev perm \<bullet> \<alpha>)\<prec> P')"
    by(rule Weak_Late_Step_Semantics.eqvtI)
  hence "(perm \<bullet> P) \<Longrightarrow>\<^sub>l \<alpha> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
  moreover have "((perm \<bullet> P'), Q') \<in> Rel'"
  proof -
    from PRel EqvtRel' RelRel'  have "((perm \<bullet> P'), (perm \<bullet> (rev perm \<bullet> Q'))) \<in> Rel'"
      by(force intro: eqvtRelI)
    thus ?thesis by(simp add: name_per_rev)
  qed
  ultimately show ?case by blast
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 PSimQ: "P \<leadsto><Rel> Q"
  and     Sim: "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> P \<leadsto>\<^sup>^<Rel> Q"
  and     Eqvt: "eqvt Rel"
  and     PRelQ: "(P, Q) \<in> Rel"

  shows "Q \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> Q' \<Longrightarrow> x \<sharp> P \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and   "Q \<Longrightarrow>\<^sub>l\<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
proof -
  assume QTrans: "Q \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> Q'"
  assume xFreshP: "x \<sharp> P"
  have Goal: "\<And>P Q a x Q'. \<lbrakk>P \<leadsto><Rel> Q; Q \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> Q'; x \<sharp> P; x \<sharp> Q; (P, Q) \<in> Rel\<rbrakk> \<Longrightarrow>
                            \<exists>P'. P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  proof -
    fix P Q a x Q'
    assume PSimQ: "P \<leadsto><Rel> Q"
    assume QTrans: "Q \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> Q'"
    assume xFreshP: "x \<sharp> P"
    assume xFreshQ: "x \<sharp> Q"
    assume PRelQ: "(P, Q) \<in> Rel"

    from QTrans xFreshQ 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(force dest: transitionE simp add: weakTransition_def)

    from QChain PRelQ Sim have "\<exists>P''. P \<Longrightarrow>\<^sub>\<tau> P'' \<and> (P'', Q'') \<in> Rel"
      by(rule Weak_Late_Sim.weakSimTauChain)
    then obtain P'' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P''" and P''RelQ'': "(P'', Q'') \<in> Rel" by blast
    from PChain xFreshP have xFreshP'': "x \<sharp> P''" by(rule freshChain)

    from P''RelQ'' have "P'' \<leadsto>\<^sup>^<Rel> Q''" by(rule Sim)
    hence "\<exists>P'''. P'' \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P''' \<and> (P''', Q''') \<in> Rel" using Q''Trans xFreshP''
      by(rule Weak_Late_Sim.simE)
    then obtain P''' where P''Trans: "P'' \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'''" and P'''RelQ''': "(P''', Q''') \<in> Rel"
      by(force simp add: weakTransition_def)

    have "\<exists>P'. P''' \<Longrightarrow>\<^sub>\<tau> P' \<and> (P', Q') \<in> Rel" using Q'''Chain P'''RelQ''' Sim
      by(rule Weak_Late_Sim.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 xFreshP'' have "P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'"
      by(blast dest: Weak_Late_Step_Semantics.chainTransitionAppend)
    with P'RelQ' show "\<exists>P'. P \<Longrightarrow>\<^sub>l a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel" by blast
  qed

  have "\<exists>c::name. c \<sharp> (Q, Q', P, x)" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshQ: "c \<sharp> Q" and cFreshQ': "c \<sharp> Q'" and cFreshP: "c \<sharp> P"
                        and xineqc: "x \<noteq> c"
    by(force simp add: fresh_prod)

  from QTrans cFreshQ' have "Q \<Longrightarrow>\<^sub>la<\<nu>c> \<prec> ([(x, c)] \<bullet> Q')" by(simp add: alphaBoundResidual)
  with PSimQ have "\<exists>P'. P \<Longrightarrow>\<^sub>la<\<nu>c> \<prec> P' \<and> (P', [(x, c)] \<bullet> Q') \<in> Rel" using cFreshP cFreshQ PRelQ
    by(rule Goal)
  then obtain P' where PTrans: "P \<Longrightarrow>\<^sub>la<\<nu>c> \<prec> P'" and P'RelQ': "(P', [(x, c)] \<bullet> Q') \<in> Rel"
    by force
  have "P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> ([(x, c)] \<bullet> P')"
  proof -
    from PTrans xFreshP xineqc have "x \<sharp> P'" by(rule Weak_Late_Step_Semantics.freshTransition)
    with PTrans show ?thesis by(simp add: alphaBoundResidual name_swap)
  qed
  moreover have "([(x, c)] \<bullet> P', Q') \<in> Rel"
  proof -
    from Eqvt P'RelQ' have "([(x, c)] \<bullet> P', [(x, c)] \<bullet> [(x, c)] \<bullet> Q') \<in> Rel"
      by(rule eqvtRelI)
    thus ?thesis by simp
  qed

  ultimately show "\<exists>P'. P \<Longrightarrow>\<^sub>l a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel" by blast
next
  assume QTrans: "Q \<Longrightarrow>\<^sub>l\<alpha> \<prec> Q'"

  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)

  thus "\<exists>P'. P \<Longrightarrow>\<^sub>l \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
  proof(induct arbitrary: \<alpha> Q''' Q' rule: tauChainInduct)
    case(id \<alpha> Q''')
    from PSimQ \<open>Q \<longmapsto>\<alpha> \<prec> Q'''\<close> have "\<exists>P'. P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P' \<and> (P', Q''') \<in> Rel"
      by(blast dest: simE)
    then obtain P''' where PTrans: "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'''" and P'RelQ''': "(P''', Q''') \<in> Rel"
      by blast

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

    from P'''Chain PTrans have "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'"
      by(blast dest: Weak_Late_Step_Semantics.chainTransitionAppend)

    with P'RelQ' show ?case by blast
  next
    case(ih Q'''' Q''' \<alpha> Q'' Q')
    have "Q''' \<Longrightarrow>\<^sub>\<tau> Q'''" by simp
    with \<open>Q'''' \<longmapsto>\<tau> \<prec> Q'''\<close> obtain P''' where PTrans: "P \<Longrightarrow>\<^sub>l\<tau> \<prec> P'''" and P'''RelQ''': "(P''', Q''') \<in> Rel"
      by(drule_tac ih) auto
    from P'''RelQ''' \<open>Q''' \<longmapsto>\<alpha> \<prec> Q''\<close> obtain P'' where
      P'''Trans: "P''' \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P''" and P''RelQ'': "(P'', Q'') \<in> Rel"
      by(blast dest: Weak_Late_Sim.simE Sim)
    from P''RelQ'' \<open>Q'' \<Longrightarrow>\<^sub>\<tau> Q'\<close> Sim obtain P' where
      P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'" and P'RelQ': "(P', Q')\<in> Rel"
      by(drule_tac Weak_Late_Sim.weakSimTauChain) auto

    from PTrans P'''Trans P''Chain have "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'"
      apply(auto simp add: weakTransition_def residual.inject)
      apply(drule_tac Weak_Late_Step_Semantics.tauTransitionChain, auto)
      apply(drule_tac Weak_Late_Step_Semantics.chainTransitionAppend, simp)
      apply(rule Weak_Late_Step_Semantics.chainTransitionAppend, auto)
      by(drule_tac Weak_Late_Step_Semantics.chainTransitionAppend, auto)
    with \<open>(P', Q') \<in> Rel\<close> show ?case by blast
  qed
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_Late_Step_Semantics.singleActionChain simp add: weakStepSimDef)

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

  shows "P \<leadsto><Rel''> R"
using Eqvt'
proof(induct rule: simCasesCont[of _ "(P, Q)"])
  case(Bound R' a x)
  have RTrans: "R \<longmapsto> a<\<nu>x> \<prec> R'" by fact
  have "x \<sharp> (P, Q)" by fact
  hence xFreshP: "x \<sharp> P" and xFreshQ: "x \<sharp> Q" by(simp add: fresh_prod)+

  from QSimR RTrans xFreshQ obtain Q' where QTrans: "Q \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> Q'"
                                        and Q'RelR': "(Q', R') \<in> Rel'"
    by(blast dest: simE)
  from PSimQ Sim Eqvt PRelQ QTrans xFreshP obtain P' where PTrans: "P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec> P'"
                                                       and P'RelQ': "(P', Q') \<in> Rel"
    by(blast dest: simE2)
  moreover from P'RelQ' Q'RelR' Trans have "(P', R') \<in> Rel''" by blast
  ultimately show ?case by blast
next
  case(Input R' a x)
  have RTrans: "R \<longmapsto> a<x> \<prec> R'" by fact
  have "x \<sharp> (P, Q)" by fact
  hence xFreshP: "x \<sharp> P" and xFreshQ: "x \<sharp> Q" by(simp add: fresh_prod)+

  from QSimR RTrans xFreshQ obtain Q''
    where "\<forall>u. \<exists>Q'. Q \<Longrightarrow>\<^sub>lu in Q''\<rightarrow>a<x> \<prec> Q' \<and> (Q', R'[x::=u]) \<in> Rel'"
    by(blast dest: simE)
  hence "\<exists>Q'''. Q \<Longrightarrow>\<^sub>\<tau> Q''' \<and> Q'''\<longmapsto>a<x> \<prec> Q'' \<and> (\<forall>u. \<exists>Q'. Q''[x::=u]\<Longrightarrow>\<^sub>\<tau> Q' \<and> (Q', R'[x::=u]) \<in> Rel')"
    by(simp add: inputTransition_def, blast)
  then obtain Q''' where QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q'''"
                     and Q'''Trans: "Q''' \<longmapsto>a<x> \<prec> Q''"
                     and L1: "\<forall>u. \<exists>Q'. Q''[x::=u]\<Longrightarrow>\<^sub>\<tau> Q' \<and> (Q', R'[x::=u]) \<in> Rel'"
    by blast
  from QChain PRelQ Sim obtain P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''" and P'''RelQ''': "(P''', Q''') \<in> Rel"
    by(drule_tac Weak_Late_Sim.weakSimTauChain) auto
  from PChain xFreshP have xFreshP''': "x \<sharp> P'''" by(rule freshChain)
  from P'''RelQ''' have "P''' \<leadsto>\<^sup>^<Rel> Q'''" by(rule Sim)
  with xFreshP''' Q'''Trans obtain P'''' where L2: "\<forall>u. \<exists>P''. P''' \<Longrightarrow>\<^sub>lu in P''''\<rightarrow>a<x> \<prec> P'' \<and> (P'', Q''[x::=u]) \<in> Rel"
    by(blast dest: Weak_Late_Sim.simE)
  have "\<forall>u. \<exists>P' Q'. P \<Longrightarrow>\<^sub>lu in P''''\<rightarrow>a<x> \<prec> P' \<and> (P', R'[x::=u]) \<in> Rel''"
  proof(rule allI)
    fix u
    from L1 obtain Q' where Q''Chain: "Q''[x::=u] \<Longrightarrow>\<^sub>\<tau> Q'" and Q'RelR': "(Q', R'[x::=u]) \<in> Rel'"
      by blast
    from L2 obtain P'' where P'''Trans: "P''' \<Longrightarrow>\<^sub>lu in P''''\<rightarrow>a<x> \<prec> P''"
                         and P''RelQ'': "(P'', Q''[x::=u]) \<in> Rel"
      by blast
    from P''RelQ'' have "P'' \<leadsto>\<^sup>^<Rel> Q''[x::=u]" by(rule Sim)
    have "\<exists>P'. P'' \<Longrightarrow>\<^sub>\<tau> P' \<and> (P', Q') \<in> Rel" using Q''Chain P''RelQ'' Sim
      by(rule Weak_Late_Sim.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>\<^sub>lu in P''''\<rightarrow>a<x> \<prec> P'"
      by(blast dest: Weak_Late_Step_Semantics.chainTransitionAppend)
    moreover from P'RelQ' Q'RelR' have "(P', R'[x::=u]) \<in> Rel''" by(insert Trans, auto)
    ultimately show "\<exists>P' Q'. P \<Longrightarrow>\<^sub>lu in P''''\<rightarrow>a<x> \<prec> P' \<and> (P', R'[x::=u]) \<in> Rel''" by blast
  qed
  thus ?case by force
next
  case(Free R' \<alpha>)
  have RTrans: "R \<longmapsto> \<alpha> \<prec> R'" by fact
  with QSimR obtain Q' where QTrans: "Q \<Longrightarrow>\<^sub>l\<alpha> \<prec> Q'" and Q'RelR': "(Q', R') \<in> Rel'"
    by(blast dest: simE)
  from PSimQ Sim Eqvt PRelQ QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'"
                                               and P'RelQ': "(P', Q') \<in> Rel"
    by(blast dest: simE2)
  from P'RelQ' Q'RelR' Trans have "(P', R') \<in> Rel''" by blast
  with PTrans show ?case by blast
qed

end


section \<open>Soundness\<close>

theory Soundness
  imports ProverLemmas
begin

text \<open>In this theory, we prove that the prover is sound with regards to the SeCaV proof system
  using the abstract soundness framework.\<close>

text \<open>If some suffix of the sequents in all of the children of a state are provable, so is some
  suffix of the sequent in the current state, with the prefix in each sequent being the same.
  (As a side condition, the lists of terms need to be compatible.)\<close>
lemma SeCaV_children_pre:
  assumes \<open>\<forall>z' \<in> set (children A r z). (\<tturnstile> pre @ z')\<close>
    and \<open>paramss (pre @ z) \<subseteq> paramsts A\<close>
  shows \<open>\<tturnstile> pre @ z\<close>
  using assms
proof (induct z arbitrary: pre A)
  case Nil
  then show ?case
    by simp
next
  case (Cons p z)
  then have ih: \<open>\<forall>z' \<in> set (children A r z). (\<tturnstile> pre @ z') \<Longrightarrow> (\<tturnstile> pre @ z)\<close>
    if \<open>paramss (pre @ z) \<subseteq> paramsts A\<close> for pre A
    using that by simp

  let ?A = \<open>remdups (A @ subtermFms (concat (parts A r p)))\<close>

  have A: \<open>paramss (pre @ p # z) \<subseteq> paramsts ?A\<close>
    using paramsts_subset Cons.prems(2) by fastforce

  have \<open>\<forall>z' \<in> set (list_prod (parts A r p) (children ?A r z)). (\<tturnstile> pre @ z')\<close>
    using Cons.prems by (metis children.simps(2))
  then have \<open>\<forall>z' \<in> {hs @ ts |hs ts. hs \<in> set (parts A r p) \<and> ts \<in> set (children ?A r z)}.
      (\<tturnstile> pre @ z')\<close>
    using list_prod_is_cartesian by blast
  then have *:
    \<open>\<forall>hs \<in> set (parts A r p). \<forall>ts \<in> set (children ?A r z). (\<tturnstile> pre @ hs @ ts)\<close>
    by blast
  then show ?case
  proof (cases r p rule: parts_exhaust)
    case (AlphaDis p q)
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ p # q # z')\<close>
      using * unfolding parts_def by simp
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [p, q]) @ z')\<close>
      by simp
    then have \<open>\<tturnstile> pre @ p # q # z\<close>
      using AlphaDis ih[where pre=\<open>pre @ [p, q]\<close> and A=\<open>?A\<close>] A by simp
    then have \<open>\<tturnstile> p # q # pre @ z\<close>
      using Ext by simp
    then have \<open>\<tturnstile> Dis p q # pre @ z\<close>
      using SeCaV.AlphaDis by blast
    then show ?thesis
      using AlphaDis Ext by simp
  next
    case (AlphaImp p q)
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg p # q # z')\<close>
      using * unfolding parts_def by simp
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg p, q]) @ z')\<close>
      by simp
    then have \<open>\<tturnstile> pre @ Neg p # q # z\<close>
      using AlphaImp ih[where pre=\<open>pre @ [Neg p, q]\<close> and A=\<open>?A\<close>] A by simp
    then have \<open>\<tturnstile> Neg p # q # pre @ z\<close>
      using Ext by simp
    then have \<open>\<tturnstile> Imp p q # pre @ z\<close>
      using SeCaV.AlphaImp by blast
    then show ?thesis
      using AlphaImp Ext by simp
  next
    case (AlphaCon p q)
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg p # Neg q # z')\<close>
      using * unfolding parts_def by simp
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg p, Neg q]) @ z')\<close>
      by simp
    then have \<open>\<tturnstile> pre @ Neg p # Neg q # z\<close>
      using AlphaCon ih[where pre=\<open>pre @ [Neg p, Neg q]\<close> and A=\<open>?A\<close>] A by simp
    then have \<open>\<tturnstile> Neg p # Neg q # pre @ z\<close>
      using Ext by simp
    then have \<open>\<tturnstile> Neg (Con p q) # pre @ z\<close>
      using SeCaV.AlphaCon by blast
    then show ?thesis
      using AlphaCon Ext by simp
  next
    case (BetaCon p q)
    then have
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ p # z')\<close>
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ q # z')\<close>
      using * unfolding parts_def by simp_all
    then have
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [p]) @ z')\<close>
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [q]) @ z')\<close>
      by simp_all
    then have \<open>\<tturnstile> pre @ p # z\<close> \<open>\<tturnstile> pre @ q # z\<close>
      using BetaCon ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp_all
    then have \<open>\<tturnstile> p # pre @ z\<close> \<open>\<tturnstile> q # pre @ z\<close>
      using Ext by simp_all
    then have \<open>\<tturnstile> Con p q # pre @ z\<close>
      using SeCaV.BetaCon by blast
    then show ?thesis
      using BetaCon Ext by simp
  next
    case (BetaImp p q)
    then have
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ p # z')\<close>
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg q # z')\<close>
      using * unfolding parts_def by simp_all
    then have
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [p]) @ z')\<close>
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg q]) @ z')\<close>
      by simp_all
    then have \<open>\<tturnstile> pre @ p # z\<close> \<open>\<tturnstile> pre @ Neg q # z\<close>
      using BetaImp ih ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp_all
    then have \<open>\<tturnstile> p # pre @ z\<close> \<open>\<tturnstile> Neg q # pre @ z\<close>
      using Ext by simp_all
    then have \<open>\<tturnstile> Neg (Imp p q) # pre @ z\<close>
      using SeCaV.BetaImp by blast
    then show ?thesis
      using BetaImp Ext by simp
  next
    case (BetaDis p q)
    then have
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg p # z')\<close>
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg q # z')\<close>
      using * unfolding parts_def by simp_all
    then have
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg p]) @ z')\<close>
      \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg q]) @ z')\<close>
      by simp_all
    then have \<open>\<tturnstile> pre @ Neg p # z\<close> \<open>\<tturnstile> pre @ Neg q # z\<close>
      using BetaDis ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp_all
    then have \<open>\<tturnstile> Neg p # pre @ z\<close> \<open>\<tturnstile> Neg q # pre @ z\<close>
      using Ext by simp_all
    then have \<open>\<tturnstile> Neg (Dis p q) # pre @ z\<close>
      using SeCaV.BetaDis by blast
    then show ?thesis
      using BetaDis Ext by simp
  next
    case (DeltaUni p)
    let ?i = \<open>generateNew A\<close>
    have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ sub 0 (Fun ?i []) p # z')\<close>
      using DeltaUni * unfolding parts_def by simp
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [sub 0 (Fun ?i []) p]) @ z')\<close>
      by simp
    moreover have \<open>set (subtermFm (sub 0 (Fun ?i []) p)) \<subseteq> set ?A\<close>
      using DeltaUni unfolding parts_def by simp
    then have \<open>params (sub 0 (Fun ?i []) p) \<subseteq> paramsts ?A\<close>
      using subtermFm_subset_params by blast
    ultimately have \<open>\<tturnstile> pre @ sub 0 (Fun ?i []) p # z\<close>
      using DeltaUni ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp
    then have \<open>\<tturnstile> sub 0 (Fun ?i []) p # pre @ z\<close>
      using Ext by simp
    moreover have \<open>?i \<notin> paramsts A\<close>
      by (induct A) (metis Suc_max_new generateNew_def listFunTm_paramst(2) plus_1_eq_Suc)+
    then have \<open>news ?i (p # pre @ z)\<close>
      using DeltaUni Cons.prems(2) news_paramss by auto
    ultimately have \<open>\<tturnstile> Uni p # pre @ z\<close>
      using SeCaV.DeltaUni by blast
    then show ?thesis
      using DeltaUni Ext by simp
  next
    case (DeltaExi p)
    let ?i = \<open>generateNew A\<close>
    have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg (sub 0 (Fun ?i []) p) # z')\<close>
      using DeltaExi * unfolding parts_def by simp
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [Neg (sub 0 (Fun ?i []) p)]) @ z')\<close>
      by simp
    moreover have \<open>set (subtermFm (sub 0 (Fun ?i []) p)) \<subseteq> set ?A\<close>
      using DeltaExi unfolding parts_def by simp
    then have \<open>params (sub 0 (Fun ?i []) p) \<subseteq> paramsts ?A\<close>
      using subtermFm_subset_params by blast
    ultimately have \<open>\<tturnstile> pre @ Neg (sub 0 (Fun ?i []) p) # z\<close>
      using DeltaExi ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp
    then have \<open>\<tturnstile> Neg (sub 0 (Fun ?i []) p) # pre @ z\<close>
      using Ext by simp
    moreover have \<open>?i \<notin> paramsts A\<close>
      by (induct A) (metis Suc_max_new generateNew_def listFunTm_paramst(2) plus_1_eq_Suc)+
    then have \<open>news ?i (p # pre @ z)\<close>
      using DeltaExi Cons.prems(2) news_paramss by auto
   ultimately have \<open>\<tturnstile> Neg (Exi p) # pre @ z\<close>
      using SeCaV.DeltaExi by blast
    then show ?thesis
      using DeltaExi Ext by simp
  next
    case (NegNeg p)
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ p # z')\<close>
      using * unfolding parts_def by simp
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [p]) @ z')\<close>
      by simp
    then have \<open>\<tturnstile> pre @ p # z\<close>
      using NegNeg ih[where pre=\<open>pre @ [_]\<close> and A=\<open>?A\<close>] A by simp
    then have \<open>\<tturnstile> p # pre @ z\<close>
      using Ext by simp
    then have \<open>\<tturnstile> Neg (Neg p) # pre @ z\<close>
      using SeCaV.Neg by blast
    then show ?thesis
      using NegNeg Ext by simp
  next
    case (GammaExi p)
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Exi p # map (\<lambda>t. sub 0 t p) A @ z')\<close>
      using * unfolding parts_def by simp
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> ((pre @ Exi p # map (\<lambda>t. sub 0 t p) A) @ z'))\<close>
      by simp
    moreover have \<open>\<forall>t \<in> set A. params (sub 0 t p) \<subseteq> paramsts A \<union> params p\<close>
      using params_sub by fastforce
    then have \<open>\<forall>t \<in> set A. params (sub 0 t p) \<subseteq> paramsts ?A\<close>
        using GammaExi A by fastforce
    then have \<open>paramss (map (\<lambda>t. sub 0 t p) A) \<subseteq> paramsts ?A\<close>
      by auto
    ultimately have \<open>\<tturnstile> pre @ Exi p # map (\<lambda>t. sub 0 t p) A @ z\<close>
      using GammaExi ih[where pre=\<open>pre @ Exi p # map _ A\<close> and A=\<open>?A\<close>] A by simp
    moreover have \<open>ext (map (\<lambda>t. sub 0 t p) A @ Exi p # pre @ z)
          (pre @ Exi p # map (\<lambda>t. sub 0 t p) A @ z)\<close>
      by auto
    ultimately have \<open>\<tturnstile> map (\<lambda>t. sub 0 t p) A @ Exi p # pre @ z\<close>
      using Ext by blast
    then have \<open>\<tturnstile> Exi p # pre @ z\<close>
    proof (induct A)
      case Nil
      then show ?case
        by simp
    next
      case (Cons a A)
      then have \<open>\<tturnstile> Exi p # map (\<lambda>t. sub 0 t p) A @ Exi p # pre @ z\<close>
        using SeCaV.GammaExi by simp
      then have \<open>\<tturnstile> map (\<lambda>t. sub 0 t p) A @ Exi p # pre @ z\<close>
        using Ext by simp
      then show ?case
        using Cons.hyps by blast
    qed
    then show ?thesis
      using GammaExi Ext by simp
  next
    case (GammaUni p)
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> pre @ Neg (Uni p) # map (\<lambda>t. Neg (sub 0 t p)) A @ z')\<close>
      using * unfolding parts_def by simp
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> ((pre @ Neg (Uni p) # map (\<lambda>t. Neg (sub 0 t p)) A) @ z'))\<close>
      by simp
    moreover have \<open>\<forall>t \<in> set A. params (sub 0 t p) \<subseteq> paramsts A \<union> params p\<close>
      using params_sub by fastforce
    then have \<open>\<forall>t \<in> set A. params (sub 0 t p) \<subseteq> paramsts ?A\<close>
        using GammaUni A by fastforce
    then have \<open>paramss (map (\<lambda>t. sub 0 t p) A) \<subseteq> paramsts ?A\<close>
      by auto
    ultimately have \<open>\<tturnstile> pre @ Neg (Uni p) # map (\<lambda>t. Neg (sub 0 t p)) A @ z\<close>
      using GammaUni ih[where pre=\<open>pre @ Neg (Uni p) # map _ A\<close> and A=\<open>?A\<close>] A by simp
    moreover have \<open>ext (map (\<lambda>t. Neg (sub 0 t p)) A @ Neg (Uni p) # pre @ z)
          (pre @ Neg (Uni p) # map (\<lambda>t. Neg (sub 0 t p)) A @ z)\<close>
      by auto
    ultimately have \<open>\<tturnstile> map (\<lambda>t. Neg (sub 0 t p)) A @ Neg (Uni p) # pre @ z\<close>
      using Ext by blast
    then have \<open>\<tturnstile> Neg (Uni p) # pre @ z\<close>
    proof (induct A)
      case Nil
      then show ?case
        by simp
    next
      case (Cons a A)
      then have \<open>\<tturnstile> Neg (Uni p) # map (\<lambda>t. Neg (sub 0 t p)) A @ Neg (Uni p) # pre @ z\<close>
        using SeCaV.GammaUni by simp
      then have \<open>\<tturnstile> map (\<lambda>t. Neg (sub 0 t p)) A @ Neg (Uni p) # pre @ z\<close>
        using Ext by simp
      then show ?case
        using Cons.hyps by blast
    qed
    then show ?thesis
      using GammaUni Ext by simp
  next
    case Other
    then have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> (pre @ [p]) @ z')\<close>
      using * by simp
    then show ?thesis
      using ih[where pre=\<open>pre @ [p]\<close> and A=\<open>?A\<close>] A by simp
  qed
qed

text \<open>As a special case, the prefix can be empty.\<close>
corollary SeCaV_children:
  assumes \<open>\<forall>z' \<in> set (children A r z). (\<tturnstile> z')\<close> and \<open>paramss z \<subseteq> paramsts A\<close>
  shows \<open>\<tturnstile> z\<close>
  using SeCaV_children_pre assms by (metis append_Nil)

text \<open>Using this lemma, we can instantiate the abstract soundness framework.\<close>
interpretation Soundness eff rules UNIV \<open>\<lambda>_ (A, z). (\<tturnstile> z)\<close>
  unfolding Soundness_def
proof safe
  fix r A z ss S
  assume r_enabled: \<open>eff r (A, z) ss\<close>

  assume \<open>\<forall>s'. s' |\<in>| ss \<longrightarrow> (\<forall>S \<in> UNIV. case s' of (A, z) \<Rightarrow> \<tturnstile> z)\<close>
  then have next_sound: \<open>\<forall>B z. (B, z) |\<in>| ss \<longrightarrow> (\<tturnstile> z)\<close>
    by simp

  show \<open>\<tturnstile> z\<close>
  proof (cases \<open>branchDone z\<close>)
    case True
    then obtain p where \<open>p \<in> set z\<close> \<open>Neg p \<in> set z\<close>
      using branchDone_contradiction by blast
    then show ?thesis
      using Ext Basic by fastforce
  next
    case False
    let ?A = \<open>remdups (A @ subtermFms z)\<close>
    have \<open>\<forall>z' \<in> set (children ?A r z). (\<tturnstile> z')\<close>
      using False r_enabled eff_children next_sound by blast
    moreover have \<open>set (subtermFms z) \<subseteq> set ?A\<close>
      by simp
    then have \<open>paramss z \<subseteq> paramsts ?A\<close>
      using subtermFm_subset_params by fastforce
    ultimately show \<open>\<tturnstile> z\<close>
      using SeCaV_children by blast
  qed
qed

text \<open>Using the result from the abstract soundness framework, we can finally state our soundness
  result: for a finite, well-formed proof tree, the sequent at the root of the tree is provable in
  the SeCaV proof system.\<close>
theorem prover_soundness_SeCaV:
  assumes \<open>tfinite t\<close> and \<open>wf t\<close>
  shows \<open>\<tturnstile> rootSequent t\<close>
  using assms soundness by fastforce

end


subsection \<open> Refinement Calculus \<close>

theory utp_rcalc
  imports utp_prog
begin

subsection \<open> Operators \<close>

lift_definition spec :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred \<Rightarrow> ('\<alpha> \<Rightarrow> '\<alpha> upred) \<Rightarrow> '\<alpha> prog"
is "\<lambda> x p q. (\<Squnion> v \<bullet> ((p \<and> &\<^bold>v =\<^sub>u \<guillemotleft>v\<guillemotright>) \<turnstile>\<^sub>n x:[\<lceil>q(v)\<rceil>\<^sub>>]))"
  by (simp add: closure)

lift_definition log_const :: "'a itself \<Rightarrow> ('a \<Rightarrow> '\<alpha> prog) \<Rightarrow> '\<alpha> prog"
is "\<lambda> t P. \<Squnion> i \<bullet> P i" by (simp add: closure)

declare spec.rep_eq [prog_rep_eq]
declare log_const.rep_eq [prog_rep_eq]

subsection \<open> Syntax Translations \<close>

syntax
  "_spec"      :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_:[_,/ _]" [99,0,0] 100)
  "_log_const" :: "id \<Rightarrow> type \<Rightarrow> logic \<Rightarrow> logic" ("con _ :: _ \<bullet> _" [0, 10] 10)
  "_init_val"  :: "svid \<Rightarrow> logic" ("&\<^sub>0_" [998] 998)
  "_init_expr" :: "logic \<Rightarrow> logic" ("[_]\<^sub>0")

translations
  "_spec x p q" => "CONST spec x p (\<lambda> _init_var. q)"
  "_spec (_salphaset (_salphamk x)) p q" <= "CONST spec x p (\<lambda> iv. q)"
  "con x :: 'a \<bullet> P" == "CONST log_const TYPE('a) (\<lambda> x. P)"
  "_init_val x" => "CONST uop (CONST lens_get x) (CONST lit _init_var)"
  "_init_expr e" => "e\<lbrakk>\<guillemotleft>_init_var\<guillemotright>/&\<^bold>v\<rbrakk>"

abbreviation "chose x \<equiv> {&x}:[true,true]"

abbreviation passume :: "'\<alpha> upred \<Rightarrow> '\<alpha> prog" ("{_}\<^sub>p") where
"{b}\<^sub>p \<equiv> \<emptyset>:[b, true]"

abbreviation passert :: "'\<alpha> upred \<Rightarrow> '\<alpha> prog" ("[_]\<^sub>p") where
"[b]\<^sub>p \<equiv> \<emptyset>:[true, b]"

subsection \<open> Refinement Laws \<close>

lemma spec_abort:
  "x:[false,post] = abort"
  by pauto

lemma spec_skip:
  "\<emptyset>:[true,true] = skip"
  by (pauto)

lemma rc_spec_expand:
  "vwb_lens w \<Longrightarrow> w:[pre, post(iv :: '\<alpha>)] = (con s :: '\<alpha> \<bullet> w:[pre \<and> &\<^bold>v =\<^sub>u \<guillemotleft>s\<guillemotright>, post(s)])"
  by (peq)

lemma rc_strengthen_post:
  assumes "`post' \<Rightarrow> post`"
  shows "w:[pre, post] \<sqsubseteq> w:[pre, post']"
  using assms by (pauto)

lemma rc_weaken_pre:
  assumes "`pre \<Rightarrow> pre'`"
  shows "w:[pre, post] \<sqsubseteq> w:[pre', post]"
  using assms by prefine

lemma rc_skip:
  assumes "vwb_lens w" "`pre \<Rightarrow> post`"
  shows "w:[pre, post] \<sqsubseteq> skip"
  using assms by prefine

lemma rc_assign:
  assumes "vwb_lens x" "vwb_lens w" "x \<bowtie> w" "`pre \<Rightarrow> post\<lbrakk>e/w\<rbrakk>`"
  shows "{&w,&x}:[pre,post] \<sqsubseteq> w := e"
  using assms by prefine

lemma rc_seq:
  assumes "vwb_lens w" "w \<natural> mid"
  shows "w:[pre, post] \<sqsubseteq> w:[pre, mid] ;; w:[mid, post]"
  using assms by (prefine, metis mwb_lens.put_put vwb_lens_mwb)

lemma rc_intro_log_const:
  assumes "`pre \<Rightarrow> (\<^bold>\<exists> c :: 'a \<bullet> pre'(c))`"
  shows "w:[pre, post] \<sqsubseteq> (con c :: 'a \<bullet> w:[pre'(c), post])"
  using assms by (prefine)

lemma rc_fix_init_val:
  "w:[pre, post] \<sqsubseteq> (con c :: 'a \<bullet> w:[pre \<and> \<guillemotleft>c\<guillemotright> =\<^sub>u E, post])"
  by (prefine)

lemma rc_remove_log_const:
  "(con c :: 'a \<bullet> P) \<sqsubseteq> P"
  by (prefine')

lemma rc_expand_frame:
  assumes "vwb_lens x" "w \<bowtie> x" "\<And> iv. x \<sharp> post(iv)"
  shows "{&w}:[pre, post(iv)] = {&w,&x}:[pre, post(iv) \<and> &x =\<^sub>u &\<^sub>0x]"
  using assms
  apply (peq)
  apply (rename_tac b c)
  apply (metis lens_indep_def)
  apply (simp add: lens_indep.lens_put_comm)
done

lemma rc_iterate:
  fixes V :: "(nat, 'a) uexpr"
  assumes "vwb_lens w"
  shows "w:[ivr, ivr \<and> \<not> (\<Or> i\<in>A \<bullet> g(i))]
        \<sqsubseteq> (do i\<in>A \<bullet> g(i) \<rightarrow> w:[ivr \<and> g(i), ivr \<and> (V <\<^sub>u [V]\<^sub>0)] od)" (is "?lhs \<sqsubseteq> ?rhs")
proof -
  have "(\<Squnion> v \<bullet> (ivr \<and> &\<^bold>v =\<^sub>u \<guillemotleft>v\<guillemotright>) \<turnstile>\<^sub>n w:[\<lceil>ivr \<and> \<not> (\<Sqinter> i \<in> A \<bullet> g i)\<rceil>\<^sub>>]) =
        (ivr \<turnstile>\<^sub>n w:[\<lceil>ivr \<and> \<not> (\<Sqinter> i \<in> A \<bullet> g i)\<rceil>\<^sub>>])"
    by (rel_auto)
  also have "... \<sqsubseteq> do i\<in>A \<bullet> g(i) \<rightarrow> \<Squnion> v \<bullet> ((ivr \<and> g i) \<and> &\<^bold>v =\<^sub>u \<guillemotleft>v\<guillemotright>) \<turnstile>\<^sub>n w:[\<lceil>ivr \<and> V <\<^sub>u V\<lbrakk>\<guillemotleft>v\<guillemotright>/&\<^bold>v\<rbrakk>\<rceil>\<^sub>>] od"
    apply (rule order_trans)
    defer
    apply (rule IterateD_refine_intro[of _ _ _ _ V], simp add: assms)
    apply (rule IterateD_mono_refine)
    apply (simp_all add: ndes_simp closure)
    apply (rule ndesign_refine_intro)
    apply (rel_auto)+
  done
  finally show ?thesis
    apply (ptransfer, simp add: usubst)
    oops

lemma rc_iterate_single:
  fixes V :: "(nat, 'a) uexpr"
  assumes "vwb_lens w"
  shows "w:[ivr, ivr \<and> \<not> g] \<sqsubseteq> (do g \<rightarrow> w:[ivr \<and> g, ivr \<and> (V <\<^sub>u [V]\<^sub>0)] od)"
oops

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

header {* Determinism *}

theory Determinism imports WellDefined begin

text_raw {* \label{s:prog_determ} *}

text {* We provide a set of lemmas for establishing that
  appropriately restricted programs are fully additive, and
  maximal in the refinement order.  This is particularly useful
  with data refinement, as it implies correspondence. *}

subsection  {* Additivity *}

lemma additive_wp_Abort:
  "additive (wp (Abort))"
  by(auto simp:wp_eval)

text {* @{term "wlp Abort"} is not additive.  *}

lemma additive_wp_Skip:
  "additive (wp (Skip))"
  by(auto simp:wp_eval)

lemma additive_wp_Apply:
  "additive (wp (Apply f))"
  by(auto simp:wp_eval)

lemma additive_wp_Seq:
  fixes a::"'s prog"
  assumes adda: "additive (wp a)"
      and addb: "additive (wp b)"
      and wb:   "well_def b"
  shows "additive (wp (a ;; b))"
proof(rule additiveI, unfold wp_eval o_def)
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  assume sP: "sound P" and sQ: "sound Q"

  note hb = well_def_wp_healthy[OF wb]

  from addb sP sQ
  have "wp b (\<lambda>s. P s + Q s) = (\<lambda>s. wp b P s + wp b Q s)"
    by(blast dest:additiveD)
  with adda sP sQ hb
  show "wp a (wp b (\<lambda>s. P s + Q s)) s =
        wp a (wp b P) s + (wp a (wp b Q)) s"
    by(auto intro:fun_cong[OF additiveD])
qed

lemma additive_wp_PC:
  "\<lbrakk> additive (wp a); additive (wp b) \<rbrakk> \<Longrightarrow> additive (wp (a \<^bsub>P\<^esub>\<oplus> b))"
  by(rule additiveI, simp add:additiveD field_simps wp_eval)

text {* @{term DC} is not additive. *}

lemma additive_wp_SetPC:
  "\<lbrakk> \<And>x s. x \<in> supp (p s) \<Longrightarrow> additive (wp (a x)); \<And>s. finite (supp (p s)) \<rbrakk> \<Longrightarrow>
   additive (wp (SetPC a p))"
  by(rule additiveI,
     simp add:wp_eval additiveD distrib_left setsum.distrib)

lemma additive_wp_Bind:
  "\<lbrakk> \<And>x. additive (wp (a (f x))) \<rbrakk> \<Longrightarrow> additive (wp (Bind f a))"
  by(simp add:wp_eval additive_def)

lemma additive_wp_Embed:
  "\<lbrakk> additive t \<rbrakk> \<Longrightarrow> additive (wp (Embed t))"
  by(simp add:wp_eval)

lemma additive_wp_repeat:
  "additive (wp a) \<Longrightarrow> well_def a \<Longrightarrow> additive (wp (repeat n a))"
  by(induct n, auto simp:additive_wp_Skip intro:additive_wp_Seq wd_intros)

lemmas fa_intros =
  additive_wp_Abort additive_wp_Skip
  additive_wp_Apply additive_wp_Seq
  additive_wp_PC    additive_wp_SetPC
  additive_wp_Bind  additive_wp_Embed
  additive_wp_repeat

subsection {* Maximality *}

lemma max_wp_Skip:
  "maximal (wp Skip)"
  by(simp add:maximal_def wp_eval)

lemma max_wp_Apply:
  "maximal (wp (Apply f))"
  by(auto simp:wp_eval o_def)

lemma max_wp_Seq:
  "\<lbrakk> maximal (wp a); maximal (wp b) \<rbrakk> \<Longrightarrow> maximal (wp (a ;; b))"
  by(simp add:wp_eval maximal_def)

lemma max_wp_PC:
  "\<lbrakk> maximal (wp a); maximal (wp b) \<rbrakk> \<Longrightarrow> maximal (wp (a \<^bsub>P\<^esub>\<oplus> b))"
  by(rule maximalI, simp add:maximalD field_simps wp_eval)

lemma max_wp_DC:
  "\<lbrakk> maximal (wp a); maximal (wp b) \<rbrakk> \<Longrightarrow> maximal (wp (a \<Sqinter> b))"
  by(rule maximalI, simp add:wp_eval maximalD)

lemma max_wp_SetPC:
  "\<lbrakk> \<And>s a. a \<in> supp (P s) \<Longrightarrow> maximal (wp (p a)); \<And>s. (\<Sum>a\<in>supp (P s). P s a) = 1 \<rbrakk> \<Longrightarrow>
  maximal (wp (SetPC p P))"
  by(auto simp:maximalD wp_def SetPC_def setsum_left_distrib[symmetric])

lemma max_wp_SetDC:
  fixes p::"'a \<Rightarrow> 's prog"
  assumes mp: "\<And>s a. a \<in> S s \<Longrightarrow> maximal (wp (p a))"
      and ne: "\<And>s. S s \<noteq> {}"
  shows "maximal (wp (SetDC p S))"
proof(rule maximalI, rule ext, unfold wp_eval)
  fix c::real and s::'s
  assume "0 \<le> c"
  hence "Inf ((\<lambda>a. wp (p a) (\<lambda>_. c) s) ` S s) = Inf ((\<lambda>_. c) ` S s)"
    using mp by(simp add:maximalD cong:image_cong)
  also {
    from ne have "\<exists>a. a \<in> S s" by(blast)
    hence "Inf ((\<lambda>_. c) ` S s) = c"
      by(simp add:image_def)
  }
  finally show "Inf ((\<lambda>a. wp (p a) (\<lambda>_. c) s) ` S s) = c" .
qed

lemma max_wp_Embed:
  "maximal t \<Longrightarrow> maximal (wp (Embed t))"
  by(simp add:wp_eval)

lemma max_wp_repeat:
  "maximal (wp a) \<Longrightarrow> maximal (wp (repeat n a))"
  by(induct n, simp_all add:max_wp_Skip max_wp_Seq)

lemma max_wp_Bind:
  assumes ma: "\<And>s. maximal (wp (a (f s)))"
  shows "maximal (wp (Bind f a))"
proof(rule maximalI, rule ext, simp add:wp_eval)
  fix c::real and s
  assume "0 \<le> c"
  with ma have "wp (a (f s)) (\<lambda>_. c) = (\<lambda>_. c)" by(blast)
  thus "wp (a (f s)) (\<lambda>_. c) s = c" by(auto)
qed

lemmas max_intros =
  max_wp_Skip  max_wp_Apply
  max_wp_Seq   max_wp_PC
  max_wp_DC    max_wp_SetPC
  max_wp_SetDC max_wp_Embed
  max_wp_Bind  max_wp_repeat

text {* A healthy transformer that terminates is maximal. *}
lemma healthy_term_max:
  assumes ht: "healthy t"
      and trm: "\<lambda>s. 1 \<tturnstile> t (\<lambda>s. 1)"
  shows "maximal t"
proof(intro maximalI ext)
  fix c::real and s
  assume nnc: "0 \<le> c"

  have "t (\<lambda>s. c) s = t (\<lambda>s. 1 * c) s" by(simp)
  also from nnc healthy_scalingD[OF ht]
  have "... = c * t (\<lambda>s. 1) s" by(simp add:scalingD)
  also {
    from ht have "t (\<lambda>s. 1) \<tturnstile> \<lambda>s. 1" by(auto)
    with trm have "t (\<lambda>s. 1) = (\<lambda>s. 1)" by(auto)
    hence "c * t (\<lambda>s. 1) s = c" by(simp)
  }
  finally show "t (\<lambda>s. c) s = c" .
qed

subsection {* Determinism *}

lemma det_wp_Skip:
  "determ (wp Skip)"
  using max_intros fa_intros by(blast)

lemma det_wp_Apply:
  "determ (wp (Apply f))"
  by(intro determI fa_intros max_intros)

lemma det_wp_Seq:
  "determ (wp a) \<Longrightarrow> determ (wp b) \<Longrightarrow> well_def b \<Longrightarrow> determ (wp (a ;; b))"
  by(intro determI fa_intros max_intros, auto)

lemma det_wp_PC:
  "determ (wp a) \<Longrightarrow> determ (wp b) \<Longrightarrow> determ (wp (a \<^bsub>P\<^esub>\<oplus> b))"
  by(intro determI fa_intros max_intros, auto)

lemma det_wp_SetPC:
  "(\<And>x s. x \<in> supp (p s) \<Longrightarrow> determ (wp (a x))) \<Longrightarrow>
   (\<And>s. finite (supp (p s))) \<Longrightarrow>
   (\<And>s. setsum (p s) (supp (p s)) = 1) \<Longrightarrow>
   determ (wp (SetPC a p))"
  by(intro determI fa_intros max_intros, auto)

lemma det_wp_Bind:
  "(\<And>x. determ (wp (a (f x)))) \<Longrightarrow> determ (wp (Bind f a))"
  by(intro determI fa_intros max_intros, auto)

lemma det_wp_Embed:
  "determ t \<Longrightarrow> determ (wp (Embed t))"
  by(simp add:wp_eval)

lemma det_wp_repeat:
  "determ (wp a) \<Longrightarrow> well_def a \<Longrightarrow> determ (wp (repeat n a))"
  by(intro determI fa_intros max_intros, auto)

lemmas determ_intros =
  det_wp_Skip det_wp_Apply
  det_wp_Seq  det_wp_PC
  det_wp_SetPC det_wp_Bind
  det_wp_Embed det_wp_repeat

end