section \<open>\isaheader{Nested DFS (HPY improvement)}\<close>
theory Nested_DFS
imports
  "../../Refine_Dflt"
  Succ_Graph
  "../../Lib/Code_Target_ICF"
  "../../../CAVA_Automata/Digraph_Basic"
begin

text \<open>
  Implementation of a nested DFS algorithm for accepting cycle detection
  using the refinement framework. The algorithm uses the improvement of
  [HPY96], i.e., it reports a cycle if the inner DFS finds a path back to
  the stack of the outer DFS.

  The algorithm returns a witness in case that an accepting cycle is detected.
\<close>

subsection "Tools for DFS Algorithms"

subsubsection "Invariants"
definition "gen_dfs_pre E U S V u0 \<equiv>
  E``U \<subseteq> U   \<comment> \<open>Upper bound is closed under transitions\<close>
  \<and> finite U \<comment> \<open>Upper bound is finite\<close>
  \<and> V \<subseteq> U    \<comment> \<open>Visited set below upper bound\<close>
  \<and> u0 \<in> U   \<comment> \<open>Start node in upper bound\<close>
  \<and> E``(V-S) \<subseteq> V \<comment> \<open>Visited nodes closed under reachability, or on stack\<close>
  \<and> u0\<notin>V     \<comment> \<open>Start node not yet visited\<close>
  \<and> S \<subseteq> V    \<comment> \<open>Stack is visited\<close>
  \<and> (\<forall>v\<in>S. (v,u0)\<in>(E\<inter>S\<times>UNIV)\<^sup>*) \<comment> \<open>\<open>u0\<close> reachable from stack, only over stack\<close>
  "

definition "gen_dfs_var U \<equiv> finite_psupset U"

definition "gen_dfs_fe_inv E U S V0 u0 it V brk \<equiv>
  (\<not>brk \<longrightarrow> E``(V-S) \<subseteq> V)  \<comment> \<open>Visited set closed under reachability\<close>
  \<and> E``{u0} - it \<subseteq> V     \<comment> \<open>Successors of \<open>u0\<close> visited\<close>
  \<and> V0 \<subseteq> V               \<comment> \<open>Visited set increasing\<close>
  \<and> V \<subseteq> V0 \<union> (E - UNIV\<times>S)\<^sup>* `` (E``{u0} - it - S) \<comment> \<open>All visited nodes reachable\<close>
"

definition "gen_dfs_post E U S V0 u0 V brk \<equiv>
  (\<not>brk \<longrightarrow> E``(V-S) \<subseteq> V) \<comment> \<open>Visited set closed under reachability\<close>
  \<and> u0 \<in> V               \<comment> \<open>\<open>u0\<close> visited\<close>
  \<and> V0 \<subseteq> V               \<comment> \<open>Visited set increasing\<close>
  \<and> V \<subseteq> V0 \<union> (E - UNIV\<times>S)\<^sup>* `` {u0} \<comment> \<open>All visited nodes reachable\<close>
"

subsubsection "Invariant Preservation"
lemma gen_dfs_pre_initial:
  assumes "finite (E\<^sup>*``{v0})"
  assumes "v0\<in>U"
  shows "gen_dfs_pre E (E\<^sup>*``{v0}) {} {} v0"
  using assms unfolding gen_dfs_pre_def
  apply auto
  done

lemma gen_dfs_pre_imp_wf:
  assumes "gen_dfs_pre E U S V u0"
  shows "wf (gen_dfs_var U)"
  using assms unfolding gen_dfs_pre_def gen_dfs_var_def by auto

lemma gen_dfs_pre_imp_fin:
  assumes "gen_dfs_pre E U S V u0"
  shows "finite (E `` {u0})"
  apply (rule finite_subset[where B="U"])
  using assms unfolding gen_dfs_pre_def
  by auto

text \<open>Inserted \<open>u0\<close> on stack and to visited set\<close>
lemma gen_dfs_pre_imp_fe:
  assumes "gen_dfs_pre E U S V u0"
  shows "gen_dfs_fe_inv E U (insert u0 S) (insert u0 V) u0
    (E``{u0}) (insert u0 V) False"
  using assms unfolding gen_dfs_pre_def gen_dfs_fe_inv_def
  apply auto
  done

lemma gen_dfs_fe_inv_pres_visited:
  assumes "gen_dfs_pre E U S V u0"
  assumes "gen_dfs_fe_inv E U (insert u0 S) (insert u0 V) u0 it V' False"
  assumes "t\<in>it" "it\<subseteq>E``{u0}" "t\<in>V'"
  shows "gen_dfs_fe_inv E U (insert u0 S) (insert u0 V) u0 (it-{t}) V' False"
  using assms unfolding gen_dfs_fe_inv_def
  apply auto
  done

lemma gen_dfs_upper_aux:
  assumes "(x,y)\<in>E'\<^sup>*"
  assumes "(u0,x)\<in>E"
  assumes "u0\<in>U"
  assumes "E'\<subseteq>E"
  assumes "E``U \<subseteq> U"
  shows "y\<in>U"
  using assms
  by induct auto

lemma gen_dfs_fe_inv_imp_var:
  assumes "gen_dfs_pre E U S V u0"
  assumes "gen_dfs_fe_inv E U (insert u0 S) (insert u0 V) u0 it V' False"
  assumes "t\<in>it" "it\<subseteq>E``{u0}" "t\<notin>V'"
  shows "(V',V) \<in> gen_dfs_var U"
  using assms unfolding gen_dfs_fe_inv_def gen_dfs_pre_def gen_dfs_var_def
  apply (clarsimp simp add: finite_psupset_def)
  apply (blast dest: gen_dfs_upper_aux)
  done

lemma gen_dfs_fe_inv_imp_pre:
  assumes "gen_dfs_pre E U S V u0"
  assumes "gen_dfs_fe_inv E U (insert u0 S) (insert u0 V) u0 it V' False"
  assumes "t\<in>it" "it\<subseteq>E``{u0}" "t\<notin>V'"
  shows "gen_dfs_pre E U (insert u0 S) V' t"
  using assms unfolding gen_dfs_fe_inv_def gen_dfs_pre_def
  apply clarsimp
  apply (intro conjI)
  apply (blast dest: gen_dfs_upper_aux)
  apply blast
  apply blast
  apply blast
  apply clarsimp
  apply (rule rtrancl_into_rtrancl[where b=u0])
  apply (auto intro: rev_subsetD[OF _ rtrancl_mono[where r="E \<inter> S \<times> UNIV"]]) []
  apply blast
  done

lemma gen_dfs_post_imp_fe_inv:
  assumes "gen_dfs_pre E U S V u0"
  assumes "gen_dfs_fe_inv E U (insert u0 S) (insert u0 V) u0 it V' False"
  assumes "t\<in>it" "it\<subseteq>E``{u0}" "t\<notin>V'"
  assumes "gen_dfs_post E U (insert u0 S) V' t V'' cyc"
  shows "gen_dfs_fe_inv E U (insert u0 S) (insert u0 V) u0 (it-{t}) V'' cyc"
  using assms unfolding gen_dfs_fe_inv_def gen_dfs_post_def gen_dfs_pre_def
  apply clarsimp
  apply (intro conjI)
  apply blast
  apply blast
  apply blast
  apply (erule order_trans)
  apply simp
  apply (rule conjI)
    apply (erule order_trans[
      where y="insert u0 (V \<union> (E - UNIV \<times> insert u0 S)\<^sup>*
        `` (E `` {u0} - it - insert u0 S))"])
    apply blast

    apply (cases cyc)
      apply simp
      apply blast

      apply simp
      apply blast
  done

lemma gen_dfs_post_aux:
  assumes 1: "(u0,x)\<in>E"
  assumes 2: "(x,y)\<in>(E - UNIV \<times> insert u0 S)\<^sup>*"
  assumes 3: "S\<subseteq>V" "x\<notin>V"
  shows "(u0, y) \<in> (E - UNIV \<times> S)\<^sup>*"
proof -
  from 1 3 have "(u0,x)\<in>(E - UNIV \<times> S)" by blast
  also have "(x,y)\<in>(E - UNIV \<times> S)\<^sup>*"
    apply (rule_tac rev_subsetD[OF 2 rtrancl_mono])
    by auto
  finally show ?thesis .
qed

lemma gen_dfs_fe_imp_post_brk:
  assumes "gen_dfs_pre E U S V u0"
  assumes "gen_dfs_fe_inv E U (insert u0 S) (insert u0 V) u0 it V' True"
  assumes "it\<subseteq>E``{u0}"
  shows "gen_dfs_post E U S V u0 V' True"
  using assms unfolding gen_dfs_pre_def gen_dfs_fe_inv_def gen_dfs_post_def
  apply clarify
  apply (intro conjI)
  apply simp
  apply simp
  apply simp
  apply clarsimp
  apply (blast intro: gen_dfs_post_aux)
  done

lemma gen_dfs_fe_inv_imp_post:
  assumes "gen_dfs_pre E U S V u0"
  assumes "gen_dfs_fe_inv E U (insert u0 S) (insert u0 V) u0 {} V' cyc"
  assumes "cyc\<longrightarrow>cyc'"
  shows "gen_dfs_post E U S V u0 V' cyc'"
  using assms unfolding gen_dfs_pre_def gen_dfs_fe_inv_def gen_dfs_post_def
  apply clarsimp
  apply (intro conjI)
  apply blast
  apply (auto intro: gen_dfs_post_aux) []
  done

lemma gen_dfs_pre_imp_post_brk:
  assumes "gen_dfs_pre E U S V u0"
  shows "gen_dfs_post E U S V u0 (insert u0 V) True"
  using assms unfolding gen_dfs_pre_def gen_dfs_post_def
  apply auto
  done

subsubsection "Consequences of Postcondition"
lemma gen_dfs_post_imp_reachable:
  assumes "gen_dfs_pre E U S V0 u0"
  assumes "gen_dfs_post E U S V0 u0 V brk"
  shows "V \<subseteq> V0 \<union> E\<^sup>*``{u0}"
  using assms unfolding gen_dfs_post_def gen_dfs_pre_def
  apply clarsimp
  apply (blast intro: rev_subsetD[OF _ rtrancl_mono])
  done

lemma gen_dfs_post_imp_complete:
  assumes "gen_dfs_pre E U {} V0 u0"
  assumes "gen_dfs_post E U {} V0 u0 V False"
  shows "V0 \<union> E\<^sup>*``{u0} \<subseteq> V"
  using assms unfolding gen_dfs_post_def gen_dfs_pre_def
  apply clarsimp
  apply (blast dest: Image_closed_trancl)
  done

lemma gen_dfs_post_imp_eq:
  assumes "gen_dfs_pre E U {} V0 u0"
  assumes "gen_dfs_post E U {} V0 u0 V False"
  shows "V = V0 \<union> E\<^sup>*``{u0}"
  using gen_dfs_post_imp_reachable[OF assms] gen_dfs_post_imp_complete[OF assms]
  by blast

lemma gen_dfs_post_imp_below_U:
  assumes "gen_dfs_pre E U S V0 u0"
  assumes "gen_dfs_post E U S V0 u0 V False"
  shows "V \<subseteq> U"
  using assms unfolding gen_dfs_pre_def gen_dfs_post_def
  apply clarsimp
  apply (blast intro: rev_subsetD[OF _ rtrancl_mono] dest: Image_closed_trancl)
  done

subsection "Abstract Algorithm"

subsubsection \<open>Inner (red) DFS\<close>

text \<open>A witness of the red algorithm is a node on the stack and a path
  to this node\<close>
type_synonym 'v red_witness = "('v list \<times> 'v) option"
text \<open>Prepend node to red witness\<close>
fun prep_wit_red :: "'v \<Rightarrow> 'v red_witness \<Rightarrow> 'v red_witness" where
  "prep_wit_red v None = None"
| "prep_wit_red v (Some (p,u)) = Some (v#p,u)"

text \<open>
  Initial witness for node \<open>u\<close> with onstack successor \<open>v\<close>
\<close>
definition red_init_witness :: "'v \<Rightarrow> 'v \<Rightarrow> 'v red_witness" where
  "red_init_witness u v = Some ([u],v)"

definition red_dfs where
  "red_dfs E onstack V u \<equiv>
    REC\<^sub>T (\<lambda>D (V,u). do {
      let V=insert u V;

      \<comment> \<open>Check whether we have a successor on stack\<close>
      brk \<leftarrow> FOREACH\<^sub>C (E``{u}) (\<lambda>brk. brk=None)
        (\<lambda>t _. if t\<in>onstack then RETURN (red_init_witness u t) else RETURN None)
        None;

      \<comment> \<open>Recurse for successors\<close>
      case brk of
        None \<Rightarrow>
          FOREACH\<^sub>C (E``{u}) (\<lambda>(V,brk). brk=None)
            (\<lambda>t (V,_).
              if t\<notin>V then do {
                (V,brk) \<leftarrow> D (V,t);
                RETURN (V,prep_wit_red u brk)
              } else RETURN (V,None))
            (V,None)
      | _ \<Rightarrow> RETURN (V,brk)
    }) (V,u)
  "

text \<open>
  A witness of the blue DFS may be in two different phases, the \<open>REACH\<close>
  phase is before the node on the stack has actually been popped, and the
  \<open>CIRC\<close> phase is after the node on the stack has been popped.

  \<open>REACH v p u p'\<close>: \begin{description}
  \item[\<open>v\<close>] accepting node
  \item[\<open>p\<close>] path from \<open>v\<close> to \<open>u\<close>
  \item[\<open>u\<close>] node on stack
  \item[\<open>p'\<close>] path from current node to \<open>v\<close>
  \end{description}

  \<open>CIRC v pc pr\<close>: \begin{description}
  \item[\<open>v\<close>] accepting node
  \item[\<open>pc\<close>] path from \<open>v\<close> to \<open>v\<close>
  \item[\<open>pr\<close>] path from current node to \<open>v\<close>
  \end{description}
\<close>
datatype 'v blue_witness =
  NO_CYC
| REACH "'v" "'v list" "'v" "'v list"
| CIRC "'v" "'v list" "'v list"

text \<open>Prepend node to witness\<close>
primrec prep_wit_blue :: "'v \<Rightarrow> 'v blue_witness \<Rightarrow> 'v blue_witness" where
  "prep_wit_blue u0 NO_CYC = NO_CYC"
| "prep_wit_blue u0 (REACH v p u p') = (
  if u0=u then
    CIRC v (p@u#p') (u0#p')
  else
    REACH v p u (u0#p')
  )"
| "prep_wit_blue u0 (CIRC v pc pr) = CIRC v pc (u0#pr)"

text \<open>Initialize blue witness\<close>
fun init_wit_blue :: "'v \<Rightarrow> 'v red_witness \<Rightarrow> 'v blue_witness" where
  "init_wit_blue u0 None = NO_CYC"
| "init_wit_blue u0 (Some (p,u)) = (
  if u=u0 then
    CIRC u0 p []
  else REACH u0 p u [])"

text \<open>Extract result from witness\<close>
definition "extract_res cyc
  \<equiv> (case cyc of CIRC v pc pr \<Rightarrow> Some (v,pc,pr) | _ \<Rightarrow> None)"

subsubsection \<open>Outer (Blue) DFS\<close>
definition blue_dfs
  :: "('a\<times>'a) set \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> ('a\<times>'a list\<times>'a list) option nres"
  where
  "blue_dfs E A s \<equiv> do {
    (_,_,_,cyc) \<leftarrow> REC\<^sub>T (\<lambda>D (blues,reds,onstack,s). do {
      let blues=insert s blues;
      let onstack=insert s onstack;
      (blues,reds,onstack,cyc) \<leftarrow>
      FOREACH\<^sub>C (E``{s}) (\<lambda>(_,_,_,cyc). cyc=NO_CYC)
        (\<lambda>t (blues,reds,onstack,cyc).
          if t\<notin>blues then do {
            (blues,reds,onstack,cyc) \<leftarrow> D (blues,reds,onstack,t);
            RETURN (blues,reds,onstack,(prep_wit_blue s cyc))
          } else RETURN (blues,reds,onstack,cyc))
        (blues,reds,onstack,NO_CYC);

      (reds,cyc) \<leftarrow>
      if cyc=NO_CYC \<and> s\<in>A then do {
        (reds,rcyc) \<leftarrow> red_dfs E onstack reds s;
        RETURN (reds, init_wit_blue s rcyc)
      } else RETURN (reds,cyc);

      let onstack=onstack - {s};
      RETURN (blues,reds,onstack,cyc)
    }) ({},{},{},s);
    RETURN (extract_res cyc)
  }
  "

subsection "Correctness"

subsubsection "Specification"

text \<open>Specification of a reachable accepting cycle:\<close>
definition "has_acc_cycle E A v0 \<equiv> \<exists>v\<in>A. (v0,v)\<in>E\<^sup>* \<and> (v,v)\<in>E\<^sup>+"

text \<open>Specification of witness for accepting cycle\<close>
definition "is_acc_cycle E A v0 v r c
  \<equiv> v\<in>A \<and> path E v0 r v \<and> path E v c v \<and> c\<noteq>[]"

text \<open>Specification is compatible with existence of accepting cycle\<close>
lemma is_acc_cycle_eq:
  "has_acc_cycle E A v0 \<longleftrightarrow> (\<exists>v r c. is_acc_cycle E A v0 v r c)"
  unfolding has_acc_cycle_def is_acc_cycle_def
  by (auto elim!: rtrancl_is_path trancl_is_path
    intro: path_is_rtrancl path_is_trancl)

subsubsection "Correctness Proofs"

text \<open>Additional invariant to be maintained between calls of red dfs\<close>
definition "red_dfs_inv E U reds onstack \<equiv>
  E``U \<subseteq> U           \<comment> \<open>Upper bound is closed under transitions\<close>
  \<and> finite U         \<comment> \<open>Upper bound is finite\<close>
  \<and> reds \<subseteq> U         \<comment> \<open>Red set below upper bound\<close>
  \<and> E``reds \<subseteq> reds   \<comment> \<open>Red nodes closed under reachability\<close>
  \<and> E``reds \<inter> onstack = {} \<comment> \<open>No red node with edge to stack\<close>
"

lemma red_dfs_inv_initial:
  assumes "finite (E\<^sup>*``{v0})"
  shows "red_dfs_inv E (E\<^sup>*``{v0}) {} {}"
  using assms unfolding red_dfs_inv_def
  apply auto
  done

text \<open>Correctness of the red DFS.\<close>
theorem red_dfs_correct:
  fixes v0 u0 :: 'v
  assumes PRE:
    "red_dfs_inv E U reds onstack"
    "u0\<in>U"
    "u0\<notin>reds"
  shows "red_dfs E onstack reds u0
    \<le> SPEC (\<lambda>(reds',cyc). case cyc of
      Some (p,v) \<Rightarrow> v\<in>onstack \<and> p\<noteq>[] \<and> path E u0 p v
    | None \<Rightarrow>
        red_dfs_inv E U reds' onstack
        \<and> u0\<in>reds'
        \<and> reds' \<subseteq> reds \<union> E\<^sup>* `` {u0}
  )"
proof -
  let ?dfs_red = "
    REC\<^sub>T (\<lambda>D (V,u). do {
      let V=insert u V;

      \<comment> \<open>Check whether we have a successor on stack\<close>
      brk \<leftarrow> FOREACH\<^sub>C (E``{u}) (\<lambda>brk. brk=None)
        (\<lambda>t _. if t\<in>onstack then
            RETURN (red_init_witness u t)
          else RETURN None)
        None;

      \<comment> \<open>Recurse for successors\<close>
      case brk of
        None \<Rightarrow>
          FOREACH\<^sub>C (E``{u}) (\<lambda>(V,brk). brk=None)
            (\<lambda>t (V,_).
              if t\<notin>V then do {
                (V,brk) \<leftarrow> D (V,t);
                RETURN (V,prep_wit_red u brk)
              } else RETURN (V,None))
            (V,None)
      | _ \<Rightarrow> RETURN (V,brk)
    }) (V,u)
"
  let "REC\<^sub>T ?body ?init" = "?dfs_red"

  define pre where "pre = (\<lambda>S (V,u0). gen_dfs_pre E U S V u0 \<and> E``V \<inter> onstack = {})"
  define post where "post = (\<lambda>S (V0,u0) (V,cyc). gen_dfs_post E U S V0 u0 V (cyc\<noteq>None)
    \<and> (case cyc of None \<Rightarrow> E``V \<inter> onstack = {}
      | Some (p,v) \<Rightarrow> v\<in>onstack \<and> p\<noteq>[] \<and> path E u0 p v))
    "

  define fe_inv where "fe_inv = (\<lambda>S V0 u0 it (V,cyc).
    gen_dfs_fe_inv E U S V0 u0 it V (cyc\<noteq>None)
    \<and> (case cyc of None \<Rightarrow> E``V \<inter> onstack = {}
      | Some (p,v) \<Rightarrow> v\<in>onstack \<and> p\<noteq>[] \<and> path E u0 p v))
    "

  from PRE have GENPRE: "gen_dfs_pre E U {} reds u0"
    unfolding red_dfs_inv_def gen_dfs_pre_def
    by auto
  with PRE have PRE': "pre {} (reds,u0)"
    unfolding pre_def red_dfs_inv_def
    by auto

  have IMP_POST: "SPEC (post {} (reds,u0))
    \<le> SPEC (\<lambda>(reds',cyc). case cyc of
      Some (p,v) \<Rightarrow> v\<in>onstack \<and> p\<noteq>[] \<and> path E u0 p v
    | None \<Rightarrow>
        red_dfs_inv E U reds' onstack
        \<and> u0\<in>reds'
        \<and> reds' \<subseteq> reds \<union> E\<^sup>* `` {u0})"
    apply (clarsimp split: option.split)
    apply (intro impI conjI allI)
    apply simp_all
  proof -
    fix reds' p v
    assume "post {} (reds,u0) (reds',Some (p,v))"
    thus "v\<in>onstack" and "p\<noteq>[]" and "path E u0 p v"
      unfolding post_def by auto
  next
    fix reds'
    assume "post {} (reds, u0) (reds', None)"
    hence GPOST: "gen_dfs_post E U {} reds u0 reds' False"
      and NS: "E``reds' \<inter> onstack = {}"
      unfolding post_def by auto

    from GPOST show "u0\<in>reds'" unfolding gen_dfs_post_def by auto

    show "red_dfs_inv E U reds' onstack"
      unfolding red_dfs_inv_def
      apply (intro conjI)
      using GENPRE[unfolded gen_dfs_pre_def]
      apply (simp_all) [2]
      apply (rule gen_dfs_post_imp_below_U[OF GENPRE GPOST])
      using GPOST[unfolded gen_dfs_post_def] apply simp
      apply fact
      done

    from GPOST show "reds' \<subseteq> reds \<union> E\<^sup>* `` {u0}"
      unfolding gen_dfs_post_def by auto
  qed

  {
    fix \<sigma> S
    assume INV0: "pre S \<sigma>"
    have "REC\<^sub>T ?body \<sigma>
      \<le> SPEC (post S \<sigma>)"

      apply (rule RECT_rule_arb[where
        pre="pre" and
        V="gen_dfs_var U <*lex*> {}" and
        arb="S"
        ])

      apply refine_mono

      using INV0[unfolded pre_def] apply (auto intro: gen_dfs_pre_imp_wf) []

      apply fact

      apply (rename_tac D S u)
      apply (intro refine_vcg)

      \<comment> \<open>First foreach loop, checking for onstack-successor\<close>
      apply (rule_tac I="\<lambda>it cyc.
        (case cyc of None \<Rightarrow> (E``{b} - it) \<inter> onstack = {}
          | Some (p,v) \<Rightarrow> (v\<in>onstack \<and> p\<noteq>[] \<and> path E b p v))"
        in FOREACHc_rule)
      apply (auto simp add: pre_def gen_dfs_pre_imp_fin) []
      apply auto []
      apply (auto
        split: option.split
        simp: red_init_witness_def intro: path1) []

      apply (intro refine_vcg)

      \<comment> \<open>Second foreach loop, iterating over sucessors\<close>
      apply (rule_tac I="fe_inv (insert b S) (insert b a) b" in
        FOREACHc_rule
      )
      apply (auto simp add: pre_def gen_dfs_pre_imp_fin) []

      apply (auto simp add: pre_def fe_inv_def gen_dfs_pre_imp_fe) []

      apply (intro refine_vcg)

      \<comment> \<open>Recursive call\<close>
      apply (rule order_trans)
      apply (rprems)
      apply (clarsimp simp add: pre_def fe_inv_def)
      apply (rule gen_dfs_fe_inv_imp_pre, assumption+) []
      apply (auto simp add: pre_def fe_inv_def intro: gen_dfs_fe_inv_imp_var) []

      apply (clarsimp simp add: pre_def post_def fe_inv_def
        split: option.split_asm prod.split_asm
        ) []
        apply (blast intro: gen_dfs_post_imp_fe_inv)
        apply (blast intro: gen_dfs_post_imp_fe_inv path_prepend)

      apply (auto simp add: pre_def post_def fe_inv_def
        intro: gen_dfs_fe_inv_pres_visited) []

      apply (auto simp add: pre_def post_def fe_inv_def
        intro: gen_dfs_fe_inv_imp_post) []

      apply (auto simp add: pre_def post_def fe_inv_def
        intro: gen_dfs_fe_imp_post_brk) []

      apply (auto simp add: pre_def post_def fe_inv_def
        intro: gen_dfs_pre_imp_post_brk) []

      apply (auto simp add: pre_def post_def fe_inv_def
        intro: gen_dfs_pre_imp_post_brk) []

      done
  } note GEN=this

  note GEN[OF PRE']
  also note IMP_POST
  finally show ?thesis
    unfolding red_dfs_def .
qed

text \<open>Main theorem: Correctness of the blue DFS\<close>
theorem blue_dfs_correct:
  fixes v0 :: 'v
  assumes FIN[simp,intro!]: "finite (E\<^sup>*``{v0})"
  shows "blue_dfs E A v0 \<le> SPEC (\<lambda>r.
    case r of None \<Rightarrow> \<not>has_acc_cycle E A v0
  | Some (v,pc,pv) \<Rightarrow> is_acc_cycle E A v0 v pv pc)"
proof -
  let ?ndfs = "
  do {
    (_,_,_,cyc) \<leftarrow> REC\<^sub>T (\<lambda>D (blues,reds,onstack,s). do {
      let blues=insert s blues;
      let onstack=insert s onstack;
      (blues,reds,onstack,cyc) \<leftarrow>
      FOREACH\<^sub>C (E``{s}) (\<lambda>(_,_,_,cyc). cyc=NO_CYC)
        (\<lambda>t (blues,reds,onstack,cyc).
          if t\<notin>blues then do {
            (blues,reds,onstack,cyc) \<leftarrow> D (blues,reds,onstack,t);
            RETURN (blues,reds,onstack,(prep_wit_blue s cyc))
          } else RETURN (blues,reds,onstack,cyc))
        (blues,reds,onstack,NO_CYC);

      (reds,cyc) \<leftarrow>
      if cyc=NO_CYC \<and> s\<in>A then do {
        (reds,rcyc) \<leftarrow> red_dfs E onstack reds s;
        RETURN (reds, init_wit_blue s rcyc)
      } else RETURN (reds,cyc);

      let onstack=onstack - {s};
      RETURN (blues,reds,onstack,cyc)
    }) ({},{},{},s);
    RETURN (case cyc of NO_CYC \<Rightarrow> None | CIRC v pc pr \<Rightarrow> Some (v,pc,pr))
  }"
  let "do {_ \<leftarrow> REC\<^sub>T ?body ?init; _}" = "?ndfs"

  let ?U = "E\<^sup>*``{v0}"

  define add_inv where "add_inv = (\<lambda>blues reds onstack.
    \<not>(\<exists>v\<in>(blues-onstack)\<inter>A. (v,v)\<in>E\<^sup>+)  \<comment> \<open>No cycles over finished, accepting states\<close>
    \<and> reds \<subseteq> blues                     \<comment> \<open>Red nodes are also blue\<close>
    \<and> reds \<inter> onstack = {}              \<comment> \<open>No red nodes on stack\<close>
    \<and> red_dfs_inv E ?U reds onstack)"

  define cyc_post where "cyc_post = (\<lambda>blues reds onstack u0 cyc. (case cyc of
      NO_CYC \<Rightarrow> add_inv blues reds onstack
    | REACH v p u p' \<Rightarrow> v\<in>A \<and> u\<in>onstack-{u0} \<and> p\<noteq>[]
      \<and> path E v p u \<and> path E u0 p' v
    | CIRC v pc pr \<Rightarrow> v\<in>A \<and> pc\<noteq>[] \<and> path E v pc v \<and> path E u0 pr v
    ))"

  define pre where "pre = (\<lambda>(blues,reds,onstack,u).
    gen_dfs_pre E ?U onstack blues u \<and> add_inv blues reds onstack)"

  define post where "post = (\<lambda>(blues0,reds0::'v set,onstack0,u0) (blues,reds,onstack,cyc).
    onstack = onstack0
    \<and> gen_dfs_post E ?U onstack0 blues0 u0 blues (cyc\<noteq>NO_CYC)
    \<and> cyc_post blues reds onstack u0 cyc)"

  define fe_inv where "fe_inv = (\<lambda>blues0 u0 onstack0 it (blues,reds,onstack,cyc).
    onstack=onstack0
    \<and> gen_dfs_fe_inv E ?U onstack0 blues0 u0 it blues (cyc\<noteq>NO_CYC)
    \<and> cyc_post blues reds onstack u0 cyc)"

  have GENPRE: "gen_dfs_pre E ?U {} {} v0"
    apply (auto intro: gen_dfs_pre_initial)
    done
  hence PRE': "pre ({},{},{},v0)"
    unfolding pre_def add_inv_def
    apply (auto intro: red_dfs_inv_initial)
    done

  {
    fix blues reds onstack cyc
    assume "post ({},{},{},v0) (blues,reds,onstack,cyc)"
    hence "case cyc of NO_CYC \<Rightarrow> \<not>has_acc_cycle E A v0
      | REACH _ _ _ _ \<Rightarrow> False
      | CIRC v pc pr \<Rightarrow> is_acc_cycle E A v0 v pr pc"
      unfolding post_def cyc_post_def
      apply (cases cyc)
      using gen_dfs_post_imp_eq[OF GENPRE, of blues]
      apply (auto simp: add_inv_def has_acc_cycle_def) []
      apply auto []
      apply (auto simp: is_acc_cycle_def) []
      done
  } note IMP_POST = this

  {
    fix onstack blues u0 reds
    assume "pre (blues,reds,onstack,u0)"
    hence "fe_inv (insert u0 blues) u0 (insert u0 onstack) (E``{u0})
      (insert u0 blues,reds,insert u0 onstack,NO_CYC)"
      unfolding fe_inv_def add_inv_def cyc_post_def
      apply clarsimp
      apply (intro conjI)
      apply (simp add: pre_def gen_dfs_pre_imp_fe)
      apply (auto simp: pre_def add_inv_def) []
      apply (auto simp: pre_def add_inv_def) []
      defer
      apply (auto simp: pre_def add_inv_def) []
      apply (unfold pre_def add_inv_def red_dfs_inv_def gen_dfs_pre_def) []
      apply clarsimp
      apply blast

      apply (auto simp: pre_def add_inv_def gen_dfs_pre_def) []
      done
  } note PRE_IMP_FE = this

  have [simp]: "\<And>u cyc. prep_wit_blue u cyc = NO_CYC \<longleftrightarrow> cyc=NO_CYC"
    by (case_tac cyc) auto

  {
    fix blues0 reds0 onstack0 u0
      blues reds onstack blues' reds' onstack'
      cyc it t
    assume PRE: "pre (blues0,reds0,onstack0,u0)"
    assume FEI: "fe_inv (insert u0 blues0) u0 (insert u0 onstack0)
        it (blues,reds,onstack,NO_CYC)"
    assume IT: "t\<in>it" "it\<subseteq>E``{u0}" "t\<notin>blues"
    assume POST: "post (blues,reds,onstack, t) (blues',reds',onstack',cyc)"
    note [simp del] = path_simps
    have "fe_inv (insert u0 blues0) u0 (insert u0 onstack0) (it-{t})
      (blues',reds',onstack',prep_wit_blue u0 cyc)"
      unfolding fe_inv_def
      using PRE FEI IT POST
      unfolding fe_inv_def post_def pre_def
      apply (clarsimp)
      apply (intro allI impI conjI)
      apply (blast intro: gen_dfs_post_imp_fe_inv)
      unfolding cyc_post_def
      apply (auto split: blue_witness.split_asm intro: path_conc path_prepend)
      done
  } note FE_INV_PRES=this

  {
    fix blues reds onstack u0
    assume "pre (blues,reds,onstack,u0)"
    hence "(v0,u0)\<in>E\<^sup>*"
      unfolding pre_def gen_dfs_pre_def by auto
  } note PRE_IMP_REACH = this

  {
    fix blues0 reds0 onstack0 u0 blues reds onstack
    assume A: "pre (blues0,reds0,onstack0,u0)"
       "fe_inv (insert u0 blues0) u0 (insert u0 onstack0)
        {} (blues,reds,onstack,NO_CYC)"
       "u0\<in>A"
    have "u0\<notin>reds" using A
      unfolding fe_inv_def add_inv_def pre_def cyc_post_def
      apply auto
      done
  } note FE_IMP_RED_PRE = this

  {
    fix blues0 reds0 onstack0 u0 blues reds onstack rcyc reds'
    assume PRE: "pre (blues0,reds0,onstack0,u0)"
    assume FEI: "fe_inv (insert u0 blues0) u0 (insert u0 onstack0)
        {} (blues,reds,onstack,NO_CYC)"
    assume ACC: "u0\<in>A"
    assume SPECR: "case rcyc of
      Some (p,v) \<Rightarrow> v\<in>onstack \<and> p\<noteq>[] \<and> path E u0 p v
    | None \<Rightarrow>
        red_dfs_inv E ?U reds' onstack
        \<and> u0\<in>reds'
        \<and> reds' \<subseteq> reds \<union> E\<^sup>* `` {u0}"
    have "post (blues0,reds0,onstack0,u0)
      (blues,reds',onstack - {u0},init_wit_blue u0 rcyc)"
      unfolding post_def add_inv_def cyc_post_def
      apply (clarsimp)
      apply (intro conjI)
    proof goal_cases
      from PRE FEI show OS0[symmetric]: "onstack - {u0} = onstack0"
        by (auto simp: pre_def fe_inv_def add_inv_def gen_dfs_pre_def) []

      from PRE FEI have "u0\<in>onstack"
        unfolding pre_def gen_dfs_pre_def fe_inv_def gen_dfs_fe_inv_def
        by auto

      from PRE FEI
      show POST: "gen_dfs_post E (E\<^sup>* `` {v0}) onstack0 blues0 u0 blues
        (init_wit_blue u0 rcyc \<noteq> NO_CYC)"
        by (auto simp: pre_def fe_inv_def intro: gen_dfs_fe_inv_imp_post)

      case 3

      from FEI have [simp]: "onstack=insert u0 onstack0"
        unfolding fe_inv_def by auto
      from FEI have "u0\<in>blues" unfolding fe_inv_def gen_dfs_fe_inv_def by auto

      show ?case
        apply (cases rcyc)
        apply (simp_all add: split_paired_all)
      proof -
        assume [simp]: "rcyc=None"
        show "(\<forall>v\<in>(blues - (onstack0 - {u0})) \<inter> A. (v, v) \<notin> E\<^sup>+) \<and>
          reds' \<subseteq> blues \<and>
          reds' \<inter> (onstack0 - {u0}) = {} \<and>
          red_dfs_inv E (E\<^sup>* `` {v0}) reds' (onstack0 - {u0})"
        proof (intro conjI)
          from SPECR have RINV: "red_dfs_inv E ?U reds' onstack"
            and "u0\<in>reds'"
            and REDS'R: "reds' \<subseteq> reds \<union> E\<^sup>*``{u0}"
            by auto

          from RINV show
            RINV': "red_dfs_inv E (E\<^sup>* `` {v0}) reds' (onstack0 - {u0})"
            unfolding red_dfs_inv_def by auto

          from RINV'[unfolded red_dfs_inv_def] have
            REDS'CL: "E``reds' \<subseteq> reds'"
            and DJ': "E `` reds' \<inter> (onstack0 - {u0}) = {}" by auto

          from RINV[unfolded red_dfs_inv_def] have
            DJ: "E `` reds' \<inter> (onstack) = {}" by auto

          show "reds' \<subseteq> blues"
          proof
            fix v assume "v\<in>reds'"
            with REDS'R have "v\<in>reds \<or> (u0,v)\<in>E\<^sup>*" by blast
            thus "v\<in>blues" proof
              assume "v\<in>reds"
              moreover with FEI have "reds\<subseteq>blues"
                unfolding fe_inv_def add_inv_def cyc_post_def by auto
              ultimately show ?thesis ..
            next
              from POST[unfolded gen_dfs_post_def OS0] have
                CL: "E `` (blues - (onstack0 - {u0})) \<subseteq> blues" and "u0\<in>blues"
                by auto
              from PRE FEI have "onstack0 \<subseteq> blues"
                unfolding pre_def fe_inv_def gen_dfs_pre_def gen_dfs_fe_inv_def
                by auto

              assume "(u0,v)\<in>E\<^sup>*"
              thus "v\<in>blues"
              proof (cases rule: rtrancl_last_visit[where S="onstack - {u0}"])
                case no_visit
                thus "v\<in>blues" using \<open>u0\<in>blues\<close> CL
                  by induct (auto elim: rtranclE)
              next
                case (last_visit_point u)
                then obtain uh where "(u0,uh)\<in>E\<^sup>*" and "(uh,u)\<in>E"
                  by (metis tranclD2)
                with REDS'CL DJ' \<open>u0\<in>reds'\<close> have "uh\<in>reds'"
                  by (auto dest: Image_closed_trancl)
                with DJ' \<open>(uh,u)\<in>E\<close> \<open>u \<in> onstack - {u0}\<close> have False
                  by simp blast
                thus ?thesis ..
              qed
            qed
          qed

          show "\<forall>v\<in>(blues - (onstack0 - {u0})) \<inter> A. (v, v) \<notin> E\<^sup>+"
          proof
            fix v
            assume A: "v \<in> (blues - (onstack0 - {u0})) \<inter> A"
            show "(v,v)\<notin>E\<^sup>+" proof (cases "v=u0")
              assume "v\<noteq>u0"
              with A have "v\<in>(blues - (insert u0 onstack)) \<inter> A" by auto
              with FEI show ?thesis
                unfolding fe_inv_def add_inv_def cyc_post_def by auto
            next
              assume [simp]: "v=u0"
              show ?thesis proof
                assume "(v,v)\<in>E\<^sup>+"
                then obtain uh where "(u0,uh)\<in>E\<^sup>*" and "(uh,u0)\<in>E"
                  by (auto dest: tranclD2)
                with REDS'CL DJ \<open>u0\<in>reds'\<close> have "uh\<in>reds'"
                  by (auto dest: Image_closed_trancl)
                with DJ \<open>(uh,u0)\<in>E\<close> \<open>u0 \<in> onstack\<close> show False by blast
              qed
            qed
          qed

          show "reds' \<inter> (onstack0 - {u0}) = {}"
          proof (rule ccontr)
            assume "reds' \<inter> (onstack0 - {u0}) \<noteq> {}"
            then obtain v where "v\<in>reds'" and "v\<in>onstack0" and "v\<noteq>u0" by auto

            from \<open>v\<in>reds'\<close> REDS'R have "v\<in>reds \<or> (u0,v)\<in>E\<^sup>*"
              by auto
            thus False proof
              assume "v\<in>reds"
              with FEI[unfolded fe_inv_def add_inv_def cyc_post_def]
                \<open>v\<in>onstack0\<close>
              show False by auto
            next
              assume "(u0,v)\<in>E\<^sup>*"
              with \<open>v\<noteq>u0\<close> obtain uh where "(u0,uh)\<in>E\<^sup>*" and "(uh,v)\<in>E"
                by (auto elim: rtranclE)
              with REDS'CL DJ \<open>u0\<in>reds'\<close> have "uh\<in>reds'"
                by (auto dest: Image_closed_trancl)
              with DJ \<open>(uh,v)\<in>E\<close> \<open>v \<in> onstack0\<close> show False by simp blast
            qed
          qed
        qed
      next
        fix u p
        assume [simp]: "rcyc = Some (p,u)"
        show "(u = u0 \<longrightarrow> u0 \<in> A \<and> p \<noteq> [] \<and> path E u0 p u0) \<and>
          (u \<noteq> u0 \<longrightarrow> u0 \<in> A \<and> u \<in> onstack0 \<and> p \<noteq> [] \<and> path E u0 p u)"
        proof (intro conjI impI)
          show "u0\<in>A" by fact
          show "u0\<in>A" by fact
          from SPECR show
            "u\<noteq>u0 \<Longrightarrow> u\<in>onstack0"
            "p\<noteq>[]"
            "p\<noteq>[]"
            "path E u0 p u"
            "u=u0 \<Longrightarrow> path E u0 p u0"
            by auto
        qed
      qed
    qed
  } note RED_IMP_POST = this

  {
    fix blues0 reds0 onstack0 u0 blues reds onstack and cyc :: "'v blue_witness"
    assume PRE: "pre (blues0,reds0,onstack0,u0)"
    and FEI: "fe_inv (insert u0 blues0) u0 (insert u0 onstack0)
        {} (blues,reds,onstack,NO_CYC)"
    and FC[simp]: "cyc=NO_CYC"
    and NCOND: "u0\<notin>A"

    from PRE FEI have OS0: "onstack0 = onstack - {u0}"
      by (auto simp: pre_def fe_inv_def add_inv_def gen_dfs_pre_def) []

    from PRE FEI have "u0\<in>onstack"
      unfolding pre_def gen_dfs_pre_def fe_inv_def gen_dfs_fe_inv_def
      by auto
    with OS0 have OS1: "onstack = insert u0 onstack0" by auto

    have "post (blues0,reds0,onstack0,u0) (blues,reds,onstack - {u0},NO_CYC)"
      apply (clarsimp simp: post_def cyc_post_def) []
      apply (intro conjI impI)
      apply (simp add: OS0)
      using PRE FEI apply (auto
        simp: pre_def fe_inv_def intro: gen_dfs_fe_inv_imp_post) []

      using FEI[unfolded fe_inv_def cyc_post_def] unfolding add_inv_def
      apply clarsimp
      apply (intro conjI)
      using NCOND apply auto []
      apply auto []
      apply (clarsimp simp: red_dfs_inv_def, blast) []
      done
  } note NCOND_IMP_POST=this

  {
    fix blues0 reds0 onstack0 u0 blues reds onstack it
      and cyc :: "'v blue_witness"
    assume PRE: "pre (blues0,reds0,onstack0,u0)"
    and FEI: "fe_inv (insert u0 blues0) u0 (insert u0 onstack0)
        it (blues,reds,onstack,cyc)"
    and NC: "cyc\<noteq>NO_CYC"
    and IT: "it\<subseteq>E``{u0}"
    from PRE FEI have OS0: "onstack0 = onstack - {u0}"
      by (auto simp: pre_def fe_inv_def add_inv_def gen_dfs_pre_def) []

    from PRE FEI have "u0\<in>onstack"
      unfolding pre_def gen_dfs_pre_def fe_inv_def gen_dfs_fe_inv_def
      by auto
    with OS0 have OS1: "onstack = insert u0 onstack0" by auto

    have "post (blues0,reds0,onstack0,u0) (blues,reds,onstack - {u0},cyc)"
      apply (clarsimp simp: post_def) []
      apply (intro conjI impI)
      apply (simp add: OS0)
      using PRE FEI IT NC apply (auto
        simp: pre_def fe_inv_def intro: gen_dfs_fe_imp_post_brk) []
      using FEI[unfolded fe_inv_def] NC
      unfolding cyc_post_def
      apply (auto split: blue_witness.split simp: OS1) []
      done
  } note BREAK_IMP_POST = this

  {
    fix \<sigma>
    assume INV0: "pre \<sigma>"
    have "REC\<^sub>T ?body \<sigma>
      \<le> SPEC (post \<sigma>)"

      apply (intro refine_vcg
        RECT_rule[where pre="pre"
        and V="gen_dfs_var ?U <*lex*> {}"]
      )
      apply refine_mono
      apply (blast intro!: gen_dfs_pre_imp_wf[OF GENPRE])
      apply (rule INV0)

      \<comment> \<open>Foreach loop\<close>
      apply (rule_tac
        I="fe_inv (insert bb a) bb (insert bb ab)"
        in FOREACHc_rule')

      apply (auto simp add: pre_def gen_dfs_pre_imp_fin) []

      apply (blast intro: PRE_IMP_FE)

      apply (intro refine_vcg)

      \<comment> \<open>Recursive call\<close>
      apply (rule order_trans)
      apply (rprems)
      apply (clarsimp simp add: pre_def fe_inv_def cyc_post_def)
      apply (rule gen_dfs_fe_inv_imp_pre, assumption+) []
      apply (auto simp add: pre_def fe_inv_def intro: gen_dfs_fe_inv_imp_var) []

      apply (auto intro: FE_INV_PRES) []

      apply (auto simp add: pre_def post_def fe_inv_def
        intro: gen_dfs_fe_inv_pres_visited) []

      apply (intro refine_vcg)

      \<comment> \<open>Nested DFS call\<close>
      apply (rule order_trans)
      apply (rule red_dfs_correct[where U="E\<^sup>* `` {v0}"])
      apply (auto simp add: fe_inv_def add_inv_def cyc_post_def) []
      apply (auto intro: PRE_IMP_REACH) []
      apply (auto dest: FE_IMP_RED_PRE) []

      apply (intro refine_vcg)
      apply clarsimp
      apply (rule RED_IMP_POST, assumption+) []

      apply (clarsimp, blast intro: NCOND_IMP_POST) []

      apply (intro refine_vcg)
      apply simp

      apply (clarsimp, blast intro: BREAK_IMP_POST) []
      done
  } note GEN=this

  show ?thesis
    unfolding blue_dfs_def extract_res_def
    apply (intro refine_vcg)
    apply (rule order_trans)
    apply (rule GEN)
    apply fact
    apply (intro refine_vcg)
    apply clarsimp
    apply (drule IMP_POST)
    apply (simp split: blue_witness.split_asm)
    done
qed

subsection "Refinement"

subsubsection \<open>Setup for Custom Datatypes\<close>
text \<open>This effort can be automated, but currently, such an automation is
  not yet implemented\<close>
abbreviation "red_wit_rel \<equiv> \<langle>\<langle>\<langle>nat_rel\<rangle>list_rel,nat_rel\<rangle>prod_rel\<rangle>option_rel"
abbreviation "wit_res_rel \<equiv>
  \<langle>\<langle>nat_rel,\<langle>\<langle>nat_rel\<rangle>list_rel,\<langle>nat_rel\<rangle>list_rel\<rangle>prod_rel\<rangle>prod_rel\<rangle>option_rel"
abbreviation "i_red_wit \<equiv> \<langle>\<langle>\<langle>i_nat\<rangle>\<^sub>ii_list,i_nat\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_option"
abbreviation "i_res \<equiv>
  \<langle>\<langle>i_nat,\<langle>\<langle>i_nat\<rangle>\<^sub>ii_list,\<langle>i_nat\<rangle>\<^sub>ii_list\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_option"

abbreviation "blue_wit_rel \<equiv> (Id::(nat blue_witness \<times> _) set)"
consts i_blue_wit :: interface

term extract_res

lemma [autoref_itype]:
  "NO_CYC ::\<^sub>i i_blue_wit"
  "(=) ::\<^sub>i i_blue_wit \<rightarrow>\<^sub>i i_blue_wit \<rightarrow>\<^sub>i i_bool"
  "init_wit_blue ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_red_wit \<rightarrow>\<^sub>i i_blue_wit"
  "prep_wit_blue ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_blue_wit \<rightarrow>\<^sub>i i_blue_wit"
  "red_init_witness ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_nat \<rightarrow>\<^sub>i i_red_wit"
  "prep_wit_red ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_red_wit \<rightarrow>\<^sub>i i_red_wit"
  "extract_res ::\<^sub>i i_blue_wit \<rightarrow>\<^sub>i i_res"
  by auto

context begin interpretation autoref_syn .

lemma autoref_wit[autoref_rules_raw]:
  "(NO_CYC,NO_CYC)\<in>blue_wit_rel"
  "((=), (=)) \<in> blue_wit_rel \<rightarrow> blue_wit_rel \<rightarrow> bool_rel"
  "(init_wit_blue, init_wit_blue) \<in> nat_rel \<rightarrow> red_wit_rel \<rightarrow> blue_wit_rel"
  "(prep_wit_blue,prep_wit_blue)\<in>nat_rel \<rightarrow> blue_wit_rel \<rightarrow> blue_wit_rel"
  "(red_init_witness, red_init_witness) \<in> nat_rel\<rightarrow>nat_rel\<rightarrow>red_wit_rel"
  "(prep_wit_red,prep_wit_red) \<in> nat_rel \<rightarrow> red_wit_rel \<rightarrow> red_wit_rel"
  "(extract_res,extract_res) \<in> blue_wit_rel \<rightarrow> wit_res_rel"
  by simp_all

subsubsection \<open>Actual Refinement\<close>

schematic_goal red_dfs_impl_refine_aux:
  (*notes [[goals_limit = 1]]*)
  fixes u'::"nat" and V'::"nat set"
  notes [autoref_tyrel] =
    ty_REL[where 'a="nat set" and R="\<langle>nat_rel\<rangle>iam_set_rel"]
  assumes [autoref_rules]:
    "(u,u')\<in>nat_rel"
    "(V,V')\<in>\<langle>nat_rel\<rangle>iam_set_rel"
    "(onstack,onstack')\<in>\<langle>nat_rel\<rangle>iam_set_rel"
    "(E,E')\<in>\<langle>nat_rel\<rangle>slg_rel"
  shows "(RETURN (?f::?'c), red_dfs E' onstack' V' u') \<in> ?R"
  apply -
  unfolding red_dfs_def
  apply (autoref_monadic)
  done

concrete_definition red_dfs_impl uses red_dfs_impl_refine_aux
prepare_code_thms red_dfs_impl_def
declare red_dfs_impl.refine[autoref_higher_order_rule, autoref_rules]

schematic_goal ndfs_impl_refine_aux:
  fixes s::"nat"
  notes [autoref_tyrel] =
    ty_REL[where 'a="nat set" and R="\<langle>nat_rel\<rangle>iam_set_rel"]
  assumes [autoref_rules]:
    "(succi,E)\<in>\<langle>nat_rel\<rangle>slg_rel"
    "(Ai,A)\<in>\<langle>nat_rel\<rangle>iam_set_rel"
  notes [autoref_rules] = IdI[of s]
  shows "(RETURN (?f::?'c), blue_dfs E A s) \<in> \<langle>?R\<rangle>nres_rel"
  unfolding blue_dfs_def
  apply (autoref_monadic (trace))
  done

concrete_definition ndfs_impl for succi Ai s uses ndfs_impl_refine_aux
prepare_code_thms ndfs_impl_def
export_code ndfs_impl checking SML

term "\<lambda>E A v0. ndfs_impl (succ_of_list_impl E) (acc_of_list_impl A) v0"

term nat_of_integer

definition "succ_of_list_impl_int \<equiv>
  succ_of_list_impl o map (\<lambda>(u,v). (nat_of_integer u, nat_of_integer v))"

definition "acc_of_list_impl_int \<equiv>
  acc_of_list_impl o map nat_of_integer"

export_code
  ndfs_impl
  succ_of_list_impl_int
  acc_of_list_impl_int
  nat_of_integer
  integer_of_nat
  in SML module_name HPY_new

ML_val \<open>
  @{code ndfs_impl} (@{code succ_of_list_impl_int} [(1,2),(2,3),(2,7),(7,1)])
    (@{code acc_of_list_impl_int} [7]) (@{code nat_of_integer} 1)

\<close>

schematic_goal ndfs_impl_refine_aux_old:
  fixes s::"nat"
  assumes [autoref_rules]:
    "(succi,E)\<in>\<langle>nat_rel\<rangle>slg_rel"
    "(Ai,A)\<in>\<langle>nat_rel\<rangle>dflt_rs_rel"
  notes [autoref_rules] = IdI[of s]
  shows "(RETURN (?f::?'c), blue_dfs E A s) \<in> \<langle>?R\<rangle>nres_rel"
  unfolding blue_dfs_def red_dfs_def
  using [[autoref_trace]]
  apply (autoref_monadic)
  done

end


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

lemma inputSupportDerivative:
  assumes "P \<longmapsto>a<x> \<prec> P'"

  shows "(supp P') - {x} \<subseteq> supp P"
using assms
apply(nominal_induct rule: inputInduct)
apply(auto simp add: pi.supp abs_supp supp_atm)
apply(rule ccontr)
apply(simp add: fresh_def[symmetric])
apply(drule_tac fresh_fact1)
apply(rotate_tac 4)
apply assumption
apply(simp add: fresh_def)
apply force
apply(case_tac "x \<sharp> P")
apply(drule_tac fresh_fact1)
apply(rotate_tac 2)
apply assumption
apply(simp add: fresh_def)
apply force
apply(rotate_tac 2)
apply(drule_tac fresh_fact2)
apply(simp add: fresh_def)
by force

lemma outputSupportDerivative:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  assumes "P \<longmapsto>a[b] \<prec> P'"

  shows "(supp P') \<subseteq> ((supp P)::name set)"
using assms
by(nominal_induct rule: outputInduct) (auto simp add: pi.supp abs_supp)

lemma boundOutputSupportDerivative:
  assumes "P \<longmapsto>a<\<nu>x> \<prec> P'"
  and     "x \<sharp> P"

  shows "(supp P') - {x} \<subseteq> supp P"
using assms
by(nominal_induct rule: boundOutputInduct) (auto simp add: pi.supp abs_supp supp_atm dest: outputSupportDerivative)

lemma tauSupportDerivative:

  assumes "P \<longmapsto>\<tau> \<prec> P'"

  shows "((supp P')::name set) \<subseteq> supp P"
using assms
proof(nominal_induct rule: tauInduct)
  case(Tau P)
  thus ?case by(force simp add: pi.supp)
next
  case(Match P)
  thus ?case by(force simp add: pi.supp)
next
  case(Mismatch P)
  thus ?case by(force simp add: pi.supp)
next
  case(Sum1 P)
  thus ?case by(force simp add: pi.supp)
next
  case(Sum2 P)
  thus ?case by(force simp add: pi.supp)
next
  case(Par1 P)
  thus ?case by(force simp add: pi.supp)
next
  case(Par2 P)
  thus ?case by(force simp add: pi.supp)
next
  case(Comm1 P a b P' Q Q')
  from `P \<longmapsto>a<b> \<prec> P'` have "(supp P') - {b} \<subseteq> supp P" by(rule inputSupportDerivative)
  moreover from `Q \<longmapsto> a[b] \<prec> Q'` have "((supp Q')::name set) \<subseteq> supp Q" by(rule outputSupportDerivative)
  moreover from `Q \<longmapsto> a[b] \<prec> Q'` have "b \<in> supp Q"
    by(nominal_induct rule: outputInduct) (auto simp add: pi.supp abs_supp supp_atm)
  ultimately show ?case by(auto simp add: pi.supp)
next
  case(Comm2 P a b P' Q Q')
  from `P \<longmapsto> a[b] \<prec> P'` have "((supp P')::name set) \<subseteq> supp P" by(rule outputSupportDerivative)
  moreover from `Q \<longmapsto>a<b> \<prec> Q'` have "(supp Q') - {b} \<subseteq> supp Q" by(rule inputSupportDerivative)
  moreover from `P \<longmapsto> a[b] \<prec> P'` have "b \<in> supp P"
    by(nominal_induct rule: outputInduct) (auto simp add: pi.supp abs_supp supp_atm)
  ultimately show ?case by(auto simp add: pi.supp)
next
  case(Close1 P a x P' Q Q')
  thus ?case by(auto dest: inputSupportDerivative boundOutputSupportDerivative simp add: abs_supp pi.supp)
next
  case(Close2 P a x P' Q Q')
  thus ?case by(auto dest: inputSupportDerivative boundOutputSupportDerivative simp add: abs_supp pi.supp)
next
  case(Res P P' x)
  thus ?case by(force simp add: pi.supp abs_supp)
next
  case(Bang P P')
  thus ?case by(force simp add: pi.supp)
qed

lemma tauChainSupportDerivative:
  fixes P  :: pi
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"

  shows "((supp P')::name set) \<subseteq> (supp P)"
using assms
by(induct rule: tauChainInduct) (auto dest: tauSupportDerivative)

definition outputTransition :: "pi \<Rightarrow> name \<Rightarrow> name \<Rightarrow> pi \<Rightarrow> bool" ("_ \<Longrightarrow>_<\<nu>_> \<prec> _" [80, 80, 80, 80] 80)
  where "P \<Longrightarrow>a<\<nu>x> \<prec> P' \<equiv> \<exists>P''' P''. P \<Longrightarrow>\<^sub>\<tau> P''' \<and> P''' \<longmapsto>a<\<nu>x> \<prec> P'' \<and> P'' \<Longrightarrow>\<^sub>\<tau> P'"

definition freeTransition :: "pi \<Rightarrow> freeRes\<Rightarrow> pi \<Rightarrow> bool" ("_ \<Longrightarrow>_ \<prec> _" [80, 80, 80] 80)
  where "P \<Longrightarrow>\<alpha> \<prec> P' \<equiv> \<exists>P''' P''. P \<Longrightarrow>\<^sub>\<tau> P''' \<and> P''' \<longmapsto>\<alpha> \<prec> P'' \<and> P'' \<Longrightarrow>\<^sub>\<tau> P'"

lemma transitionI:
  fixes P    :: pi
  and   P''' :: pi
  and   \<alpha>    :: freeRes
  and   P''  :: pi
  and   P'   :: pi
  and   a    :: name
  and   x    :: name

  shows "\<lbrakk>P \<Longrightarrow>\<^sub>\<tau> P'''; P''' \<longmapsto>\<alpha> \<prec> P''; P'' \<Longrightarrow>\<^sub>\<tau> P'\<rbrakk> \<Longrightarrow> P \<Longrightarrow>\<alpha> \<prec> P'"
  and   "\<lbrakk>P \<Longrightarrow>\<^sub>\<tau> P'''; P''' \<longmapsto>a<\<nu>x> \<prec> P''; P'' \<Longrightarrow>\<^sub>\<tau> P'\<rbrakk> \<Longrightarrow> P \<Longrightarrow>a<\<nu>x> \<prec> P'"
by(auto simp add: outputTransition_def freeTransition_def)

lemma transitionE:
  fixes P  :: pi
  and   \<alpha>  :: freeRes
  and   P' :: pi
  and   a  :: name
  and   x  :: name

  shows "P \<Longrightarrow>\<alpha> \<prec> P' \<Longrightarrow> (\<exists>P'' P'''. P \<Longrightarrow>\<^sub>\<tau> P'' \<and> P'' \<longmapsto>\<alpha> \<prec> P''' \<and> P''' \<Longrightarrow>\<^sub>\<tau> P')"
  and   "P \<Longrightarrow>a<\<nu>x> \<prec> P' \<Longrightarrow> \<exists>P'' P'''. P \<Longrightarrow>\<^sub>\<tau> P''' \<and> P''' \<longmapsto>a<\<nu>x> \<prec> P'' \<and> P'' \<Longrightarrow>\<^sub>\<tau> P'"
by(auto simp add: outputTransition_def freeTransition_def)

lemma weakTransitionAlpha:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi
  and   y  :: name

  assumes PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  and     "y \<sharp> P"

  shows "P \<Longrightarrow>a<\<nu>y> \<prec> ([(x, y)] \<bullet> P')"
proof(cases "y=x")
  case True
  with PTrans show ?thesis by simp
next
  case False
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a<\<nu>x> \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: transitionE)
  note PChain
  moreover from PChain `y \<sharp> P` have "y \<sharp> P'''" by(rule freshChain)
  with P'''Trans have "y \<sharp> P''" using `y \<noteq> x` by(rule freshTransition)
  with P'''Trans have "P''' \<longmapsto>a<\<nu>y> \<prec> ([(x, y)] \<bullet> P'')" by(simp add: alphaBoundOutput name_swap)
  moreover from P''Chain have "([(x, y)] \<bullet> P'') \<Longrightarrow>\<^sub>\<tau> ([(x, y)] \<bullet> P')"
    by(rule eqvtChainI)
  ultimately show ?thesis by(rule transitionI)
qed

lemma singleActionChain:
  fixes P  :: pi
  and   Rs :: residual

  shows "P \<longmapsto>a<\<nu>x> \<prec> P' \<Longrightarrow> P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  and   "P \<longmapsto>\<alpha> \<prec> P' \<Longrightarrow> P \<Longrightarrow>\<alpha> \<prec> P'"
proof -
  have "P \<Longrightarrow>\<^sub>\<tau> P" by simp
  moreover assume "P \<longmapsto>a<\<nu>x> \<prec> P'"
  moreover have "P' \<Longrightarrow>\<^sub>\<tau> P'" by simp
  ultimately show "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
    by(rule transitionI)
next
  have "P \<Longrightarrow>\<^sub>\<tau> P" by simp
  moreover assume "P \<longmapsto>\<alpha> \<prec> P'"
  moreover have "P' \<Longrightarrow>\<^sub>\<tau> P'" by simp
  ultimately show "P \<Longrightarrow>\<alpha> \<prec> P'"
    by(rule transitionI)
qed

lemma Tau:
  fixes P :: pi

  shows "\<tau>.(P) \<Longrightarrow> \<tau> \<prec>  P"
proof -
  have "\<tau>.(P) \<Longrightarrow>\<^sub>\<tau> \<tau>.(P)" by simp
  moreover have "\<tau>.(P) \<longmapsto>\<tau> \<prec> P" by(rule Early_Semantics.Tau)
  moreover have "P \<Longrightarrow>\<^sub>\<tau> P" by simp
  ultimately show ?thesis by(rule transitionI)
qed

lemma Input:
  fixes a :: name
  and   x :: name
  and   u :: name
  and   P :: pi

  shows "a<x>.P \<Longrightarrow> a<u> \<prec> P[x::=u]"
proof -
  have "a<x>.P \<Longrightarrow>\<^sub>\<tau> a<x>.P" by simp
  moreover have "a<x>.P \<longmapsto> a<u> \<prec> P[x::=u]" by(rule Early_Semantics.Input)
  moreover have "P[x::=u] \<Longrightarrow>\<^sub>\<tau> P[x::=u]" by simp
  ultimately show ?thesis by(rule transitionI)
qed

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

  shows "a{b}.P \<Longrightarrow>a[b] \<prec> P"
proof -
  have "a{b}.P \<Longrightarrow>\<^sub>\<tau> a{b}.P" by simp
  moreover have "a{b}.P \<longmapsto>a[b] \<prec> P" by(rule Early_Semantics.Output)
  moreover have "P \<Longrightarrow>\<^sub>\<tau> P" by simp
  ultimately show ?thesis by(rule transitionI)
qed

lemma Match:
  fixes P  :: pi
  and   b  :: name
  and   x  :: name
  and   a  :: name
  and   P' :: pi
  and   \<alpha> :: freeRes

  shows "P \<Longrightarrow>b<\<nu>x> \<prec> P' \<Longrightarrow> [a\<frown>a]P \<Longrightarrow>b<\<nu>x> \<prec> P'"
  and   "P \<Longrightarrow>\<alpha> \<prec> P' \<Longrightarrow> [a\<frown>a]P \<Longrightarrow>\<alpha> \<prec> P'"
proof -
  assume "P \<Longrightarrow> b<\<nu>x> \<prec> P'"
  then obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                         and P'''Trans: "P''' \<longmapsto>b<\<nu>x> \<prec> P''"
                         and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: transitionE)
  show "[a\<frown>a]P \<Longrightarrow>b<\<nu>x> \<prec> P'"
  proof(cases "P = P'''")
    case True
    have "[a\<frown>a]P \<Longrightarrow>\<^sub>\<tau> [a\<frown>a]P" by simp
    moreover from `P = P'''` P'''Trans have "[a\<frown>a]P \<longmapsto> b<\<nu>x> \<prec> P''"
      by(rule_tac Early_Semantics.Match) auto
    ultimately show ?thesis using P''Chain by(rule transitionI)
  next
    case False
    from PChain `P \<noteq> P'''` have "[a\<frown>a]P \<Longrightarrow>\<^sub>\<tau> P'''" by(rule matchChain)
    thus ?thesis using P'''Trans P''Chain by(rule transitionI)
  qed
next
  assume "P \<Longrightarrow>\<alpha> \<prec> P'"
  then obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                         and P'''Trans: "P''' \<longmapsto>\<alpha> \<prec> P''"
                         and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: transitionE)
  show "[a\<frown>a]P \<Longrightarrow>\<alpha> \<prec> P'"
  proof(cases "P = P'''")
    case True
    have "[a\<frown>a]P \<Longrightarrow>\<^sub>\<tau> [a\<frown>a]P" by simp
    moreover from `P = P'''` P'''Trans have "[a\<frown>a]P \<longmapsto>\<alpha> \<prec> P''"
      by(rule_tac Early_Semantics.Match) auto
    ultimately show ?thesis using P''Chain by(rule transitionI)
  next
    case False
    from PChain `P \<noteq> P'''` have "[a\<frown>a]P \<Longrightarrow>\<^sub>\<tau> P'''" by(rule matchChain)
    thus ?thesis using P'''Trans P''Chain by(rule transitionI)
  qed
qed

lemma Mismatch:
  fixes P  :: pi
  and   c  :: name
  and   x  :: name
  and   a  :: name
  and   b  :: name
  and   P' :: pi
  and   \<alpha> :: freeRes

  shows "\<lbrakk>P \<Longrightarrow>c<\<nu>x> \<prec> P'; a \<noteq> b\<rbrakk> \<Longrightarrow> [a\<noteq>b]P \<Longrightarrow>c<\<nu>x> \<prec> P'"
  and   "\<lbrakk>P \<Longrightarrow>\<alpha> \<prec> P'; a \<noteq> b\<rbrakk> \<Longrightarrow> [a\<noteq>b]P \<Longrightarrow>\<alpha> \<prec> P'"
proof -
  assume "P \<Longrightarrow>c<\<nu>x> \<prec> P'"
  then obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                         and P'''Trans: "P''' \<longmapsto>c<\<nu>x> \<prec> P''"
                         and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: transitionE)
  assume "a \<noteq> b"
  show "[a\<noteq>b]P \<Longrightarrow>c<\<nu>x> \<prec> P'"
  proof(cases "P = P'''")
    case True
    have "[a\<noteq>b]P \<Longrightarrow>\<^sub>\<tau> [a\<noteq>b]P" by simp
    moreover from `P = P'''` `a \<noteq> b` P'''Trans have "[a\<noteq>b]P \<longmapsto> c<\<nu>x> \<prec> P''"
      by(rule_tac Early_Semantics.Mismatch) auto
    ultimately show ?thesis using P''Chain by(rule transitionI)
  next
    case False
    from PChain `a \<noteq> b` `P \<noteq> P'''` have "[a\<noteq>b]P \<Longrightarrow>\<^sub>\<tau> P'''" by(rule mismatchChain)
    thus ?thesis using P'''Trans P''Chain by(rule transitionI)
  qed
next
  assume "P \<Longrightarrow>\<alpha> \<prec> P'"
  then obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                         and P'''Trans: "P''' \<longmapsto>\<alpha> \<prec> P''"
                         and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: transitionE)
  assume "a \<noteq> b"
  show "[a\<noteq>b]P \<Longrightarrow>\<alpha> \<prec> P'"
  proof(cases "P = P'''")
    case True
    have "[a\<noteq>b]P \<Longrightarrow>\<^sub>\<tau> [a\<noteq>b]P" by simp
    moreover from `P = P'''` `a \<noteq> b` P'''Trans have "[a\<noteq>b]P \<longmapsto>\<alpha> \<prec> P''"
      by(rule_tac Early_Semantics.Mismatch) auto
    ultimately show ?thesis using P''Chain by(rule transitionI)
  next
    case False
    from PChain `a \<noteq> b` `P \<noteq> P'''` have "[a\<noteq>b]P \<Longrightarrow>\<^sub>\<tau> P'''" by(rule mismatchChain)
    thus ?thesis using P'''Trans P''Chain by(rule transitionI)
  qed
qed

lemma Open:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  assumes PTrans:  "P \<Longrightarrow>a[b] \<prec> P'"
  and     "a \<noteq> b"

  shows "<\<nu>b>P \<Longrightarrow>a<\<nu>b> \<prec> P'"
proof -
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a[b] \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: transitionE)
  from PChain have "<\<nu>b>P \<Longrightarrow>\<^sub>\<tau> <\<nu>b>P'''" by(rule ResChain)
  moreover from P'''Trans `a \<noteq> b` have "<\<nu>b>P''' \<longmapsto>a<\<nu>b> \<prec> P''" by(rule Open)
  ultimately show ?thesis using P''Chain by(rule transitionI)
qed

lemma Sum1:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi
  and   Q  :: pi
  and   \<alpha>  :: freeRes

  shows "P \<Longrightarrow>a<\<nu>x> \<prec> P' \<Longrightarrow> P \<oplus> Q \<Longrightarrow>a<\<nu>x> \<prec> P'"
  and   "P \<Longrightarrow>\<alpha> \<prec> P' \<Longrightarrow> P \<oplus> Q \<Longrightarrow>\<alpha> \<prec> P'"
proof -
  assume "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  then obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                         and P'''Trans: "P''' \<longmapsto>a<\<nu>x> \<prec> P''"
                         and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: transitionE)
  show "P \<oplus> Q \<Longrightarrow>a<\<nu>x> \<prec> P'"
  proof(cases "P = P'''")
    case True
    have "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P \<oplus> Q" by simp
    moreover from P'''Trans `P = P'''` have "P \<oplus> Q \<longmapsto> a<\<nu>x> \<prec> P''" by(blast intro: Sum1)
    ultimately show ?thesis using P''Chain by(rule transitionI)
  next
    case False
    from PChain `P \<noteq> P'''` have "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P'''" by(rule sum1Chain)
    thus ?thesis using P'''Trans P''Chain by(rule transitionI)
  qed
next
  assume "P \<Longrightarrow>\<alpha> \<prec> P'"
  then obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                         and P'''Trans: "P''' \<longmapsto>\<alpha> \<prec> P''"
                         and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: transitionE)
  show "P \<oplus> Q \<Longrightarrow>\<alpha> \<prec> P'"
  proof(cases "P = P'''")
    case True
    have "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P \<oplus> Q" by simp
    moreover from P'''Trans `P = P'''` have "P \<oplus> Q \<longmapsto>\<alpha> \<prec> P''" by(blast intro: Sum1)
    ultimately show ?thesis using P''Chain by(rule transitionI)
  next
    case False
    from PChain `P \<noteq> P'''` have "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P'''" by(rule sum1Chain)
    thus ?thesis using P'''Trans P''Chain by(rule transitionI)
  qed
qed

lemma Sum2:
  fixes Q  :: pi
  and   a  :: name
  and   x  :: name
  and   Q' :: pi
  and   P  :: pi
  and   \<alpha>  :: freeRes

  shows "Q \<Longrightarrow>a<\<nu>x> \<prec> Q' \<Longrightarrow> P \<oplus> Q \<Longrightarrow>a<\<nu>x> \<prec> Q'"
  and   "Q \<Longrightarrow>\<alpha> \<prec> Q' \<Longrightarrow> P \<oplus> Q \<Longrightarrow>\<alpha> \<prec> Q'"
proof -
  assume "Q \<Longrightarrow>a<\<nu>x> \<prec> Q'"
  then 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)
  show "P \<oplus> Q \<Longrightarrow>a<\<nu>x> \<prec> Q'"
  proof(cases "Q = Q'''")
    case True
    have "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P \<oplus> Q" by simp
    moreover from Q'''Trans `Q = Q'''` have "P \<oplus> Q \<longmapsto>a<\<nu>x> \<prec> Q''" by(blast intro: Sum2)
    ultimately show ?thesis using Q''Chain by(rule transitionI)
  next
    case False
    from QChain `Q \<noteq> Q'''` have "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> Q'''" by(rule sum2Chain)
    thus ?thesis using Q'''Trans Q''Chain by(rule transitionI)
  qed
next
  assume "Q \<Longrightarrow>\<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(force dest: transitionE)
  show "P \<oplus> Q \<Longrightarrow>\<alpha> \<prec> Q'"
  proof(cases "Q = Q'''")
    case True
    have "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P \<oplus> Q" by simp
    moreover from Q'''Trans `Q = Q'''` have "P \<oplus> Q \<longmapsto>\<alpha> \<prec> Q''" by(blast intro: Sum2)
    ultimately show ?thesis using Q''Chain by(rule transitionI)
  next
    case False
    from QChain `Q \<noteq> Q'''` have "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> Q'''" by(rule sum2Chain)
    thus ?thesis using Q'''Trans Q''Chain by(rule transitionI)
  qed
qed

lemma Par1B:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi
  and   Q  :: pi

  assumes PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  and     "x \<sharp> Q"

  shows "P \<parallel> Q \<Longrightarrow>a<\<nu>x> \<prec> (P' \<parallel> Q)"
proof -
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a<\<nu>x> \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)
  from PChain have "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P''' \<parallel> Q" by(rule Par1Chain)
  moreover from P'''Trans `x \<sharp> Q` have "P''' \<parallel> Q \<longmapsto>a<\<nu>x> \<prec> (P'' \<parallel> Q)" by(rule Early_Semantics.Par1B)
  moreover from P''Chain have "P'' \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q" by(rule Par1Chain)
  ultimately show "P \<parallel> Q \<Longrightarrow>a<\<nu>x> \<prec> (P' \<parallel> Q)" by(rule transitionI)
qed

lemma Par1F:
  fixes P  :: pi
  and   \<alpha>  :: freeRes
  and   P' :: pi
  and   Q  :: pi

  assumes PTrans: "P \<Longrightarrow>\<alpha> \<prec> P'"

  shows "P \<parallel> Q \<Longrightarrow>\<alpha> \<prec> (P' \<parallel> Q)"
proof -
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>\<alpha> \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)
  from PChain have "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P''' \<parallel> Q" by(rule Par1Chain)
  moreover from P'''Trans have "P''' \<parallel> Q \<longmapsto>\<alpha> \<prec> (P'' \<parallel> Q)" by(rule Early_Semantics.Par1F)
  moreover from P''Chain have "P'' \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q" by(rule Par1Chain)
  ultimately show ?thesis by(rule transitionI)
qed

lemma Par2B:
  fixes Q  :: pi
  and   a  :: name
  and   x  :: name
  and   Q' :: pi
  and   P  :: pi

  assumes QTrans: "Q \<Longrightarrow>a<\<nu>x> \<prec> Q'"
  and     "x \<sharp> P"

  shows "P \<parallel> Q \<Longrightarrow>a<\<nu>x> \<prec> (P \<parallel> Q')"
proof -
  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 have "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P \<parallel> Q'''" by(rule Par2Chain)
  moreover from Q'''Trans `x \<sharp> P` have "P \<parallel> Q''' \<longmapsto>a<\<nu>x> \<prec> (P \<parallel> Q'')" by(rule Early_Semantics.Par2B)
  moreover from Q''Chain have "P \<parallel> Q'' \<Longrightarrow>\<^sub>\<tau> P \<parallel> Q'" by(rule Par2Chain)
  ultimately show "P \<parallel> Q \<Longrightarrow>a<\<nu>x> \<prec> (P \<parallel> Q')" by(rule transitionI)
qed

lemma Par2F:
  fixes Q  :: pi
  and   \<alpha>  :: freeRes
  and   Q' :: pi
  and   P  :: pi

  assumes QTrans: "Q \<Longrightarrow>\<alpha> \<prec> Q'"

  shows "P \<parallel> Q \<Longrightarrow>\<alpha> \<prec> (P \<parallel> Q')"
proof -
  from QTrans 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 have "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P \<parallel> Q'''" by(rule Par2Chain)
  moreover from Q'''Trans have "P \<parallel> Q''' \<longmapsto>\<alpha> \<prec> (P \<parallel> Q'')" by(rule Early_Semantics.Par2F)
  moreover from Q''Chain have "P \<parallel> Q'' \<Longrightarrow>\<^sub>\<tau> P \<parallel> Q'" by(rule Par2Chain)
  ultimately show ?thesis by(rule transitionI)
qed

lemma Comm1:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi
  and   Q  :: pi
  and   Q' :: pi

  assumes PTrans: "P \<Longrightarrow>a<b> \<prec> P'"
  and     QTrans: "Q \<Longrightarrow>a[b] \<prec> Q'"

  shows "P \<parallel> Q \<Longrightarrow>\<tau> \<prec> P' \<parallel> Q'"
proof -
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a<b> \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)
  from QTrans obtain Q'' Q''' where QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q'''"
                                and Q'''Trans: "Q''' \<longmapsto>a[b] \<prec> Q''"
                                and Q''Chain: "Q'' \<Longrightarrow>\<^sub>\<tau> Q'"
    by(blast dest: transitionE)

  from PChain QChain have "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P''' \<parallel> Q'''" by(rule chainPar)
  moreover from P'''Trans Q'''Trans have "P''' \<parallel> Q''' \<longmapsto>\<tau> \<prec> P'' \<parallel> Q''"
    by(rule Early_Semantics.Comm1)
  moreover from P''Chain Q''Chain have "P'' \<parallel> Q'' \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q'" by(rule chainPar)
  ultimately show ?thesis by(rule transitionI)
qed

lemma Comm2:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi
  and   Q  :: pi
  and   Q' :: pi

  assumes PTrans: "P \<Longrightarrow>a[b] \<prec> P'"
  and     QTrans: "Q \<Longrightarrow>a<b> \<prec> Q'"

  shows "P \<parallel> Q \<Longrightarrow>\<tau> \<prec> P' \<parallel> Q'"
proof -
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a[b] \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)
  from QTrans obtain Q'' Q''' where QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q'''"
                                and Q'''Trans: "Q''' \<longmapsto>a<b> \<prec> Q''"
                                and Q''Chain: "Q'' \<Longrightarrow>\<^sub>\<tau> Q'"
    by(blast dest: transitionE)

  from PChain QChain have "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P''' \<parallel> Q'''" by(rule chainPar)
  moreover from P'''Trans Q'''Trans have "P''' \<parallel> Q''' \<longmapsto>\<tau> \<prec> P'' \<parallel> Q''"
    by(rule Early_Semantics.Comm2)
  moreover from P''Chain Q''Chain have "P'' \<parallel> Q'' \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q'" by(rule chainPar)
  ultimately show ?thesis by(rule transitionI)
qed

lemma Close1:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi
  and   Q  :: pi
  and   Q' :: pi

  assumes PTrans: "P \<Longrightarrow>a<x> \<prec> P'"
  and     QTrans: "Q \<Longrightarrow>a<\<nu>x> \<prec> Q'"
  and     "x \<sharp> P"

  shows "P \<parallel> Q \<Longrightarrow>\<tau> \<prec> <\<nu>x>(P' \<parallel> Q')"
proof -
  from PTrans obtain P''' P'' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a<x> \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)
  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 PChain QChain have "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P''' \<parallel> Q'''" by(rule chainPar)
  moreover from PChain `x \<sharp> P` have "x \<sharp> P'''" by(rule freshChain)
  with P'''Trans Q'''Trans have "P''' \<parallel> Q''' \<longmapsto>\<tau> \<prec> <\<nu>x>(P'' \<parallel> Q'')"
    by(rule Early_Semantics.Close1)
  moreover from P''Chain Q''Chain have "P'' \<parallel> Q'' \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q'" by(rule chainPar)
  hence "<\<nu>x>(P'' \<parallel> Q'') \<Longrightarrow>\<^sub>\<tau> <\<nu>x>(P' \<parallel> Q')" by(rule ResChain)
  ultimately show ?thesis by(rule transitionI)
qed

lemma Close2:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi
  and   Q  :: pi
  and   Q' :: pi

  assumes PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  and     QTrans: "Q \<Longrightarrow>a<x> \<prec> Q'"
  and     xFreshQ: "x \<sharp> Q"

  shows "P \<parallel> Q \<Longrightarrow>\<tau> \<prec> <\<nu>x>(P' \<parallel> Q')"
proof -
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a<\<nu>x> \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)
  from QTrans obtain Q'' Q''' where QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q'''"
                                and Q'''Trans: "Q''' \<longmapsto>a<x> \<prec> Q''"
                                and Q''Chain: "Q'' \<Longrightarrow>\<^sub>\<tau> Q'"
    by(blast dest: transitionE)

  from PChain QChain have "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P''' \<parallel> Q'''" by(rule chainPar)
  moreover from QChain `x \<sharp> Q` have "x \<sharp> Q'''" by(rule freshChain)

  with P'''Trans Q'''Trans have "P''' \<parallel> Q''' \<longmapsto>\<tau> \<prec> <\<nu>x>(P'' \<parallel> Q'')"
    by(rule Early_Semantics.Close2)
  moreover from P''Chain Q''Chain have "P'' \<parallel> Q'' \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q'" by(rule chainPar)
 hence "<\<nu>x>(P'' \<parallel> Q'') \<Longrightarrow>\<^sub>\<tau> <\<nu>x>(P' \<parallel> Q')" by(rule ResChain)
  ultimately show ?thesis by(rule transitionI)
qed

lemma ResF:
  fixes P  :: pi
  and   \<alpha>  :: freeRes
  and   P' :: pi
  and   x  :: name

  assumes PTrans: "P \<Longrightarrow>\<alpha> \<prec> P'"
  and     "x \<sharp> \<alpha>"

  shows "<\<nu>x>P \<Longrightarrow>\<alpha> \<prec> <\<nu>x>P'"
proof -
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>\<alpha> \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)

  from PChain have "<\<nu>x>P \<Longrightarrow>\<^sub>\<tau> <\<nu>x>P'''" by(rule ResChain)
  moreover from P'''Trans `x \<sharp> \<alpha>` have "<\<nu>x>P''' \<longmapsto>\<alpha> \<prec> <\<nu>x>P''"
    by(rule Early_Semantics.ResF)
  moreover from P''Chain have "<\<nu>x>P'' \<Longrightarrow>\<^sub>\<tau> <\<nu>x>P'" by(rule ResChain)
  ultimately show ?thesis by(rule transitionI)
qed

lemma ResB:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi
  and   y  :: name

  assumes PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  and     "y \<noteq> a"
  and     "y \<noteq> x"

  shows "<\<nu>y>P \<Longrightarrow>a<\<nu>x> \<prec> (<\<nu>y>P')"
proof -
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a<\<nu>x> \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)

  from PChain have "<\<nu>y>P \<Longrightarrow>\<^sub>\<tau> <\<nu>y>P'''" by(rule ResChain)
  moreover from P'''Trans  `y \<noteq> a` `y \<noteq> x` have "<\<nu>y>P''' \<longmapsto>a<\<nu>x> \<prec> (<\<nu>y>P'')"
    by(rule Early_Semantics.ResB)
  moreover from P''Chain have "<\<nu>y>P'' \<Longrightarrow>\<^sub>\<tau> <\<nu>y>P'" by(rule ResChain)
  ultimately show ?thesis by(rule transitionI)
qed

lemma Bang:
  fixes P  :: pi
  and   Rs :: residual

  shows "P \<parallel> !P \<Longrightarrow>a<\<nu>x> \<prec> P' \<Longrightarrow> !P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  and   "P \<parallel> !P \<Longrightarrow>\<alpha> \<prec> P' \<Longrightarrow> !P \<Longrightarrow>\<alpha> \<prec> P'"
proof -
  assume PTrans: "P \<parallel> !P \<Longrightarrow> a<\<nu>x> \<prec> P'"

  from PTrans obtain P'' P''' where PChain: "P \<parallel> !P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a<\<nu>x> \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: transitionE)

  show "!P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  proof(cases "P''' = P \<parallel> !P")
    case True
    have "!P \<Longrightarrow>\<^sub>\<tau> !P" by simp
    moreover from P'''Trans `P''' = P \<parallel> !P` have "!P \<longmapsto>a<\<nu>x> \<prec> P''" by(blast intro: Early_Semantics.Bang)
    ultimately show ?thesis using P''Chain by(rule transitionI)
  next
    case False
    from PChain `P''' \<noteq> P \<parallel> !P` have "!P \<Longrightarrow>\<^sub>\<tau> P'''" by(rule bangChain)
    with P'''Trans P''Chain show ?thesis by(blast intro: transitionI)
  qed
next
  fix \<alpha> P' P
  assume "P \<parallel> !P \<Longrightarrow>\<alpha> \<prec> P'"

  then obtain P'' P''' where PChain: "P \<parallel> !P \<Longrightarrow>\<^sub>\<tau> P''"
                         and P''Trans: "P'' \<longmapsto>\<alpha> \<prec> P'''"
                         and P'''Chain: "P''' \<Longrightarrow>\<^sub>\<tau> P'"
    by(force dest: transitionE)

  show "!P \<Longrightarrow>\<alpha> \<prec> P'"
  proof(cases "P'' = P \<parallel> !P")
    assume "P'' = P \<parallel> !P"
    moreover with P''Trans have "!P \<longmapsto>\<alpha> \<prec> P'''" by(blast intro: Bang)
    ultimately show ?thesis using PChain P'''Chain by(rule_tac transitionI, auto)
  next
    assume "P'' \<noteq> P \<parallel> !P"
    with PChain have "!P \<Longrightarrow>\<^sub>\<tau> P''" by(rule bangChain)
    with P''Trans P'''Chain show ?thesis by(blast intro: transitionI)
  qed
qed

lemma tauTransitionChain:
  fixes P  :: pi
  and   P' :: pi

  assumes "P \<Longrightarrow>\<tau> \<prec> P'"

  shows "P \<Longrightarrow>\<^sub>\<tau> P'"
using assms
by(force dest: transitionE tauActTauChain)

lemma chainTransitionAppend:
  fixes P   :: pi
  and   P'  :: pi
  and   Rs  :: residual
  and   a   :: name
  and   x   :: name
  and   P'' :: pi
  and   \<alpha>   :: freeRes

  shows "P \<Longrightarrow>a<\<nu>x> \<prec> P'' \<Longrightarrow> P'' \<Longrightarrow>\<^sub>\<tau> P' \<Longrightarrow> P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  and   "P \<Longrightarrow>\<alpha> \<prec> P'' \<Longrightarrow> P'' \<Longrightarrow>\<^sub>\<tau> P' \<Longrightarrow> P \<Longrightarrow>\<alpha> \<prec> P'"
  and   "P \<Longrightarrow>\<^sub>\<tau> P'' \<Longrightarrow> P'' \<Longrightarrow>a<\<nu>x> \<prec> P' \<Longrightarrow> P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  and   "P \<Longrightarrow>\<^sub>\<tau> P'' \<Longrightarrow> P'' \<Longrightarrow>\<alpha> \<prec> P' \<Longrightarrow> P \<Longrightarrow>\<alpha> \<prec> P'"
proof -
  assume PTrans: "P \<Longrightarrow> a<\<nu>x> \<prec> P''"
  assume P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"

  from PTrans obtain P''' P'''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P''''"
                                  and P''''Trans: "P'''' \<longmapsto>a<\<nu>x> \<prec> P'''"
                                  and P'''Chain: "P''' \<Longrightarrow>\<^sub>\<tau> P''"
    by(blast dest: transitionE)

  from P'''Chain P''Chain have "P''' \<Longrightarrow>\<^sub>\<tau> P'" by auto
  with PChain P''''Trans show "P \<Longrightarrow>a<\<nu>x> \<prec> P'" by(rule transitionI)
next
  assume PTrans: "P \<Longrightarrow>\<alpha> \<prec> P''"
  assume P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"

  from PTrans obtain P''' P'''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P''''"
                                  and P''''Trans: "P'''' \<longmapsto>\<alpha> \<prec> P'''"
                                  and P'''Chain: "P''' \<Longrightarrow>\<^sub>\<tau> P''"
    by(blast dest: transitionE)

  from P'''Chain P''Chain have "P''' \<Longrightarrow>\<^sub>\<tau> P'" by auto
  with PChain P''''Trans show "P \<Longrightarrow>\<alpha> \<prec> P'" by(rule transitionI)
next
  assume PChain: "P \<Longrightarrow>\<^sub>\<tau> P''"
  assume P''Trans: "P'' \<Longrightarrow> a<\<nu>x> \<prec> P'"

  from P''Trans obtain P''' P'''' where P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P''''"
                                    and P''''Trans: "P'''' \<longmapsto>a<\<nu>x> \<prec> P'''"
                                    and P'''Chain: "P''' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)

  from PChain P''Chain have "P \<Longrightarrow>\<^sub>\<tau> P''''" by auto
  thus "P \<Longrightarrow>a<\<nu>x> \<prec> P'" using P''''Trans P'''Chain by(rule transitionI)
next
  assume PChain: "P \<Longrightarrow>\<^sub>\<tau> P''"
  assume P''Trans: "P'' \<Longrightarrow>\<alpha> \<prec> P'"

  from P''Trans obtain P''' P'''' where P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P''''"
                                    and P''''Trans: "P'''' \<longmapsto>\<alpha> \<prec> P'''"
                                    and P'''Chain: "P''' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)

  from PChain P''Chain have "P \<Longrightarrow>\<^sub>\<tau> P''''" by auto
  thus "P \<Longrightarrow>\<alpha> \<prec> P'" using P''''Trans P'''Chain by(rule transitionI)
qed

lemma freshBoundOutputTransition:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi
  and   c  :: name

  assumes PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  and     "c \<sharp> P"
  and     "c \<noteq> x"

  shows "c \<sharp> P'"
proof -
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a<\<nu>x> \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)

  from PChain `c \<sharp> P` have "c \<sharp> P'''" by(rule freshChain)
  with P'''Trans have "c \<sharp> P''" using `c \<noteq> x` by(rule Early_Semantics.freshTransition)
  with P''Chain show "c \<sharp> P'" by(rule freshChain)
qed

lemma freshTauTransition:
  fixes P :: pi
  and   c :: name

  assumes PTrans: "P \<Longrightarrow>\<tau> \<prec> P'"
  and     "c \<sharp> P"

  shows "c \<sharp> P'"
proof -
  from PTrans have "P \<Longrightarrow>\<^sub>\<tau> P'" by(rule tauTransitionChain)
  thus ?thesis using `c \<sharp> P` by(rule freshChain)
qed

lemma freshOutputTransition:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi
  and   c  :: name

  assumes PTrans: "P \<Longrightarrow>a[b] \<prec> P'"
  and     "c \<sharp> P"

  shows "c \<sharp> P'"
proof -
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a[b] \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
      by(blast dest: transitionE)

    from PChain `c \<sharp> P` have "c \<sharp> P'''" by(rule freshChain)
    with P'''Trans have "c \<sharp> P''" by(rule Early_Semantics.freshTransition)
    with P''Chain show ?thesis by(rule freshChain)
qed

lemma eqvtI[eqvt]:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi
  and   p :: "name prm"
  and   \<alpha> :: freeRes

  shows "P \<Longrightarrow>a<\<nu>x> \<prec> P' \<Longrightarrow> (p \<bullet> P) \<Longrightarrow>(p \<bullet> a)<\<nu>(p \<bullet> x)> \<prec> (p \<bullet> P')"
  and   "P \<Longrightarrow>\<alpha> \<prec> P' \<Longrightarrow> (p \<bullet> P) \<Longrightarrow>(p \<bullet> \<alpha>) \<prec> (p \<bullet> P')"
proof -
  assume "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
  then obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                         and P'''Trans: "P''' \<longmapsto>a<\<nu>x> \<prec> P''"
                         and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)

  from PChain have "(p \<bullet> P) \<Longrightarrow>\<^sub>\<tau> (p \<bullet> P''')" by(rule eqvtChainI)
  moreover from P'''Trans have "(p \<bullet> P''') \<longmapsto> (p \<bullet> (a<\<nu>x> \<prec> P''))"
    by(rule TransitionsEarly.eqvt)
  hence "(p \<bullet> P''') \<longmapsto> (p \<bullet> a)<\<nu>(p \<bullet> x)> \<prec> (p \<bullet> P'')"
    by(simp add: eqvts)
  moreover from P''Chain have "(p \<bullet> P'') \<Longrightarrow>\<^sub>\<tau> (p \<bullet> P')" by(rule eqvtChainI)
  ultimately show "(p \<bullet> P) \<Longrightarrow>(p \<bullet> a)<\<nu>(p \<bullet> x)> \<prec> (p \<bullet> P')"
    by(rule transitionI)
next
  assume "P \<Longrightarrow>\<alpha> \<prec> P'"
  then obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                         and P'''Trans: "P''' \<longmapsto>\<alpha> \<prec> P''"
                         and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)

  from PChain have "(p \<bullet> P) \<Longrightarrow>\<^sub>\<tau> (p \<bullet> P''')" by(rule eqvtChainI)
  moreover from P'''Trans have "(p \<bullet> P''') \<longmapsto> (p \<bullet> (\<alpha> \<prec> P''))"
    by(rule TransitionsEarly.eqvt)
  hence "(p \<bullet> P''') \<longmapsto> (p \<bullet> \<alpha>) \<prec> (p \<bullet> P'')"
    by(simp add: eqvts)
  moreover from P''Chain have "(p \<bullet> P'') \<Longrightarrow>\<^sub>\<tau> (p \<bullet> P')" by(rule eqvtChainI)
  ultimately show "(p \<bullet> P) \<Longrightarrow>(p \<bullet> \<alpha>) \<prec> (p \<bullet> P')"
    by(rule transitionI)
qed

lemma freshInputTransition:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi
  and   c  :: name

  assumes PTrans: "P \<Longrightarrow>a<b> \<prec> P'"
  and     "c \<sharp> P"
  and     "c \<noteq> b"

  shows "c \<sharp> P'"
proof -
  from PTrans obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''"
                                and P'''Trans: "P''' \<longmapsto>a<b> \<prec> P''"
                                and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'"
    by(blast dest: transitionE)

  from PChain `c \<sharp> P` have "c \<sharp> P'''" by(rule freshChain)
  with P'''Trans have "c \<sharp> P''" using `c \<noteq> b` by(rule Early_Semantics.freshInputTransition)
  with P''Chain show ?thesis by(rule freshChain)
qed

lemmas freshTransition = freshBoundOutputTransition freshOutputTransition
                         freshInputTransition freshTauTransition

end


theory Anti_Plurality_Rule
imports Scoring_Rules
        "Compositional_Structures/Basic_Modules/Anti_Plurality_Module"
        "Compositional_Structures/Elect_Composition"

begin

lemma anti_plurality_elect:
  shows "electoral_module (elector anti_plurality)"
proof(unfold anti_plurality.simps)
  show "electoral_module (elector (max_eliminator (scoring vector_anti_plurality)))"
     using scoring_mod_A by blast
qed

lemma anti_plurality_hom:
  shows "homogeneity (elector anti_plurality)" unfolding anti_plurality.simps
  using scoring_rules_homogeneity
  by blast

lemma anti_plurality_reinforcement:
  shows "reinforcement (elector anti_plurality)" unfolding anti_plurality.simps
  using scoring_module_rein
  by blast

end


(*  Title:      ZF/Resid/Redex.thy
    Author:     Ole Rasmussen, University of Cambridge
*)

theory Redex imports ZF begin
consts
  redexes     :: i

datatype
  "redexes" = Var ("n \<in> nat")
            | Fun ("t \<in> redexes")
            | App ("b \<in> bool","f \<in> redexes", "a \<in> redexes")

consts
  Ssub  :: "i"
  Scomp :: "i"
  Sreg  :: "i"

abbreviation
  Ssub_rel  (infixl \<open>\<Longleftarrow>\<close> 70) where
  "a \<Longleftarrow> b \<equiv> \<langle>a,b\<rangle> \<in> Ssub"

abbreviation
  Scomp_rel  (infixl \<open>\<sim>\<close> 70) where
  "a \<sim> b \<equiv> \<langle>a,b\<rangle> \<in> Scomp"

abbreviation
  "regular(a) \<equiv> a \<in> Sreg"

consts union_aux        :: "i\<Rightarrow>i"
primrec (*explicit lambda is required because both arguments of "\<squnion>" vary*)
  "union_aux(Var(n)) =
     (\<lambda>t \<in> redexes. redexes_case(\<lambda>j. Var(n), \<lambda>x. 0, \<lambda>b x y.0, t))"

  "union_aux(Fun(u)) =
     (\<lambda>t \<in> redexes. redexes_case(\<lambda>j. 0, \<lambda>y. Fun(union_aux(u)`y),
                                  \<lambda>b y z. 0, t))"

  "union_aux(App(b,f,a)) =
     (\<lambda>t \<in> redexes.
        redexes_case(\<lambda>j. 0, \<lambda>y. 0,
                     \<lambda>c z u. App(b or c, union_aux(f)`z, union_aux(a)`u), t))"

definition
  union  (infixl \<open>\<squnion>\<close> 70) where
  "u \<squnion> v \<equiv> union_aux(u)`v"

inductive
  domains       "Ssub" \<subseteq> "redexes*redexes"
  intros
    Sub_Var:     "n \<in> nat \<Longrightarrow> Var(n) \<Longleftarrow> Var(n)"
    Sub_Fun:     "\<lbrakk>u \<Longleftarrow> v\<rbrakk>\<Longrightarrow> Fun(u) \<Longleftarrow> Fun(v)"
    Sub_App1:    "\<lbrakk>u1 \<Longleftarrow> v1; u2 \<Longleftarrow> v2; b \<in> bool\<rbrakk>\<Longrightarrow>
                     App(0,u1,u2) \<Longleftarrow> App(b,v1,v2)"
    Sub_App2:    "\<lbrakk>u1 \<Longleftarrow> v1; u2 \<Longleftarrow> v2\<rbrakk>\<Longrightarrow> App(1,u1,u2) \<Longleftarrow> App(1,v1,v2)"
  type_intros    redexes.intros bool_typechecks

inductive
  domains       "Scomp" \<subseteq> "redexes*redexes"
  intros
    Comp_Var:    "n \<in> nat \<Longrightarrow> Var(n) \<sim> Var(n)"
    Comp_Fun:    "\<lbrakk>u \<sim> v\<rbrakk>\<Longrightarrow> Fun(u) \<sim> Fun(v)"
    Comp_App:    "\<lbrakk>u1 \<sim> v1; u2 \<sim> v2; b1 \<in> bool; b2 \<in> bool\<rbrakk>
                  \<Longrightarrow> App(b1,u1,u2) \<sim> App(b2,v1,v2)"
  type_intros    redexes.intros bool_typechecks

inductive
  domains       "Sreg" \<subseteq> redexes
  intros
    Reg_Var:     "n \<in> nat \<Longrightarrow> regular(Var(n))"
    Reg_Fun:     "\<lbrakk>regular(u)\<rbrakk>\<Longrightarrow> regular(Fun(u))"
    Reg_App1:    "\<lbrakk>regular(Fun(u)); regular(v)\<rbrakk>\<Longrightarrow>regular(App(1,Fun(u),v))"
    Reg_App2:    "\<lbrakk>regular(u); regular(v)\<rbrakk>\<Longrightarrow>regular(App(0,u,v))"
  type_intros    redexes.intros bool_typechecks

declare redexes.intros [simp]

(* ------------------------------------------------------------------------- *)
(*    Specialisation of comp-rules                                           *)
(* ------------------------------------------------------------------------- *)

lemmas compD1 [simp] = Scomp.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas compD2 [simp] = Scomp.dom_subset [THEN subsetD, THEN SigmaD2]
lemmas regD [simp] = Sreg.dom_subset [THEN subsetD]

(* ------------------------------------------------------------------------- *)
(*    Equality rules for union                                               *)
(* ------------------------------------------------------------------------- *)

lemma union_Var [simp]: "n \<in> nat \<Longrightarrow> Var(n) \<squnion> Var(n)=Var(n)"
by (simp add: union_def)

lemma union_Fun [simp]: "v \<in> redexes \<Longrightarrow> Fun(u) \<squnion> Fun(v) = Fun(u \<squnion> v)"
by (simp add: union_def)

lemma union_App [simp]:
     "\<lbrakk>b2 \<in> bool; u2 \<in> redexes; v2 \<in> redexes\<rbrakk>
      \<Longrightarrow> App(b1,u1,v1) \<squnion> App(b2,u2,v2)=App(b1 or b2,u1 \<squnion> u2,v1 \<squnion> v2)"
by (simp add: union_def)

lemma or_1_right [simp]: "a or 1 = 1"
by (simp add: or_def cond_def)

lemma or_0_right [simp]: "a \<in> bool \<Longrightarrow> a or 0 = a"
by (simp add: or_def cond_def bool_def, auto)

declare Ssub.intros [simp]
declare bool_typechecks [simp]
declare Sreg.intros [simp]
declare Scomp.intros [simp]

declare Scomp.intros [intro]

inductive_cases [elim!]:
  "regular(App(b,f,a))"
  "regular(Fun(b))"
  "regular(Var(b))"
  "Fun(u) \<sim> Fun(t)"
  "u \<sim> Fun(t)"
  "u \<sim> Var(n)"
  "u \<sim> App(b,t,a)"
  "Fun(t) \<sim> v"
  "App(b,f,a) \<sim> v"
  "Var(n) \<sim> u"

(* ------------------------------------------------------------------------- *)
(*    comp proofs                                                            *)
(* ------------------------------------------------------------------------- *)

lemma comp_refl [simp]: "u \<in> redexes \<Longrightarrow> u \<sim> u"
by (erule redexes.induct, blast+)

lemma comp_sym: "u \<sim> v \<Longrightarrow> v \<sim> u"
by (erule Scomp.induct, blast+)

lemma comp_sym_iff: "u \<sim> v \<longleftrightarrow> v \<sim> u"
by (blast intro: comp_sym)

lemma comp_trans [rule_format]: "u \<sim> v \<Longrightarrow> \<forall>w. v \<sim> w\<longrightarrow>u \<sim> w"
by (erule Scomp.induct, blast+)

(* ------------------------------------------------------------------------- *)
(*   union proofs                                                            *)
(* ------------------------------------------------------------------------- *)

lemma union_l: "u \<sim> v \<Longrightarrow> u \<Longleftarrow> (u \<squnion> v)"
apply (erule Scomp.induct)
apply (erule_tac [3] boolE, simp_all)
done

lemma union_r: "u \<sim> v \<Longrightarrow> v \<Longleftarrow> (u \<squnion> v)"
apply (erule Scomp.induct)
apply (erule_tac [3] c = b2 in boolE, simp_all)
done

lemma union_sym: "u \<sim> v \<Longrightarrow> u \<squnion> v = v \<squnion> u"
by (erule Scomp.induct, simp_all add: or_commute)

(* ------------------------------------------------------------------------- *)
(*      regular proofs                                                       *)
(* ------------------------------------------------------------------------- *)

lemma union_preserve_regular [rule_format]:
     "u \<sim> v \<Longrightarrow> regular(u) \<longrightarrow> regular(v) \<longrightarrow> regular(u \<squnion> v)"
  by (erule Scomp.induct, auto)

end


theory weird_nat_mul3_same
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
"mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S (Z)) (S (Z)) (S (Z)) = S Z"
| "mul3acc (S (Z)) (S (Z)) (S (S x5)) =
     S (add3acc
          (mul3acc Z Z (S x5))
          (add3acc
             (mul3acc (S Z) Z (S x5)) (mul3acc Z (S Z) (S x5))
             (mul3acc Z Z (S Z)))
          (add3acc Z Z (S x5)))"
| "mul3acc (S (Z)) (S (S x6)) (S x4) =
     S (add3acc
          (mul3acc Z (S x6) x4)
          (add3acc
             (mul3acc (S Z) (S x6) x4) (mul3acc Z (S Z) x4)
             (mul3acc Z (S x6) (S Z)))
          (add3acc Z (S x6) x4))"
| "mul3acc (S (S x7)) (S x3) (S x4) =
     S (add3acc
          (mul3acc (S x7) x3 x4)
          (add3acc
             (mul3acc (S Z) x3 x4) (mul3acc (S x7) (S Z) x4)
             (mul3acc (S x7) x3 (S Z)))
          (add3acc (S x7) x3 x4))"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S y2) z = S (add3 Z y2 z)"
| "add3 (S x2) y z = S (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
"mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S (Z)) (S (Z)) (S (Z)) = S Z"
| "mul3 (S (Z)) (S (Z)) (S (S x5)) =
     S (add3
          (mul3 Z Z (S x5))
          (add3 (mul3 (S Z) Z (S x5)) (mul3 Z (S Z) (S x5)) (mul3 Z Z (S Z)))
          (add3 Z Z (S x5)))"
| "mul3 (S (Z)) (S (S x6)) (S x4) =
     S (add3
          (mul3 Z (S x6) x4)
          (add3
             (mul3 (S Z) (S x6) x4) (mul3 Z (S Z) x4) (mul3 Z (S x6) (S Z)))
          (add3 Z (S x6) x4))"
| "mul3 (S (S x7)) (S x3) (S x4) =
     S (add3
          (mul3 (S x7) x3 x4)
          (add3
             (mul3 (S Z) x3 x4) (mul3 (S x7) (S Z) x4) (mul3 (S x7) x3 (S Z)))
          (add3 (S x7) x3 x4))"

(*hipster add3acc mul3acc add3 mul3 *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (mul3 x y z) = (mul3acc x y z)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory weird_nat_mul2_comm
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul2 :: "Nat => Nat => Nat" where
"mul2 (Z) y = Z"
| "mul2 (S z) (Z) = Z"
| "mul2 (S z) (S x2) = S (add3acc z x2 (mul2 z x2))"

(*hipster add3acc mul2 *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) . (mul2 x y) = (mul2 y x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*
    Author:   Benedikt Seidl
    License:  BSD
*)

section \<open>Implementation of the DRA Construction\<close>

theory DRA_Implementation
imports
  DRA_Construction
  LTL.Rewriting
  Transition_Systems_and_Automata.DRA_Translate
begin

subsection \<open>Generating the Explicit Automaton\<close>

text \<open>
  We convert the implicit automaton to its explicit representation
  and afterwards proof the final correctness theorem and the overall
  size bound.
\<close>

definition dra_to_drai :: "('a, 'b) dra \<Rightarrow> 'a list \<Rightarrow> ('a, 'b) drai"
where
  "dra_to_drai \<AA> \<Sigma> = drai \<Sigma> (initial \<AA>) (transition \<AA>) (condition \<AA>)"

lemma dra_to_drai_language:
  "set \<Sigma> = alphabet \<AA> \<Longrightarrow> language (drai_dra (dra_to_drai \<AA> \<Sigma>)) = language \<AA>"
  by (simp add: dra_to_drai_def drai_dra_def)

definition drai_to_draei :: "nat \<Rightarrow> ('a, 'b :: hashable) drai \<Rightarrow> ('a, nat) draei"
where
  "drai_to_draei hms = to_draei_impl (=) bounded_hashcode_nat hms"

lemma dra_to_drai_rel:
  assumes
    "(\<Sigma>, alphabet A) \<in> \<langle>Id\<rangle> list_set_rel"
  shows
    "(dra_to_drai A \<Sigma>, A) \<in> \<langle>Id, Id\<rangle>drai_dra_rel"
proof -
  have "(A, A) \<in> \<langle>Id, Id\<rangle>dra_rel"
    by simp

  then have "(dra_to_drai A \<Sigma>, dra (alphabet A) (initial A) (transition A) (condition A)) \<in> \<langle>Id, Id\<rangle>drai_dra_rel"
    unfolding dra_to_drai_def using assms by parametricity

  then show ?thesis
    by simp
qed

lemma draei_language_rel:
  fixes
    A :: "('label, 'state :: hashable) dra"
  assumes
    "(\<Sigma>, alphabet A) \<in> \<langle>Id\<rangle> list_set_rel"
  and
    "finite (DRA.nodes A)"
  and
    "is_valid_def_hm_size TYPE('state) hms"
  shows
    "DRA.language (drae_dra (draei_drae (drai_to_draei hms (dra_to_drai A \<Sigma>)))) = DRA.language A"
proof -
  have "(dra_to_drai A \<Sigma>, A) \<in> \<langle>Id, Id\<rangle>drai_dra_rel"
    using dra_to_drai_rel assms by fast

  then have "(drai_to_draei hms (dra_to_drai A \<Sigma>), to_draei A) \<in> \<langle>Id_on (dra.alphabet A), rel (dra_to_drai A \<Sigma>) A (=) bounded_hashcode_nat hms\<rangle> draei_dra_rel"
    unfolding drai_to_draei_def
    using to_draei_impl_refine[unfolded autoref_tag_defs]
    by parametricity (simp_all add: assms is_bounded_hashcode_def bounded_hashcode_nat_bounds)

  then have "(DRA.language ((drae_dra \<circ> draei_drae) (drai_to_draei hms (dra_to_drai A \<Sigma>))), DRA.language (id (to_draei A))) \<in> \<langle>\<langle>Id_on (dra.alphabet A)\<rangle> stream_rel\<rangle> set_rel"
    by parametricity

  then show ?thesis
    by (simp add: to_draei_def)
qed

subsection \<open>Defining the Alphabet\<close>

fun atoms_ltlc_list :: "'a ltlc \<Rightarrow> 'a list"
where
  "atoms_ltlc_list true\<^sub>c = []"
| "atoms_ltlc_list false\<^sub>c = []"
| "atoms_ltlc_list prop\<^sub>c(q) = [q]"
| "atoms_ltlc_list (not\<^sub>c \<phi>) = atoms_ltlc_list \<phi>"
| "atoms_ltlc_list (\<phi> and\<^sub>c \<psi>) = List.union (atoms_ltlc_list \<phi>) (atoms_ltlc_list \<psi>)"
| "atoms_ltlc_list (\<phi> or\<^sub>c \<psi>) = List.union (atoms_ltlc_list \<phi>) (atoms_ltlc_list \<psi>)"
| "atoms_ltlc_list (\<phi> implies\<^sub>c \<psi>) = List.union (atoms_ltlc_list \<phi>) (atoms_ltlc_list \<psi>)"
| "atoms_ltlc_list (X\<^sub>c \<phi>) = atoms_ltlc_list \<phi>"
| "atoms_ltlc_list (F\<^sub>c \<phi>) = atoms_ltlc_list \<phi>"
| "atoms_ltlc_list (G\<^sub>c \<phi>) = atoms_ltlc_list \<phi>"
| "atoms_ltlc_list (\<phi> U\<^sub>c \<psi>) = List.union (atoms_ltlc_list \<phi>) (atoms_ltlc_list \<psi>)"
| "atoms_ltlc_list (\<phi> R\<^sub>c \<psi>) = List.union (atoms_ltlc_list \<phi>) (atoms_ltlc_list \<psi>)"
| "atoms_ltlc_list (\<phi> W\<^sub>c \<psi>) = List.union (atoms_ltlc_list \<phi>) (atoms_ltlc_list \<psi>)"
| "atoms_ltlc_list (\<phi> M\<^sub>c \<psi>) = List.union (atoms_ltlc_list \<phi>) (atoms_ltlc_list \<psi>)"

lemma atoms_ltlc_list_set:
  "set (atoms_ltlc_list \<phi>) = atoms_ltlc \<phi>"
  by (induction \<phi>) simp_all

lemma atoms_ltlc_list_distinct:
  "distinct (atoms_ltlc_list \<phi>)"
  by (induction \<phi>) simp_all

definition ltl_alphabet :: "'a list \<Rightarrow> 'a set list"
where
  "ltl_alphabet AP = map set (subseqs AP)"

subsection \<open>The Final Constant\<close>

text \<open>
  We require the quotient type to be hashable in order to efficiently explore the automaton.
\<close>

locale dra_implementation = dra_construction_size _ _ _ Abs
  for
    Abs :: "'a ltln \<Rightarrow> 'ltlq :: hashable"
begin

definition ltln_to_draei :: "'a list \<Rightarrow> 'a ltln \<Rightarrow> ('a set, nat) draei"
where
  "ltln_to_draei AP \<phi> = drai_to_draei (Suc (size \<phi>)) (dra_to_drai (ltl_to_dra_alphabet \<phi> (set AP)) (ltl_alphabet AP))"

definition ltlc_to_draei :: "'a ltlc \<Rightarrow> ('a set, nat) draei"
where
  "ltlc_to_draei \<phi> = ltln_to_draei (atoms_ltlc_list \<phi>) (simplify Slow (ltlc_to_ltln \<phi>))"

lemma ltl_to_dra_alphabet_rel:
  "distinct AP \<Longrightarrow> (ltl_alphabet AP, alphabet (ltl_to_dra_alphabet \<psi> (set AP))) \<in> \<langle>Id\<rangle> list_set_rel"
  unfolding ltl_to_dra_alphabet_alphabet ltl_alphabet_def
  by (simp add: list_set_rel_def in_br_conv subseqs_powset distinct_set_subseqs)

lemma ltlc_to_ltln_simplify_atoms:
  "atoms_ltln (simplify Slow (ltlc_to_ltln \<phi>)) \<subseteq> atoms_ltlc \<phi>"
  using ltlc_to_ltln_atoms simplify_atoms by fast

lemma valid_def_hm_size:
  "is_valid_def_hm_size TYPE('state) (Suc (size \<phi>))" for \<phi> :: "'a ltln"
  unfolding is_valid_def_hm_size_def
  using ltln.size_neq by auto

theorem final_correctness:
  "to_omega ` language (drae_dra (draei_drae (ltlc_to_draei \<phi>)))
    = language_ltlc \<phi> \<inter> {w. range w \<subseteq> Pow (atoms_ltlc \<phi>)}"
  unfolding ltlc_to_draei_def ltln_to_draei_def
  unfolding draei_language_rel[OF ltl_to_dra_alphabet_rel[OF atoms_ltlc_list_distinct] ltl_to_dra_alphabet_nodes_finite valid_def_hm_size]
  unfolding atoms_ltlc_list_set
  unfolding ltl_to_dra_alphabet_language[OF ltlc_to_ltln_simplify_atoms]
  unfolding ltlc_to_ltln_atoms language_ltln_def language_ltlc_def ltlc_to_ltln_semantics simplify_correct ..

end

end


theory Lappend_literates
  imports Main "$HIPSTER_HOME/IsaHipster"
    Lappend
    Literate
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy

cohipster literate lappend
lemma lemma_af [thy_expl]: "lappend (literate z x2) y = literate z x2"
  by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    auto
(* Discovered and proved in ca. 20 seconds,
   lemmas about lappend are also discovered but discarded before proving
   since they are already imported from Lappend.thy *)

end