section \<open>Attractor Strategies\<close>

theory AttractorStrategy
imports
  Main
  Attractor UniformStrategy
begin

text \<open>This section proves that every attractor set has an attractor strategy.\<close>

context ParityGame begin

lemma strategy_attracts_extends_VVp:
  assumes \<sigma>: "strategy p \<sigma>" "strategy_attracts p \<sigma> S W"
    and v0: "v0 \<in> VV p" "v0 \<in> directly_attracted p S" "v0 \<notin> S"
  shows "\<exists>\<sigma>. strategy p \<sigma> \<and> strategy_attracts_via p \<sigma> v0 (insert v0 S) W"
proof-
  from v0(1,2) obtain w where "v0\<rightarrow>w" "w \<in> S" using directly_attracted_def by blast
  from \<open>w \<in> S\<close> \<sigma>(2) have "strategy_attracts_via p \<sigma> w S W" unfolding strategy_attracts_def by blast
  let ?\<sigma> = "\<sigma>(v0 := w)" \<comment> \<open>Extend @{term \<sigma>} to the new node.\<close>
  have "strategy p ?\<sigma>" using \<sigma>(1) \<open>v0\<rightarrow>w\<close> valid_strategy_updates by blast
  moreover have "strategy_attracts_via p ?\<sigma> v0 (insert v0 S) W" proof
    fix P
    assume "vmc_path G P v0 p ?\<sigma>"
    then interpret vmc_path G P v0 p ?\<sigma> .
    have "\<not>deadend v0" using \<open>v0\<rightarrow>w\<close> by blast
    then interpret vmc_path_no_deadend G P v0 p ?\<sigma> by unfold_locales

    define P'' where [simp]: "P'' = ltl P"
    have "lhd P'' = w" using v0(1) v0_conforms w0_def by auto
    hence "vmc_path G P'' w p ?\<sigma>" using vmc_path_ltl by (simp add: w0_def)

    have *: "v0 \<notin> S - W" using \<open>v0 \<notin> S\<close> by blast
    have "override_on (\<sigma>(v0 := w)) \<sigma> (S - W) = ?\<sigma>"
      by (rule ext) (metis * fun_upd_def override_on_def)
    hence "strategy_attracts p ?\<sigma> S W"
      using strategy_attracts_irrelevant_override[OF \<sigma>(2,1) \<open>strategy p ?\<sigma>\<close>] by simp
    hence "strategy_attracts_via p ?\<sigma> w S W" unfolding strategy_attracts_def
      using \<open>w \<in> S\<close> by blast
    hence "visits_via P'' S W" unfolding strategy_attracts_via_def
      using \<open>vmc_path G P'' w p ?\<sigma>\<close> by blast
    thus "visits_via P (insert v0 S) W"
      using visits_via_LCons[of "ltl P" S W v0] P_LCons by simp
  qed
  ultimately show ?thesis by blast
qed

lemma strategy_attracts_extends_VVpstar:
  assumes \<sigma>: "strategy_attracts p \<sigma> S W"
    and v0: "v0 \<notin> VV p" "v0 \<in> directly_attracted p S"
  shows "strategy_attracts_via p \<sigma> v0 (insert v0 S) W"
proof
  fix P
  assume "vmc_path G P v0 p \<sigma>"
  then interpret vmc_path G P v0 p \<sigma> .
  have "\<not>deadend v0" using v0(2) directly_attracted_contains_no_deadends by blast
  then interpret vmc_path_no_deadend G P v0 p \<sigma> by unfold_locales
  have "visits_via (ltl P) S W"
    using vmc_path.strategy_attractsE[OF vmc_path_ltl \<sigma>] v0 directly_attracted_def by simp
  thus "visits_via P (insert v0 S) W" using visits_via_LCons[of "ltl P" S W v0] P_LCons by simp
qed

lemma attractor_has_strategy_single:
  assumes "W \<subseteq> V"
    and v0_def: "v0 \<in> attractor p W" (is "_ \<in> ?A")
  shows "\<exists>\<sigma>. strategy p \<sigma> \<and> strategy_attracts_via p \<sigma> v0 ?A W"
using assms proof (induct arbitrary: v0 rule: attractor_set_induction)
  case (step S)
  have "v0 \<in> W \<Longrightarrow> \<exists>\<sigma>. strategy p \<sigma> \<and> strategy_attracts_via p \<sigma> v0 {} W"
    using strategy_attracts_via_trivial valid_arbitrary_strategy by blast
  moreover {
    assume *: "v0 \<in> directly_attracted p S" "v0 \<notin> S"
    from assms(1) step.hyps(1) step.hyps(2)
      have "\<exists>\<sigma>. strategy p \<sigma> \<and> strategy_attracts p \<sigma> S W"
      using merge_attractor_strategies by auto
    with *
      have "\<exists>\<sigma>. strategy p \<sigma> \<and> strategy_attracts_via p \<sigma> v0 (insert v0 S) W"
      using strategy_attracts_extends_VVp strategy_attracts_extends_VVpstar by blast
  }
  ultimately show ?case
    using step.prems step.hyps(2)
    attractor_strategy_on_extends[of p _ v0 "insert v0 S" W "W \<union> S \<union> directly_attracted p S"]
    attractor_strategy_on_extends[of p _ v0 "S"           W "W \<union> S \<union> directly_attracted p S"]
    attractor_strategy_on_extends[of p _ v0 "{}"          W "W \<union> S \<union> directly_attracted p S"]
    by blast
next
  case (union M)
  hence "\<exists>S. S \<in> M \<and> v0 \<in> S" by blast
  thus ?case by (meson Union_upper attractor_strategy_on_extends union.hyps)
qed

subsection \<open>Existence\<close>

text \<open>Prove that every attractor set has an attractor strategy.\<close>

theorem attractor_has_strategy:
  assumes "W \<subseteq> V"
  shows "\<exists>\<sigma>. strategy p \<sigma> \<and> strategy_attracts p \<sigma> (attractor p W) W"
proof-
  let ?A = "attractor p W"
  have "?A \<subseteq> V" by (simp add: \<open>W \<subseteq> V\<close> attractor_in_V)
  moreover
    have "\<And>v. v \<in> ?A \<Longrightarrow> \<exists>\<sigma>. strategy p \<sigma> \<and> strategy_attracts_via p \<sigma> v ?A W"
    using \<open>W \<subseteq> V\<close> attractor_has_strategy_single by blast
  ultimately show ?thesis using merge_attractor_strategies \<open>W \<subseteq> V\<close> by blast
qed

end \<comment> \<open>context ParityGame\<close>

end


theory Rene_Descartes
  imports Main
begin

section {*introduction*}

text {* This paper presents an automated verification of Rene Descartes's argument on @{ Text "my_mind_and_body_are_distinct"}.
here, I'm providing the whole argument to make it easy to the user who read this verification. *}

section {* The_Argument *}

text{*@{cite "https://www.youtube.com/watch?v=Din_92eKqW8&t=1457s"} I will note that mind differs importantly from body in that body is by it's nature divisible,
 while mind is indivisible when I think about my mind or in other words Myself in so far,
I am just a thinking being .I can't distinguish any parts.I understand myself to be a whole
unified thing although my whole mind seems united to my whole body.I know cutting off a foot or an
arm, would not take anything away from my mind and the abilities to will,sense and understand can't
be called parts that it is one and the same mind that wills,senses and understands on the other hand
whenever I think of a physical or extended thing, I can mentally divide it
and therefore understand that Object is divisible. the single fact would be enough to
teach me that my mind and my body are distinct. *}

typedecl e -- "type of physically existing things"
text ‹If it can be divided into parts it is divisible›

type_synonym σ = "e⇒bool"

consts breakable ::"σ"

consts body :: "e"  --"constant symbol for a physical thing"
consts mind :: "e"

consts whole :: \<sigma>
axiomatization where body_constrain: "breakable body" --"body is brekable"
axiomatization where mind_constrain: "\<not>breakable mind" --"mind is not breakable"
axiomatization where mindnotbody: "whole mind \<and>\<not>whole body"
abbreviation Leib_eql ::"e⇒e⇒bool"(infix"L="51) where
"(x L= y) ≡  ∀P. ((P x)⟶(P y))"

abbreviation distinct::"e⇒e⇒bool"  where
"distinct x y ≡ ¬(x L= y)"

theorem MyMindandMyBodyareDistinct:"distinct mind  body"
proof-
  from body_constrain mind_constrain have "(breakable body ∧ ¬ breakable mind)" by (rule conjI)
  from this have " ∃P. (P body ∧ ¬ P mind)" by auto
  from mindnotbody have "whole mind ∧ ¬ whole body" by blast
   from this have "∃P. (P mind ∧ ¬ P body)" by auto
   moreover from this  have "¬(mind L= body)" by auto
   ultimately show "distinct mind body" by auto
qed

 end


(**
  Author: Peter Lammich
  Inspired by Rene Neumann's DFS-Framework and Nested DFS formalization
**)
section \<open>Nested DFS using Standard Invariants Approach\<close>
theory NDFS_SI
imports
  CAVA_Automata.Automata_Impl
  CAVA_Automata.Lasso
  NDFS_SI_Statistics
  CAVA_Base.CAVA_Code_Target
begin

text \<open>
  Implementation of a nested DFS algorithm for accepting cycle detection
  using the refinement framework. The algorithm uses the improvement of
  Holzmann et al.~\<^cite>\<open>"HPY97"\<close>, i.e., it reports a cycle if the inner
  DFS finds a path back to
  the stack of the outer DFS. Moreover, an early cycle detection optimization is
  implemented~\<^cite>\<open>"SE05"\<close>, i.e., the outer DFS may already report a cycle on
  a back-edge involving an accepting node.

  The algorithm returns a witness in case that an accepting cycle is detected.

  The design approach to this algorithm is to first establish invariants of a
  generic DFS-Algorithm, which are then used to instantiate the concrete
  nested DFS-algorithm for B\"uchi emptiness check. This formalization can be
  seen as a predecessor of the formalization of
  Gabow's algorithm~\<^cite>\<open>"La14_ITP"\<close>, where this technique has been
  further developed.
\<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>
"

definition "gen_dfs_outer E U V0 it V brk \<equiv>
  V0 \<subseteq> U      \<comment> \<open>Start nodes below upper bound\<close>
  \<and> 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> (\<not>brk \<longrightarrow> E``V \<subseteq> V)  \<comment> \<open>Visited set closed under reachability\<close>
  \<and> (V0 - it \<subseteq> V) \<comment> \<open>Start nodes already iterated over are visited\<close>"

subsubsection "Invariant Preservation"
lemma gen_dfs_outer_initial:
  assumes "finite (E\<^sup>*``V0)"
  shows "gen_dfs_outer E (E\<^sup>*``V0) V0 V0 {} brk"
  using assms unfolding gen_dfs_outer_def
  by (auto intro: rev_ImageI)

lemma gen_dfs_pre_initial:
  assumes "gen_dfs_outer E U V0 it V False"
  assumes "v0\<in>U - V"
  shows "gen_dfs_pre E U {} V v0"
  using assms unfolding gen_dfs_pre_def gen_dfs_outer_def
  apply auto
  done

lemma fin_U_imp_wf:
  assumes "finite U"
  shows "wf (gen_dfs_var U)"
  using assms unfolding gen_dfs_var_def by auto

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

lemma gen_dfs_post_imp_outer:
  assumes "gen_dfs_outer E U V0 it Vis0 False"
  assumes "gen_dfs_post E U {} Vis0 v0 Vis False"
  assumes "v0 \<in> it" "it \<subseteq> V0" "v0 \<notin> Vis0"
  shows "gen_dfs_outer E U V0 (it - {v0}) Vis False"
proof -
  {
    assume "v0 \<in> it" "it \<subseteq> V0" "V0 \<subseteq> U" "E `` U \<subseteq> U"
    hence "E\<^sup>* `` {v0} \<subseteq> U"
      by (metis (full_types) empty_subsetI insert_subset rtrancl_reachable_induct subset_trans)
  } note AUX=this

  show ?thesis
    using assms
    unfolding gen_dfs_outer_def gen_dfs_post_def
    using AUX
    by auto
qed

lemma gen_dfs_outer_already_vis:
  assumes "v0 \<in> it" "it \<subseteq> V0" "v0 \<in> V"
  assumes "gen_dfs_outer E U V0 it V False"
  shows "gen_dfs_outer E U V0 (it - {v0}) V False"
  using assms
  unfolding gen_dfs_outer_def
  by auto

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;
      NDFS_SI_Statistics.vis_red_nres;

      \<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)
  "

datatype 'v blue_witness =
  NO_CYC                    \<comment> \<open>No cycle detected\<close>
| REACH "'v" "'v list"      \<comment> \<open>Path from current start node to node on
  stack, path contains accepting node.\<close>
(* REACH u p: u is on stack, p is non-empty path from u0 to u, a node
  in u or p is accepting *)
| CIRC "'v list" "'v list"  \<comment> \<open>@{text "CIRI pr pl"}: Lasso found from
  current start node.\<close>

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 u p) = (
  if u0=u then
    CIRC [] (u0#p)
  else
    REACH u (u0#p)
  )"
| "prep_wit_blue u0 (CIRC pr pl) = CIRC (u0#pr) pl"

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 [] p
  else REACH u p)"

definition init_wit_blue_early :: "'v \<Rightarrow> 'v \<Rightarrow> 'v blue_witness"
  where "init_wit_blue_early s t \<equiv> if s=t then CIRC [] [s] else REACH t [s]"

text \<open>Extract result from witness\<close>

term lasso_ext

definition "extract_res cyc
  \<equiv> (case cyc of
      CIRC pr pl \<Rightarrow> Some (pr,pl)
     | _ \<Rightarrow> None)"

subsubsection \<open>Outer (Blue) DFS\<close>
definition blue_dfs
  :: "('a,_) b_graph_rec_scheme \<Rightarrow> ('a list \<times> 'a list) option nres"
  where
  "blue_dfs G \<equiv> do {
    NDFS_SI_Statistics.start_nres;
    (_,_,cyc) \<leftarrow> FOREACHc (g_V0 G) (\<lambda>(_,_,cyc). cyc=NO_CYC)
      (\<lambda>v0 (blues,reds,_). do {
        if v0 \<notin> blues then do {
          (blues,reds,_,cyc) \<leftarrow> REC\<^sub>T (\<lambda>D (blues,reds,onstack,s). do {
            let blues=insert s blues;
            let onstack=insert s onstack;
            let s_acc = s \<in> bg_F G;
            NDFS_SI_Statistics.vis_blue_nres;
            (blues,reds,onstack,cyc) \<leftarrow>
            FOREACH\<^sub>C ((g_E G)``{s}) (\<lambda>(_,_,_,cyc). cyc=NO_CYC)
              (\<lambda>t (blues,reds,onstack,cyc).
                if t \<in> onstack \<and> (s_acc \<or> t \<in> bg_F G) then (
                  RETURN (blues,reds,onstack, init_wit_blue_early s t)
                ) else 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 do {
                  NDFS_SI_Statistics.match_blue_nres;
                  RETURN (blues,reds,onstack,cyc)
                })
              (blues,reds,onstack,NO_CYC);

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

            let onstack=onstack - {s};
            RETURN (blues,reds,onstack,cyc)
          }) (blues,reds,{},v0);
          RETURN (blues, reds, cyc)
        } else do {
          RETURN (blues, reds, NO_CYC)
        }
      }) ({},{},NO_CYC);
    NDFS_SI_Statistics.stop_nres;
    RETURN (extract_res cyc)
  }
  "

concrete_definition blue_dfs_fe uses blue_dfs_def
  is "blue_dfs G \<equiv> do {
    NDFS_SI_Statistics.start_nres;
    (_,_,cyc) \<leftarrow> ?FE;
    NDFS_SI_Statistics.stop_nres;
    RETURN (extract_res cyc)
  }"

concrete_definition blue_dfs_body uses blue_dfs_fe_def
  is "_ \<equiv> FOREACHc (g_V0 G) (\<lambda>(_,_,cyc). cyc=NO_CYC)
    (\<lambda>v0 (blues,reds,_). do {
      if v0\<notin>blues then do {
        (blues,reds,_,cyc) \<leftarrow> REC\<^sub>T ?B (blues,reds,{},v0);
        RETURN (blues, reds, cyc)
      } else do {RETURN (blues, reds, NO_CYC)}
    }) ({},{},NO_CYC)"

thm blue_dfs_body_def

subsection "Correctness"

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 intro: rev_ImageI)
  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;
      NDFS_SI_Statistics.vis_red_nres;

      \<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)

      (* First foreach loop, checking for onstack-successor*)
      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)

      (* Second foreach loop, iterating over sucessors *)
      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)

      (* Recursive call *)
      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 G :: "('v,_) b_graph_rec_scheme"
  assumes "b_graph G"
  assumes finitely_reachable: "finite ((g_E G)\<^sup>* `` g_V0 G)"
  shows "blue_dfs G \<le> SPEC (\<lambda>r.
    case r of None \<Rightarrow> (\<forall>L. \<not>b_graph.is_lasso_prpl G L)
  | Some L \<Rightarrow> b_graph.is_lasso_prpl G L)"
proof -
  interpret b_graph G by fact

  let ?A = "bg_F G"
  let ?E = "g_E G"
  let ?V0 = "g_V0 G"

  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 u p \<Rightarrow>
          path ?E u0 p u
        \<and> u \<in> onstack-{u0}
        \<and> insert u (set p) \<inter> ?A \<noteq> {}
    | CIRC pr pl \<Rightarrow> \<exists>v.
          pl\<noteq>[]
        \<and> path ?E v pl v
        \<and> path ?E u0 pr v
        \<and> set pl \<inter> ?A \<noteq> {}
    ))"

  define pre where "pre = (\<lambda>(blues,reds,onstack,u::'v).
    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)"

  define outer_inv where "outer_inv = (\<lambda>it (blues,reds,cyc).
    case cyc of
      NO_CYC \<Rightarrow>
        add_inv blues reds {}
      \<and> gen_dfs_outer ?E ?U ?V0 it blues False
    | CIRC pr pl \<Rightarrow> \<exists>v0\<in>?V0. \<exists>v.
        pl\<noteq>[]
      \<and> path ?E v pl v
      \<and> path ?E v0 pr v
      \<and> set pl \<inter> ?A \<noteq> {}
    | _ \<Rightarrow> False)"

  have OUTER_INITIAL: "outer_inv V0 ({}, {}, NO_CYC)"
    unfolding outer_inv_def add_inv_def
    using finitely_reachable
    apply (auto intro: red_dfs_inv_initial gen_dfs_outer_initial)
    done

  {
    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) []
      apply (auto simp: pre_def add_inv_def gen_dfs_pre_def) []
      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
      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 and u0::'v  and
      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 simp: path_simps)
      done
  } note FE_INV_PRES=this

  {
    fix blues reds onstack u0
    assume "pre (blues,reds,onstack,u0)"
    hence "u0\<in>?E\<^sup>*``?V0"
      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> p \<noteq> [] \<and> path ?E u0 p u0 \<and> set p \<inter> ?A \<noteq> {}) \<and>
          (u \<noteq> u0 \<longrightarrow>
              path ?E u0 p u \<and> u \<in> onstack0 \<and> (u \<in> ?A \<or> set p \<inter> ?A \<noteq> {}))"
        proof (intro conjI impI)
          from SPECR \<open>u0\<in>?A\<close> show
            "u\<noteq>u0 \<Longrightarrow> u\<in>onstack0"
            "p\<noteq>[]"
            "path ?E u0 p u"
            "u=u0 \<Longrightarrow> path ?E u0 p u0"
            "set p \<inter> F \<noteq> {}"
            "u \<in> F \<or> set p \<inter> F \<noteq> {}"
            by (auto simp: neq_Nil_conv path_simps)
        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 blues0 reds0 onstack0 and u0::'v  and
      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: "it\<subseteq>?E``{u0}" "t\<in>it"
    assume T_OS: "t \<in> onstack"
    assume U0ACC: "u0\<in>F \<or> t\<in>F"

    from T_OS have TIB: "t \<in> blues" using PRE FEI
      by (auto simp add: fe_inv_def pre_def gen_dfs_fe_inv_def gen_dfs_pre_def)

    have "fe_inv (insert u0 blues0) u0 (insert u0 onstack0) (it - {t})
      (blues,reds,onstack,init_wit_blue_early u0 t)"
      unfolding fe_inv_def
      apply (clarsimp simp: it_step_insert_iff[OF IT])
      apply (intro conjI)

      using PRE FEI apply (simp add: fe_inv_def pre_def)

      (* TODO: This is a generic early-break condition. However, it requires
        t \<in> V. Do we really need such a strict invar in case of break? *)
      using FEI TIB apply (auto simp add: fe_inv_def gen_dfs_fe_inv_def) []

      unfolding cyc_post_def init_wit_blue_early_def
      using IT T_OS U0ACC apply (auto simp: path_simps) []
      done
  } note EARLY_DET_OPT = this

  {
    fix \<sigma>
    assume INV0: "pre \<sigma>"

    have "REC\<^sub>T (blue_dfs_body G) \<sigma> \<le> SPEC (post \<sigma>)"
      apply (intro refine_vcg
        RECT_rule[where pre="pre"
        and V="gen_dfs_var ?U <*lex*> {}"]
      )
      apply (unfold blue_dfs_body_def, refine_mono) []
      apply (blast intro!: fin_U_imp_wf finitely_reachable)
      apply (rule INV0)

      (* Body *)
      apply (simp (no_asm) only: blue_dfs_body_def)
      apply (refine_rcg refine_vcg)

      (* Foreach loop *)
      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)

      (* Early detection of cycles *)
      apply (blast intro: EARLY_DET_OPT)

      (* Recursive call *)
      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)

      (* Nested DFS call *)
      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

  {
    fix v0 it blues reds
    assume "v0 \<in> it" "it \<subseteq> V0" "v0 \<notin> blues"
      "outer_inv it (blues, reds, NO_CYC)"
    hence "pre (blues, reds, {}, v0)"
      unfolding pre_def outer_inv_def
      by (auto intro: gen_dfs_pre_initial)
  } note OUTER_IMP_PRE = this

  {
    fix v0 it blues0 reds0 blues reds onstack cyc
    assume "v0 \<in> it" "it \<subseteq> V0" "v0 \<notin> blues0"
      "outer_inv it (blues0, reds0, NO_CYC)"
      "post (blues0, reds0, {}, v0) (blues, reds, onstack, cyc)"
    hence "outer_inv (it - {v0}) (blues, reds, cyc)"
      unfolding post_def outer_inv_def cyc_post_def
      by (fastforce split: blue_witness.split intro: gen_dfs_post_imp_outer)
  } note POST_IMP_OUTER = this

  {
    fix v0 it blues reds
    assume "v0 \<in> it" "it \<subseteq> V0" "outer_inv it (blues, reds, NO_CYC)"
      "v0 \<in> blues"
    hence "outer_inv (it - {v0}) (blues, reds, NO_CYC)"
      unfolding outer_inv_def
      by (auto intro: gen_dfs_outer_already_vis)
  } note OUTER_ALREX = this

  {
    fix it blues reds cyc
    assume "outer_inv it (blues, reds, cyc)" "cyc \<noteq> NO_CYC"
    hence "case extract_res cyc of
        None \<Rightarrow> \<forall>L. \<not> is_lasso_prpl L
      | Some x \<Rightarrow> is_lasso_prpl x"
      unfolding outer_inv_def extract_res_def is_lasso_prpl_def
        is_lasso_prpl_pre_def
      apply (cases cyc)
      apply auto
      done
  } note IMP_POST_CYC = this

  { fix "pr" pl blues reds
    assume ADD_INV: "add_inv blues reds {}"
    assume GEN_INV: "gen_dfs_outer E (E\<^sup>* `` V0) V0 {} blues False"
    assume LASSO: "is_lasso_prpl (pr, pl)"

    from LASSO[unfolded is_lasso_prpl_def is_lasso_prpl_pre_def]
    obtain v0 va where
      "v0\<in>V0" "pl\<noteq>[]" and
      PR: "path E v0 pr va" and PL: "path E va pl va" and
      F: "set pl \<inter> F \<noteq> {}"
      by auto

    from F obtain pl1 vf pl2 where [simp]: "pl=pl1@vf#pl2" and "vf\<in>F"
      by (fastforce simp: in_set_conv_decomp)

    from PR PL have "path E v0 (pr@pl1) vf" "path E vf (vf#pl2@pl1) vf"
      by (auto simp: path_simps)
    hence "(v0,vf)\<in>E\<^sup>*" and "(vf,vf)\<in>E\<^sup>+"
      by (auto dest: path_is_rtrancl path_is_trancl)

    from GEN_INV \<open>v0\<in>V0\<close> \<open>(v0,vf)\<in>E\<^sup>*\<close> have "vf\<in>blues"
      unfolding gen_dfs_outer_def
      apply (clarsimp)
      by (metis Image_closed_trancl rev_ImageI rev_subsetD)

    from ADD_INV[unfolded add_inv_def] \<open>vf\<in>blues\<close> \<open>vf\<in>F\<close> \<open>(vf,vf)\<in>E\<^sup>+\<close>
    have False by auto
  } note IMP_POST_NOCYC_AUX = this

  {
    fix blues reds cyc
    assume "outer_inv {} (blues, reds, cyc)"
    hence "case extract_res cyc of
        None \<Rightarrow> \<forall>L. \<not> is_lasso_prpl L
      | Some x \<Rightarrow> is_lasso_prpl x"
      apply (cases cyc)
      apply (simp_all add: IMP_POST_CYC)
      unfolding outer_inv_def extract_res_def
      apply (auto intro: IMP_POST_NOCYC_AUX)
      done
  } note IMP_POST_NOCYC = this

  show ?thesis
    unfolding blue_dfs_fe.refine blue_dfs_body.refine
    apply (refine_rcg
      FOREACHc_rule[where I=outer_inv]
      refine_vcg
    )

    apply (simp add: finitely_reachable finite_V0)

    apply (rule OUTER_INITIAL)

    apply (rule order_trans[OF GEN])
    apply (clarsimp, blast intro: OUTER_IMP_PRE)

    apply (clarsimp, blast intro: POST_IMP_OUTER)

    apply (clarsimp, blast intro: OUTER_ALREX)

    apply (clarsimp, blast intro: IMP_POST_NOCYC)

    apply (clarsimp, blast intro: IMP_POST_CYC)
    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 R \<equiv> \<langle>\<langle>\<langle>R\<rangle>list_rel,R\<rangle>prod_rel\<rangle>option_rel"
abbreviation "i_red_wit I \<equiv> \<langle>\<langle>\<langle>I\<rangle>\<^sub>ii_list,I\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_option"

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

lemmas [autoref_rel_intf] = REL_INTFI[of blue_wit_rel i_blue_wit]

term init_wit_blue_early

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 \<rightarrow>\<^sub>i i_red_wit I \<rightarrow>\<^sub>i i_blue_wit"
  "init_wit_blue_early ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i i_blue_wit"
  "prep_wit_blue ::\<^sub>i I \<rightarrow>\<^sub>i i_blue_wit \<rightarrow>\<^sub>i i_blue_wit"
  "red_init_witness ::\<^sub>i I \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i i_red_wit I"
  "prep_wit_red ::\<^sub>i I \<rightarrow>\<^sub>i i_red_wit I \<rightarrow>\<^sub>i i_red_wit I"
  "extract_res ::\<^sub>i i_blue_wit \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>I\<rangle>\<^sub>ii_list, \<langle>I\<rangle>\<^sub>ii_list\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_option"
  "red_dfs ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i I
    \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>I\<rangle>\<^sub>ii_set, i_red_wit I\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  "blue_dfs ::\<^sub>i i_bg i_unit I
    \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>\<langle>I\<rangle>\<^sub>ii_list, \<langle>I\<rangle>\<^sub>ii_list\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_option\<rangle>\<^sub>ii_nres"
  by auto

context begin interpretation autoref_syn .

term lasso_rel_ext

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"
  "\<And>R. PREFER_id R
    \<Longrightarrow> (init_wit_blue, init_wit_blue) \<in> R \<rightarrow> red_wit_rel R \<rightarrow> blue_wit_rel"
  "\<And>R. PREFER_id R
    \<Longrightarrow> (init_wit_blue_early, init_wit_blue_early) \<in> R \<rightarrow> R \<rightarrow> blue_wit_rel"
  "\<And>R. PREFER_id R
    \<Longrightarrow> (prep_wit_blue,prep_wit_blue)\<in>R \<rightarrow> blue_wit_rel \<rightarrow> blue_wit_rel"
  "\<And>R. PREFER_id R
    \<Longrightarrow> (red_init_witness, red_init_witness) \<in> R\<rightarrow>R\<rightarrow>red_wit_rel R"
  "\<And>R. PREFER_id R
    \<Longrightarrow> (prep_wit_red,prep_wit_red) \<in> R \<rightarrow> red_wit_rel R \<rightarrow> red_wit_rel R"
  "\<And>R. PREFER_id R
    \<Longrightarrow> (extract_res,extract_res)
        \<in> blue_wit_rel \<rightarrow> \<langle>\<langle>R\<rangle>list_rel\<times>\<^sub>r\<langle>R\<rangle>list_rel\<rangle>option_rel"
  by (simp_all)

subsubsection \<open>Actual Refinement\<close>

term red_dfs

term "map2set_rel (rbt_map_rel ord)"

term rbt_set_rel

schematic_goal red_dfs_refine_aux: "(?f::?'c, red_dfs::(('a::linorder \<times> _) set\<Rightarrow>_)) \<in> ?R"
  supply [autoref_tyrel] = ty_REL[where 'a="'a set" and R="\<langle>Id\<rangle>dflt_rs_rel"]
  unfolding red_dfs_def[abs_def]
  apply (autoref (trace,keep_goal))
  done
concrete_definition impl_red_dfs uses red_dfs_refine_aux

lemma impl_red_dfs_autoref[autoref_rules]:
  fixes R :: "('a\<times>'a::linorder) set"
  assumes "PREFER_id R"
  shows "(impl_red_dfs, red_dfs) \<in>
    \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<rangle>dflt_rs_rel \<rightarrow> \<langle>R\<rangle>dflt_rs_rel \<rightarrow> R
    \<rightarrow> \<langle>\<langle>R\<rangle>dflt_rs_rel \<times>\<^sub>r red_wit_rel R\<rangle>nres_rel"
  using assms impl_red_dfs.refine by simp

thm autoref_itype(1-10)

schematic_goal code_red_dfs_aux:
  shows "RETURN ?c \<le> impl_red_dfs E onstack V u"
  unfolding impl_red_dfs_def
  by (refine_transfer (post) the_resI)
concrete_definition code_red_dfs uses code_red_dfs_aux
prepare_code_thms code_red_dfs_def
declare code_red_dfs.refine[refine_transfer]

export_code code_red_dfs checking SML

schematic_goal red_dfs_hash_refine_aux: "(?f::?'c, red_dfs::(('a::hashable \<times> _) set\<Rightarrow>_)) \<in> ?R"
  supply [autoref_tyrel] = ty_REL[where 'a="'a set" and R="\<langle>Id\<rangle>hs.rel"]
  unfolding red_dfs_def[abs_def]
  apply (autoref (trace,keep_goal))
  done
concrete_definition impl_red_dfs_hash uses red_dfs_hash_refine_aux

thm impl_red_dfs_hash.refine

lemma impl_red_dfs_hash_autoref[autoref_rules]:
  fixes R :: "('a\<times>'a::hashable) set"
  assumes "PREFER_id R"
  shows "(impl_red_dfs_hash, red_dfs) \<in>
    \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<rangle>hs.rel \<rightarrow> \<langle>R\<rangle>hs.rel \<rightarrow> R
    \<rightarrow> \<langle>\<langle>R\<rangle>hs.rel \<times>\<^sub>r red_wit_rel R\<rangle>nres_rel"
  using assms impl_red_dfs_hash.refine by simp

schematic_goal code_red_dfs_hash_aux:
  shows "RETURN ?c \<le> impl_red_dfs_hash E onstack V u"
  unfolding impl_red_dfs_hash_def
  by (refine_transfer (post) the_resI)
concrete_definition code_red_dfs_hash uses code_red_dfs_hash_aux
prepare_code_thms code_red_dfs_hash_def
declare code_red_dfs_hash.refine[refine_transfer]

export_code code_red_dfs_hash checking SML

schematic_goal red_dfs_ahs_refine_aux: "(?f::?'c, red_dfs::(('a::hashable \<times> _) set\<Rightarrow>_)) \<in> ?R"
  supply [autoref_tyrel] = ty_REL[where 'a="'a::hashable set" and R="\<langle>Id\<rangle>ahs.rel"]
  unfolding red_dfs_def[abs_def]
  apply (autoref (trace,keep_goal))
  done
concrete_definition impl_red_dfs_ahs uses red_dfs_ahs_refine_aux

lemma impl_red_dfs_ahs_autoref[autoref_rules]:
  fixes R :: "('a\<times>'a::hashable) set"
  assumes "PREFER_id R"
  shows "(impl_red_dfs_ahs, red_dfs) \<in>
    \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<rangle>ahs.rel \<rightarrow> \<langle>R\<rangle>ahs.rel \<rightarrow> R
    \<rightarrow> \<langle>\<langle>R\<rangle>ahs.rel \<times>\<^sub>r red_wit_rel R\<rangle>nres_rel"
  using assms impl_red_dfs_ahs.refine by simp

schematic_goal code_red_dfs_ahs_aux:
  shows "RETURN ?c \<le> impl_red_dfs_ahs E onstack V u"
  unfolding impl_red_dfs_ahs_def
  by (refine_transfer the_resI)
concrete_definition code_red_dfs_ahs uses code_red_dfs_ahs_aux
prepare_code_thms code_red_dfs_ahs_def
declare code_red_dfs_ahs.refine[refine_transfer]

export_code code_red_dfs_ahs checking SML

(*abbreviation "blue_dfs_annot E A u \<equiv> blue_dfs E (A:::\<^sub>r\<langle>Id\<rangle>fun_set_rel) u"*)

schematic_goal blue_dfs_refine_aux: "(?f::?'c, blue_dfs::('a::linorder b_graph_rec\<Rightarrow>_)) \<in> ?R"
  supply [autoref_tyrel] =
    ty_REL[where 'a="'a" and R="Id"]
    ty_REL[where 'a="'a set" and R="\<langle>Id\<rangle>dflt_rs_rel"]
  unfolding blue_dfs_def[abs_def]
  apply (autoref (trace,keep_goal))
  done
concrete_definition impl_blue_dfs uses blue_dfs_refine_aux

thm impl_blue_dfs.refine

lemma impl_blue_dfs_autoref[autoref_rules]:
  fixes R :: "('a \<times> 'a::linorder) set"
  assumes "PREFER_id R"
  shows "(impl_blue_dfs, blue_dfs)
  \<in> bg_impl_rel_ext unit_rel R
   \<rightarrow> \<langle>\<langle>\<langle>R\<rangle>list_rel \<times>\<^sub>r \<langle>R\<rangle>list_rel\<rangle>Relators.option_rel\<rangle>nres_rel"
  using assms impl_blue_dfs.refine by simp

schematic_goal code_blue_dfs_aux:
  shows "RETURN ?c \<le> impl_blue_dfs G"
  unfolding impl_blue_dfs_def
  apply (refine_transfer (post) the_resI
    order_trans[OF det_RETURN code_red_dfs.refine])
  done
concrete_definition code_blue_dfs uses code_blue_dfs_aux
prepare_code_thms code_blue_dfs_def
declare code_blue_dfs.refine[refine_transfer]

export_code code_blue_dfs checking SML

schematic_goal blue_dfs_hash_refine_aux: "(?f::?'c, blue_dfs::('a::hashable b_graph_rec\<Rightarrow>_)) \<in> ?R"
  supply [autoref_tyrel] =
    ty_REL[where 'a="'a" and R="Id"]
    ty_REL[where 'a="'a::hashable set" and R="\<langle>Id\<rangle>hs.rel"]
  unfolding blue_dfs_def[abs_def]
  using [[autoref_trace_failed_id]]
  apply (autoref (trace,keep_goal))
  done
concrete_definition impl_blue_dfs_hash uses blue_dfs_hash_refine_aux

lemma impl_blue_dfs_hash_autoref[autoref_rules]:
  fixes R :: "('a \<times> 'a::hashable) set"
  assumes "PREFER_id R"
  shows "(impl_blue_dfs_hash, blue_dfs) \<in> bg_impl_rel_ext unit_rel R
    \<rightarrow> \<langle>\<langle>\<langle>R\<rangle>list_rel \<times>\<^sub>r \<langle>R\<rangle>list_rel\<rangle>Relators.option_rel\<rangle>nres_rel"
  using assms impl_blue_dfs_hash.refine by simp

schematic_goal code_blue_dfs_hash_aux:
  shows "RETURN ?c \<le> impl_blue_dfs_hash G"
  unfolding impl_blue_dfs_hash_def
  apply (refine_transfer the_resI
    order_trans[OF det_RETURN code_red_dfs_hash.refine])
  done
concrete_definition code_blue_dfs_hash uses code_blue_dfs_hash_aux
prepare_code_thms code_blue_dfs_hash_def
declare code_blue_dfs_hash.refine[refine_transfer]

export_code code_blue_dfs_hash checking SML

schematic_goal blue_dfs_ahs_refine_aux: "(?f::?'c, blue_dfs::('a::hashable b_graph_rec\<Rightarrow>_)) \<in> ?R"
  supply [autoref_tyrel] =
    ty_REL[where 'a="'a" and R="Id"]
    ty_REL[where 'a="'a::hashable set" and R="\<langle>Id\<rangle>ahs.rel"]
  unfolding blue_dfs_def[abs_def]
  apply (autoref (trace,keep_goal))
  done
concrete_definition impl_blue_dfs_ahs uses blue_dfs_ahs_refine_aux

lemma impl_blue_dfs_ahs_autoref[autoref_rules]:
  fixes R :: "('a \<times> 'a::hashable) set"
  assumes "MINOR_PRIO_TAG 5"
  assumes "PREFER_id R"
  shows "(impl_blue_dfs_ahs, blue_dfs) \<in> bg_impl_rel_ext unit_rel R
    \<rightarrow> \<langle>\<langle>\<langle>R\<rangle>list_rel \<times>\<^sub>r \<langle>R\<rangle>list_rel\<rangle>Relators.option_rel\<rangle>nres_rel"
  using assms impl_blue_dfs_ahs.refine by simp

thm impl_blue_dfs_ahs_def

schematic_goal code_blue_dfs_ahs_aux:
  shows "RETURN ?c \<le> impl_blue_dfs_ahs G"
  unfolding impl_blue_dfs_ahs_def
  apply (refine_transfer the_resI
    order_trans[OF det_RETURN code_red_dfs_ahs.refine])
  done
concrete_definition code_blue_dfs_ahs uses code_blue_dfs_ahs_aux
prepare_code_thms code_blue_dfs_ahs_def
declare code_blue_dfs_ahs.refine[refine_transfer]

export_code code_blue_dfs_ahs checking SML

text \<open>Correctness theorem\<close>
theorem code_blue_dfs_correct:
  assumes G: "b_graph G" "finite ((g_E G)\<^sup>* `` g_V0 G)"
  assumes REL: "(Gi,G)\<in>bg_impl_rel_ext unit_rel Id"
  shows "RETURN (code_blue_dfs Gi) \<le> SPEC (\<lambda>r.
    case r of None \<Rightarrow> \<forall>prpl. \<not>b_graph.is_lasso_prpl G prpl
  | Some L \<Rightarrow> b_graph.is_lasso_prpl G L)"
proof -
  note code_blue_dfs.refine
  also note impl_blue_dfs.refine[param_fo, OF REL, THEN nres_relD]
  also note blue_dfs_correct[OF G]
  finally show ?thesis by (simp cong: option.case_cong)
qed

theorem code_blue_dfs_correct':
  assumes G: "b_graph G" "finite ((g_E G)\<^sup>* `` g_V0 G)"
  assumes REL: "(Gi,G)\<in>bg_impl_rel_ext unit_rel Id"
  shows "case code_blue_dfs Gi of
      None \<Rightarrow> \<forall>prpl. \<not>b_graph.is_lasso_prpl G prpl
    | Some L \<Rightarrow> b_graph.is_lasso_prpl G L"
  using code_blue_dfs_correct[OF G REL]
  by simp

theorem code_blue_dfs_hash_correct:
  assumes G: "b_graph G" "finite ((g_E G)\<^sup>* `` g_V0 G)"
  assumes REL: "(Gi,G)\<in>bg_impl_rel_ext unit_rel Id"
  shows "RETURN (code_blue_dfs_hash Gi) \<le> SPEC (\<lambda>r.
    case r of None \<Rightarrow> \<forall>prpl. \<not>b_graph.is_lasso_prpl G prpl
  | Some L \<Rightarrow> b_graph.is_lasso_prpl G L)"
proof -
  note code_blue_dfs_hash.refine
  also note impl_blue_dfs_hash.refine[param_fo, OF REL, THEN nres_relD]
  also note blue_dfs_correct[OF G]
  finally show ?thesis by (simp cong: option.case_cong)
qed

theorem code_blue_dfs_hash_correct':
  assumes G: "b_graph G" "finite ((g_E G)\<^sup>* `` g_V0 G)"
  assumes REL: "(Gi,G)\<in>bg_impl_rel_ext unit_rel Id"
  shows "case code_blue_dfs_hash Gi of
      None \<Rightarrow> \<forall>prpl. \<not>b_graph.is_lasso_prpl G prpl
    | Some L \<Rightarrow> b_graph.is_lasso_prpl G L"
  using code_blue_dfs_hash_correct[OF G REL]
  by simp

theorem code_blue_dfs_ahs_correct:
  assumes G: "b_graph G" "finite ((g_E G)\<^sup>* `` g_V0 G)"
  assumes REL: "(Gi,G)\<in>bg_impl_rel_ext unit_rel Id"
  shows "RETURN (code_blue_dfs_ahs Gi) \<le> SPEC (\<lambda>r.
    case r of None \<Rightarrow> \<forall>prpl. \<not>b_graph.is_lasso_prpl G prpl
  | Some L \<Rightarrow> b_graph.is_lasso_prpl G L)"
proof -
  note code_blue_dfs_ahs.refine
  also note impl_blue_dfs_ahs.refine[param_fo, OF REL, THEN nres_relD]
  also note blue_dfs_correct[OF G]
  finally show ?thesis by (simp cong: option.case_cong)
qed

theorem code_blue_dfs_ahs_correct':
  assumes G: "b_graph G" "finite ((g_E G)\<^sup>* `` g_V0 G)"
  assumes REL: "(Gi,G)\<in>bg_impl_rel_ext unit_rel Id"
  shows "case code_blue_dfs_ahs Gi of
      None \<Rightarrow> \<forall>prpl. \<not>b_graph.is_lasso_prpl G prpl
    | Some L \<Rightarrow> b_graph.is_lasso_prpl G L"
  using code_blue_dfs_ahs_correct[OF G REL]
  by simp

text \<open>Export for benchmarking\<close>

schematic_goal acc_of_list_impl_hash:
  notes [autoref_tyrel] =
    ty_REL[where 'a="nat set" and R="\<langle>nat_rel\<rangle>iam_set_rel"]

  shows "(?f::?'c,\<lambda>l::nat list.
    let s=(set l):::\<^sub>r\<langle>nat_rel\<rangle>iam_set_rel
    in (\<lambda>x::nat. x\<in>s)
  ) \<in> ?R"
  apply (autoref (keep_goal))
  done

concrete_definition acc_of_list_impl_hash uses acc_of_list_impl_hash
export_code acc_of_list_impl_hash checking SML

definition "code_blue_dfs_nat
  \<equiv> code_blue_dfs :: _ \<Rightarrow> (nat list \<times> _) option"
definition "code_blue_dfs_hash_nat
  \<equiv> code_blue_dfs_hash :: _ \<Rightarrow> (nat list \<times> _) option"
definition "code_blue_dfs_ahs_nat
  \<equiv> code_blue_dfs_ahs :: _ \<Rightarrow> (nat list \<times> _) option"

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_hash_int \<equiv>
  acc_of_list_impl_hash o map nat_of_integer"

export_code
  code_blue_dfs_nat
  code_blue_dfs_hash_nat
  code_blue_dfs_ahs_nat
  succ_of_list_impl_int
  acc_of_list_impl_hash_int
  nat_of_integer
  integer_of_nat
  lasso_ext
  in SML module_name HPY_new_hash
  file \<open>nested_dfs_hash.sml\<close>

end


theory W
imports "../Nominal"
begin

text {* Example for strong induction rules avoiding sets of atoms. *}

atom_decl tvar var

abbreviation
  "difference_list" :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" ("_ - _" [60,60] 60)
where
  "xs - ys \<equiv> [x \<leftarrow> xs. x\<notin>set ys]"

lemma difference_eqvt_tvar[eqvt]:
  fixes pi::"tvar prm"
  and   Xs Ys::"tvar list"
  shows "pi\<bullet>(Xs - Ys) = (pi\<bullet>Xs) - (pi\<bullet>Ys)"
by (induct Xs) (simp_all add: eqvts)

lemma difference_fresh:
  fixes X::"tvar"
  and   Xs Ys::"tvar list"
  assumes a: "X\<in>set Ys"
  shows "X\<sharp>(Xs - Ys)"
using a
by (induct Xs) (auto simp add: fresh_list_nil fresh_list_cons fresh_atm)

lemma difference_supset:
  fixes xs::"'a list"
  and   ys::"'a list"
  and   zs::"'a list"
  assumes asm: "set xs \<subseteq> set ys"
  shows "xs - ys = []"
using asm
by (induct xs) (auto)

nominal_datatype ty =
    TVar "tvar"
  | Fun "ty" "ty" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype tyS =
    Ty  "ty"
  | ALL "\<guillemotleft>tvar\<guillemotright>tyS" ("\<forall>[_]._" [100,100] 100)

nominal_datatype trm =
    Var "var"
  | App "trm" "trm"
  | Lam "\<guillemotleft>var\<guillemotright>trm" ("Lam [_]._" [100,100] 100)
  | Let "\<guillemotleft>var\<guillemotright>trm" "trm"

abbreviation
  LetBe :: "var \<Rightarrow> trm \<Rightarrow> trm \<Rightarrow> trm" ("Let _ be _ in _" [100,100,100] 100)
where
 "Let x be t1 in t2 \<equiv> trm.Let x t2 t1"

type_synonym
  Ctxt  = "(var\<times>tyS) list"

text {* free type variables *}

consts ftv :: "'a \<Rightarrow> tvar list"

overloading
  ftv_prod \<equiv> "ftv :: ('a \<times> 'b) \<Rightarrow> tvar list"
  ftv_tvar \<equiv> "ftv :: tvar \<Rightarrow> tvar list"
  ftv_var  \<equiv> "ftv :: var \<Rightarrow> tvar list"
  ftv_list \<equiv> "ftv :: 'a list \<Rightarrow> tvar list"
  ftv_ty   \<equiv> "ftv :: ty \<Rightarrow> tvar list"
begin

primrec
  ftv_prod
where
 "ftv_prod (x, y) = (ftv x) @ (ftv y)"

definition
  ftv_tvar :: "tvar \<Rightarrow> tvar list"
where
[simp]: "ftv_tvar X \<equiv> [(X::tvar)]"

definition
  ftv_var :: "var \<Rightarrow> tvar list"
where
[simp]: "ftv_var x \<equiv> []"

primrec
  ftv_list
where
  "ftv_list [] = []"
| "ftv_list (x#xs) = (ftv x)@(ftv_list xs)"

nominal_primrec
  ftv_ty :: "ty \<Rightarrow> tvar list"
where
  "ftv_ty (TVar X) = [X]"
| "ftv_ty (T1 \<rightarrow>T2) = (ftv_ty T1) @ (ftv_ty T2)"
by (rule TrueI)+

end

lemma ftv_ty_eqvt[eqvt]:
  fixes pi::"tvar prm"
  and   T::"ty"
  shows "pi\<bullet>(ftv T) = ftv (pi\<bullet>T)"
by (nominal_induct T rule: ty.strong_induct)
   (perm_simp add: append_eqvt)+

overloading
  ftv_tyS  \<equiv> "ftv :: tyS \<Rightarrow> tvar list"
begin

nominal_primrec
  ftv_tyS :: "tyS \<Rightarrow> tvar list"
where
  "ftv_tyS (Ty T)    = ((ftv (T::ty))::tvar list)"
| "ftv_tyS (\<forall>[X].S) = (ftv_tyS S) - [X]"
apply(finite_guess add: ftv_ty_eqvt fs_tvar1)+
apply(rule TrueI)+
apply(rule difference_fresh)
apply(simp)
apply(fresh_guess add: ftv_ty_eqvt fs_tvar1)+
done

end

lemma ftv_tyS_eqvt[eqvt]:
  fixes pi::"tvar prm"
  and   S::"tyS"
  shows "pi\<bullet>(ftv S) = ftv (pi\<bullet>S)"
apply(nominal_induct S rule: tyS.strong_induct)
apply(simp add: eqvts)
apply(simp only: ftv_tyS.simps)
apply(simp only: eqvts)
apply(simp add: eqvts)
done

lemma ftv_Ctxt_eqvt[eqvt]:
  fixes pi::"tvar prm"
  and   \<Gamma>::"Ctxt"
  shows "pi\<bullet>(ftv \<Gamma>) = ftv (pi\<bullet>\<Gamma>)"
by (induct \<Gamma>) (auto simp add: eqvts)

text {* Valid *}
inductive
  valid :: "Ctxt \<Rightarrow> bool"
where
  V_Nil[intro]:  "valid []"
| V_Cons[intro]: "\<lbrakk>valid \<Gamma>;x\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((x,S)#\<Gamma>)"

equivariance valid

text {* General *}
primrec gen :: "ty \<Rightarrow> tvar list \<Rightarrow> tyS" where
  "gen T [] = Ty T"
| "gen T (X#Xs) = \<forall>[X].(gen T Xs)"

lemma gen_eqvt[eqvt]:
  fixes pi::"tvar prm"
  shows "pi\<bullet>(gen T Xs) = gen (pi\<bullet>T) (pi\<bullet>Xs)"
by (induct Xs) (simp_all add: eqvts)

abbreviation
  close :: "Ctxt \<Rightarrow> ty \<Rightarrow> tyS"
where
  "close \<Gamma> T \<equiv> gen T ((ftv T) - (ftv \<Gamma>))"

lemma close_eqvt[eqvt]:
  fixes pi::"tvar prm"
  shows "pi\<bullet>(close \<Gamma> T) = close (pi\<bullet>\<Gamma>) (pi\<bullet>T)"
by (simp_all only: eqvts)

text {* Substitution *}

type_synonym Subst = "(tvar\<times>ty) list"

consts
  psubst :: "Subst \<Rightarrow> 'a \<Rightarrow> 'a"       ("_<_>" [100,60] 120)

abbreviation
  subst :: "'a \<Rightarrow> tvar \<Rightarrow> ty \<Rightarrow> 'a"  ("_[_::=_]" [100,100,100] 100)
where
  "smth[X::=T] \<equiv> ([(X,T)])<smth>"

fun
  lookup :: "Subst \<Rightarrow> tvar \<Rightarrow> ty"
where
  "lookup [] X        = TVar X"
| "lookup ((Y,T)#\<theta>) X = (if X=Y then T else lookup \<theta> X)"

lemma lookup_eqvt[eqvt]:
  fixes pi::"tvar prm"
  shows "pi\<bullet>(lookup \<theta> X) = lookup (pi\<bullet>\<theta>) (pi\<bullet>X)"
by (induct \<theta>) (auto simp add: eqvts)

lemma lookup_fresh:
  fixes X::"tvar"
  assumes a: "X\<sharp>\<theta>"
  shows "lookup \<theta> X = TVar X"
using a
by (induct \<theta>)
   (auto simp add: fresh_list_cons fresh_prod fresh_atm)

overloading
  psubst_ty \<equiv> "psubst :: Subst \<Rightarrow> ty \<Rightarrow> ty"
begin

nominal_primrec
  psubst_ty
where
  "\<theta><TVar X>   = lookup \<theta> X"
| "\<theta><T\<^sub>1 \<rightarrow> T\<^sub>2> = (\<theta><T\<^sub>1>) \<rightarrow> (\<theta><T\<^sub>2>)"
by (rule TrueI)+

end

lemma psubst_ty_eqvt[eqvt]:
  fixes pi::"tvar prm"
  and   \<theta>::"Subst"
  and   T::"ty"
  shows "pi\<bullet>(\<theta><T>) = (pi\<bullet>\<theta>)<(pi\<bullet>T)>"
by (induct T rule: ty.induct) (simp_all add: eqvts)

overloading
  psubst_tyS \<equiv> "psubst :: Subst \<Rightarrow> tyS \<Rightarrow> tyS"
begin

nominal_primrec
  psubst_tyS :: "Subst \<Rightarrow> tyS \<Rightarrow> tyS"
where
  "\<theta><(Ty T)> = Ty (\<theta><T>)"
| "X\<sharp>\<theta> \<Longrightarrow> \<theta><(\<forall>[X].S)> = \<forall>[X].(\<theta><S>)"
apply(finite_guess add: psubst_ty_eqvt fs_tvar1)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess add: psubst_ty_eqvt fs_tvar1)+
done

end

overloading
  psubst_Ctxt \<equiv> "psubst :: Subst \<Rightarrow> Ctxt \<Rightarrow> Ctxt"
begin

fun
  psubst_Ctxt :: "Subst \<Rightarrow> Ctxt \<Rightarrow> Ctxt"
where
  "psubst_Ctxt \<theta> [] = []"
| "psubst_Ctxt \<theta> ((x,S)#\<Gamma>) = (x,\<theta><S>)#(psubst_Ctxt \<theta> \<Gamma>)"

end

lemma fresh_lookup:
  fixes X::"tvar"
  and   \<theta>::"Subst"
  and   Y::"tvar"
  assumes asms: "X\<sharp>Y" "X\<sharp>\<theta>"
  shows "X\<sharp>(lookup \<theta> Y)"
  using asms
  by (induct \<theta>)
     (auto simp add: fresh_list_cons fresh_prod fresh_atm)

lemma fresh_psubst_ty:
  fixes X::"tvar"
  and   \<theta>::"Subst"
  and   T::"ty"
  assumes asms: "X\<sharp>\<theta>" "X\<sharp>T"
  shows "X\<sharp>\<theta><T>"
  using asms
  by (nominal_induct T rule: ty.strong_induct)
     (auto simp add: fresh_list_append fresh_list_cons fresh_prod fresh_lookup)

lemma fresh_psubst_tyS:
  fixes X::"tvar"
  and   \<theta>::"Subst"
  and   S::"tyS"
  assumes asms: "X\<sharp>\<theta>" "X\<sharp>S"
  shows "X\<sharp>\<theta><S>"
  using asms
  by (nominal_induct S avoiding: \<theta>  X rule: tyS.strong_induct)
     (auto simp add: fresh_psubst_ty abs_fresh)

lemma fresh_psubst_Ctxt:
  fixes X::"tvar"
  and   \<theta>::"Subst"
  and   \<Gamma>::"Ctxt"
  assumes asms: "X\<sharp>\<theta>" "X\<sharp>\<Gamma>"
  shows "X\<sharp>\<theta><\<Gamma>>"
using asms
by (induct \<Gamma>)
   (auto simp add: fresh_psubst_tyS fresh_list_cons)

lemma subst_freshfact2_ty:
  fixes   X::"tvar"
  and     Y::"tvar"
  and     T::"ty"
  assumes asms: "X\<sharp>S"
  shows "X\<sharp>T[X::=S]"
  using asms
by (nominal_induct T rule: ty.strong_induct)
   (auto simp add: fresh_atm)

text {* instance of a type scheme *}
inductive
  inst :: "ty \<Rightarrow> tyS \<Rightarrow> bool"("_ \<prec> _" [50,51] 50)
where
  I_Ty[intro]:  "T \<prec> (Ty T)"
| I_All[intro]: "\<lbrakk>X\<sharp>T'; T \<prec> S\<rbrakk> \<Longrightarrow> T[X::=T'] \<prec> \<forall>[X].S"

equivariance inst[tvar]

nominal_inductive inst
  by (simp_all add: abs_fresh subst_freshfact2_ty)

lemma subst_forget_ty:
  fixes T::"ty"
  and   X::"tvar"
  assumes a: "X\<sharp>T"
  shows "T[X::=S] = T"
  using a
  by  (nominal_induct T rule: ty.strong_induct)
      (auto simp add: fresh_atm)

lemma psubst_ty_lemma:
  fixes \<theta>::"Subst"
  and   X::"tvar"
  and   T'::"ty"
  and   T::"ty"
  assumes a: "X\<sharp>\<theta>"
  shows "\<theta><T[X::=T']> = (\<theta><T>)[X::=\<theta><T'>]"
using a
apply(nominal_induct T avoiding: \<theta> X T' rule: ty.strong_induct)
apply(auto simp add: ty.inject lookup_fresh)
apply(rule sym)
apply(rule subst_forget_ty)
apply(rule fresh_lookup)
apply(simp_all add: fresh_atm)
done

lemma general_preserved:
  fixes \<theta>::"Subst"
  assumes a: "T \<prec> S"
  shows "\<theta><T> \<prec> \<theta><S>"
using a
apply(nominal_induct T S avoiding: \<theta> rule: inst.strong_induct)
apply(auto)[1]
apply(simp add: psubst_ty_lemma)
apply(rule_tac I_All)
apply(simp add: fresh_psubst_ty)
apply(simp)
done

text{* typing judgements *}
inductive
  typing :: "Ctxt \<Rightarrow> trm \<Rightarrow> ty \<Rightarrow> bool" (" _ \<turnstile> _ : _ " [60,60,60] 60)
where
  T_VAR[intro]: "\<lbrakk>valid \<Gamma>; (x,S)\<in>set \<Gamma>; T \<prec> S\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
| T_APP[intro]: "\<lbrakk>\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>1\<rightarrow>T\<^sub>2; \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> App t\<^sub>1 t\<^sub>2 : T\<^sub>2"
| T_LAM[intro]: "\<lbrakk>x\<sharp>\<Gamma>;((x,Ty T\<^sub>1)#\<Gamma>) \<turnstile> t : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : T\<^sub>1\<rightarrow>T\<^sub>2"
| T_LET[intro]: "\<lbrakk>x\<sharp>\<Gamma>; \<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>1; ((x,close \<Gamma> T\<^sub>1)#\<Gamma>) \<turnstile> t\<^sub>2 : T\<^sub>2; set (ftv T\<^sub>1 - ftv \<Gamma>) \<sharp>* T\<^sub>2\<rbrakk>
                 \<Longrightarrow> \<Gamma> \<turnstile> Let x be t\<^sub>1 in t\<^sub>2 : T\<^sub>2"

equivariance typing[tvar]

lemma fresh_tvar_trm:
  fixes X::"tvar"
  and   t::"trm"
  shows "X\<sharp>t"
by (nominal_induct t rule: trm.strong_induct)
   (simp_all add: fresh_atm abs_fresh)

lemma ftv_ty:
  fixes T::"ty"
  shows "supp T = set (ftv T)"
by (nominal_induct T rule: ty.strong_induct)
   (simp_all add: ty.supp supp_atm)

lemma ftv_tyS:
  fixes S::"tyS"
  shows "supp S = set (ftv S)"
by (nominal_induct S rule: tyS.strong_induct)
   (auto simp add: tyS.supp abs_supp ftv_ty)

lemma ftv_Ctxt:
  fixes \<Gamma>::"Ctxt"
  shows "supp \<Gamma> = set (ftv \<Gamma>)"
apply (induct \<Gamma>)
apply (simp_all add: supp_list_nil supp_list_cons)
apply (rename_tac a \<Gamma>')
apply (case_tac a)
apply (simp add: supp_prod supp_atm ftv_tyS)
done

lemma ftv_tvars:
  fixes Tvs::"tvar list"
  shows "supp Tvs = set Tvs"
by (induct Tvs)
   (simp_all add: supp_list_nil supp_list_cons supp_atm)

lemma difference_supp:
  fixes xs ys::"tvar list"
  shows "((supp (xs - ys))::tvar set) = supp xs - supp ys"
by (induct xs)
   (auto simp add: supp_list_nil supp_list_cons ftv_tvars)

lemma set_supp_eq:
  fixes xs::"tvar list"
  shows "set xs = supp xs"
by (induct xs)
   (simp_all add: supp_list_nil supp_list_cons supp_atm)

nominal_inductive2 typing
  avoids T_LET: "set (ftv T\<^sub>1 - ftv \<Gamma>)"
apply (simp add: fresh_star_def fresh_def ftv_Ctxt)
apply (simp add: fresh_star_def fresh_tvar_trm)
apply assumption
apply simp
done

lemma perm_fresh_fresh_aux:
  "\<forall>(x,y)\<in>set (pi::tvar prm). x \<sharp> z \<and> y \<sharp> z \<Longrightarrow> pi \<bullet> (z::'a::pt_tvar) = z"
  apply (induct pi rule: rev_induct)
  apply simp
  apply (simp add: split_paired_all pt_tvar2)
  apply (frule_tac x="(a, b)" in bspec)
  apply simp
  apply (simp add: perm_fresh_fresh)
  done

lemma freshs_mem:
  fixes S::"tvar set"
  assumes "x \<in> S"
  and     "S \<sharp>* z"
  shows  "x \<sharp> z"
using assms by (simp add: fresh_star_def)

lemma fresh_gen_set:
  fixes X::"tvar"
  and   Xs::"tvar list"
  assumes asm: "X\<in>set Xs"
  shows "X\<sharp>gen T Xs"
using asm
apply(induct Xs)
apply(simp)
apply(rename_tac a Xs')
apply(case_tac "X=a")
apply(simp add: abs_fresh)
apply(simp add: abs_fresh)
done

lemma close_fresh:
  fixes \<Gamma>::"Ctxt"
  shows "\<forall>(X::tvar)\<in>set ((ftv T) - (ftv \<Gamma>)). X\<sharp>(close \<Gamma> T)"
by (simp add: fresh_gen_set)

lemma gen_supp:
  shows "(supp (gen T Xs)::tvar set) = supp T - supp Xs"
by (induct Xs)
   (auto simp add: supp_list_nil supp_list_cons tyS.supp abs_supp supp_atm)

lemma minus_Int_eq:
  shows "T - (T - U) = T \<inter> U"
  by blast

lemma close_supp:
  shows "supp (close \<Gamma> T) = set (ftv T) \<inter> set (ftv \<Gamma>)"
  apply (simp add: gen_supp difference_supp ftv_ty ftv_Ctxt)
  apply (simp only: set_supp_eq minus_Int_eq)
  done

lemma better_T_LET:
  assumes x: "x\<sharp>\<Gamma>"
  and t1: "\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>1"
  and t2: "((x,close \<Gamma> T\<^sub>1)#\<Gamma>) \<turnstile> t\<^sub>2 : T\<^sub>2"
  shows "\<Gamma> \<turnstile> Let x be t\<^sub>1 in t\<^sub>2 : T\<^sub>2"
proof -
  have fin: "finite (set (ftv T\<^sub>1 - ftv \<Gamma>))" by simp
  obtain pi where pi1: "(pi \<bullet> set (ftv T\<^sub>1 - ftv \<Gamma>)) \<sharp>* (T\<^sub>2, \<Gamma>)"
    and pi2: "set pi \<subseteq> set (ftv T\<^sub>1 - ftv \<Gamma>) \<times> (pi \<bullet> set (ftv T\<^sub>1 - ftv \<Gamma>))"
    by (rule at_set_avoiding [OF at_tvar_inst fin fs_tvar1, of "(T\<^sub>2, \<Gamma>)"])
  from pi1 have pi1': "(pi \<bullet> set (ftv T\<^sub>1 - ftv \<Gamma>)) \<sharp>* \<Gamma>"
    by (simp add: fresh_star_prod)
  have Gamma_fresh: "\<forall>(x,y)\<in>set pi. x \<sharp> \<Gamma> \<and> y \<sharp> \<Gamma>"
    apply (rule ballI)
    apply (simp add: split_paired_all)
    apply (drule subsetD [OF pi2])
    apply (erule SigmaE)
    apply (drule freshs_mem [OF _ pi1'])
    apply (simp add: ftv_Ctxt [symmetric] fresh_def)
    done
  have close_fresh': "\<forall>(x, y)\<in>set pi. x \<sharp> close \<Gamma> T\<^sub>1 \<and> y \<sharp> close \<Gamma> T\<^sub>1"
    apply (rule ballI)
    apply (simp add: split_paired_all)
    apply (drule subsetD [OF pi2])
    apply (erule SigmaE)
    apply (drule bspec [OF close_fresh])
    apply (drule freshs_mem [OF _ pi1'])
    apply (simp add: fresh_def close_supp ftv_Ctxt)
    done
  note x
  moreover from Gamma_fresh perm_boolI [OF t1, of pi]
  have "\<Gamma> \<turnstile> t\<^sub>1 : pi \<bullet> T\<^sub>1"
    by (simp add: perm_fresh_fresh_aux eqvts fresh_tvar_trm)
  moreover from t2 close_fresh'
  have "(x,(pi \<bullet> close \<Gamma> T\<^sub>1))#\<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2"
    by (simp add: perm_fresh_fresh_aux)
  with Gamma_fresh have "(x,close \<Gamma> (pi \<bullet> T\<^sub>1))#\<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2"
    by (simp add: close_eqvt perm_fresh_fresh_aux)
  moreover from pi1 Gamma_fresh
  have "set (ftv (pi \<bullet> T\<^sub>1) - ftv \<Gamma>) \<sharp>* T\<^sub>2"
    by (simp only: eqvts fresh_star_prod perm_fresh_fresh_aux)
  ultimately show ?thesis by (rule T_LET)
qed

lemma ftv_ty_subst:
  fixes T::"ty"
  and   \<theta>::"Subst"
  and   X Y ::"tvar"
  assumes a1: "X \<in> set (ftv T)"
  and     a2: "Y \<in> set (ftv (lookup \<theta> X))"
  shows "Y \<in> set (ftv (\<theta><T>))"
using a1 a2
by (nominal_induct T rule: ty.strong_induct) (auto)

lemma ftv_tyS_subst:
  fixes S::"tyS"
  and   \<theta>::"Subst"
  and   X Y::"tvar"
  assumes a1: "X \<in> set (ftv S)"
  and     a2: "Y \<in> set (ftv (lookup \<theta> X))"
  shows "Y \<in> set (ftv (\<theta><S>))"
using a1 a2
by (nominal_induct S avoiding: \<theta> Y rule: tyS.strong_induct)
   (auto simp add: ftv_ty_subst fresh_atm)

lemma ftv_Ctxt_subst:
  fixes \<Gamma>::"Ctxt"
  and   \<theta>::"Subst"
  assumes a1: "X \<in> set (ftv \<Gamma>)"
  and     a2: "Y \<in> set (ftv (lookup \<theta> X))"
  shows "Y \<in> set (ftv (\<theta><\<Gamma>>))"
using a1 a2
by (induct \<Gamma>)
   (auto simp add: ftv_tyS_subst)

lemma gen_preserved1:
  assumes asm: "Xs \<sharp>* \<theta>"
  shows "\<theta><gen T Xs> = gen (\<theta><T>) Xs"
using asm
by (induct Xs)
   (auto simp add: fresh_star_def)

lemma gen_preserved2:
  fixes T::"ty"
  and   \<Gamma>::"Ctxt"
  assumes asm: "((ftv T) - (ftv \<Gamma>)) \<sharp>* \<theta>"
  shows "((ftv (\<theta><T>)) - (ftv (\<theta><\<Gamma>>))) = ((ftv T) - (ftv \<Gamma>))"
using asm
apply(nominal_induct T rule: ty.strong_induct)
apply(auto simp add: fresh_star_def)
apply(simp add: lookup_fresh)
apply(simp add: ftv_Ctxt[symmetric])
apply(fold fresh_def)
apply(rule fresh_psubst_Ctxt)
apply(assumption)
apply(assumption)
apply(rule difference_supset)
apply(auto)
apply(simp add: ftv_Ctxt_subst)
done

lemma close_preserved:
  fixes \<Gamma>::"Ctxt"
  assumes asm: "((ftv T) - (ftv \<Gamma>)) \<sharp>* \<theta>"
  shows "\<theta><close \<Gamma> T> = close (\<theta><\<Gamma>>) (\<theta><T>)"
using asm
by (simp add: gen_preserved1 gen_preserved2)

lemma var_fresh_for_ty:
  fixes x::"var"
  and   T::"ty"
  shows "x\<sharp>T"
by (nominal_induct T rule: ty.strong_induct)
   (simp_all add: fresh_atm)

lemma var_fresh_for_tyS:
  fixes x::"var"
  and   S::"tyS"
  shows "x\<sharp>S"
by (nominal_induct S rule: tyS.strong_induct)
   (simp_all add: abs_fresh var_fresh_for_ty)

lemma psubst_fresh_Ctxt:
  fixes x::"var"
  and   \<Gamma>::"Ctxt"
  and   \<theta>::"Subst"
  shows "x\<sharp>\<theta><\<Gamma>> = x\<sharp>\<Gamma>"
by (induct \<Gamma>)
   (auto simp add: fresh_list_cons fresh_list_nil fresh_prod var_fresh_for_tyS)

lemma psubst_valid:
  fixes \<theta>::Subst
  and   \<Gamma>::Ctxt
  assumes a: "valid \<Gamma>"
  shows "valid (\<theta><\<Gamma>>)"
using a
by (induct)
   (auto simp add: psubst_fresh_Ctxt)

lemma psubst_in:
  fixes \<Gamma>::"Ctxt"
  and   \<theta>::"Subst"
  and   pi::"tvar prm"
  and   S::"tyS"
  assumes a: "(x,S)\<in>set \<Gamma>"
  shows "(x,\<theta><S>)\<in>set (\<theta><\<Gamma>>)"
using a
by (induct \<Gamma>)
   (auto simp add: calc_atm)

lemma typing_preserved:
  fixes \<theta>::"Subst"
  and   pi::"tvar prm"
  assumes a: "\<Gamma> \<turnstile> t : T"
  shows "(\<theta><\<Gamma>>) \<turnstile> t : (\<theta><T>)"
using a
proof (nominal_induct \<Gamma> t T avoiding: \<theta> rule: typing.strong_induct)
  case (T_VAR \<Gamma> x S T)
  have a1: "valid \<Gamma>" by fact
  have a2: "(x, S) \<in> set \<Gamma>" by fact
  have a3: "T \<prec> S" by fact
  have  "valid (\<theta><\<Gamma>>)" using a1 by (simp add: psubst_valid)
  moreover
  have  "(x,\<theta><S>)\<in>set (\<theta><\<Gamma>>)" using a2 by (simp add: psubst_in)
  moreover
  have "\<theta><T> \<prec> \<theta><S>" using a3 by (simp add: general_preserved)
  ultimately show "(\<theta><\<Gamma>>) \<turnstile> Var x : (\<theta><T>)" by (simp add: typing.T_VAR)
next
  case (T_APP \<Gamma> t1 T1 T2 t2)
  have "\<theta><\<Gamma>> \<turnstile> t1 : \<theta><T1 \<rightarrow> T2>" by fact
  then have "\<theta><\<Gamma>> \<turnstile> t1 : (\<theta><T1>) \<rightarrow> (\<theta><T2>)" by simp
  moreover
  have "\<theta><\<Gamma>> \<turnstile> t2 : \<theta><T1>" by fact
  ultimately show "\<theta><\<Gamma>> \<turnstile> App t1 t2 : \<theta><T2>" by (simp add: typing.T_APP)
next
  case (T_LAM x \<Gamma> T1 t T2)
  fix pi::"tvar prm" and \<theta>::"Subst"
  have "x\<sharp>\<Gamma>" by fact
  then have "x\<sharp>\<theta><\<Gamma>>" by (simp add: psubst_fresh_Ctxt)
  moreover
  have "\<theta><((x, Ty T1)#\<Gamma>)> \<turnstile> t : \<theta><T2>" by fact
  then have "((x, Ty (\<theta><T1>))#(\<theta><\<Gamma>>)) \<turnstile> t : \<theta><T2>" by (simp add: calc_atm)
  ultimately show "\<theta><\<Gamma>> \<turnstile> Lam [x].t : \<theta><T1 \<rightarrow> T2>" by (simp add: typing.T_LAM)
next
  case (T_LET x \<Gamma> t1 T1 t2 T2)
  have vc: "((ftv T1) - (ftv \<Gamma>)) \<sharp>* \<theta>" by fact
  have "x\<sharp>\<Gamma>" by fact
   then have a1: "x\<sharp>\<theta><\<Gamma>>" by (simp add: calc_atm psubst_fresh_Ctxt)
  have a2: "\<theta><\<Gamma>> \<turnstile> t1 : \<theta><T1>" by fact
  have a3: "\<theta><((x, close \<Gamma> T1)#\<Gamma>)> \<turnstile> t2 : \<theta><T2>" by fact
  from a2 a3 show "\<theta><\<Gamma>> \<turnstile> Let x be t1 in t2 : \<theta><T2>"
    apply -
    apply(rule better_T_LET)
    apply(rule a1)
    apply(rule a2)
    apply(simp add: close_preserved vc)
    done
qed

end


theory SinCos_FieldWithSinCos_E1
imports Main
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize [\"th_sc1\",\"ga_nonEmpty\",\"ga_notDefBottom\",\"ga_totality\",\"ga_totality_1\",\"ga_totality_2\",\"ga_totality_3\",\"ga_totality_4\",\"ga_totality_5\",\"ga_totality_6\",\"ga_totality_7\",\"ga_totality_8\",\"ga_totality_9\",\"ga_strictness\",\"ga_strictness_1\",\"Ax1\",\"Ax2\",\"th_ef1\",\"th_ef2\",\"th_ef3\",\"th_ef4\",\"Ax1_1\",\"Ax2_1\",\"Ax3\",\"Ax4\",\"Ax5\",\"th_f0\",\"th_f1\",\"th_f2\",\"th_f3\",\"th_f4\",\"th_f5\",\"th_f6_h\",\"th_f6\",\"th_f7\",\"th_f8\",\"th_f10\",\"th_f11\",\"th_f12\",\"ga_assoc___PlusX__\",\"ga_comm___PlusX__\",\"ga_right_unit___PlusX__\",\"ga_left_unit___PlusX__\",\"ga_assoc___xX__\",\"ga_comm___xX__\",\"ga_right_unit___xX__\",\"ga_left_unit___xX__\",\"Ax9\",\"Ax10\",\"Ax11\",\"Ax12\",\"Ax13\"]"

typedecl Elem

consts
MinusXXX :: "Elem => Elem" ("(-''/ _)" [62] 62)
X0 :: "Elem" ("0''")
X1 :: "Elem" ("1''")
X2 :: "Elem" ("2")
XXMinusXXX :: "Elem => Elem => Elem" ("(_ -''/ _)" [55,55] 54)
XXPlusXXX :: "Elem => Elem => Elem" ("(_ +''/ _)" [54,55] 54)
XXSlashXXX :: "Elem => Elem => Elem" ("(_ '/''/ _)" [57,57] 56)
XXxXXX :: "Elem => Elem => Elem" ("(_ *''/ _)" [56,57] 56)
cosXX :: "Elem => Elem" ("(cos/ _)" [62] 62)
g__bottom :: "Elem" ("g'_'_bottom")
g__defined :: "Elem => bool" ("g'_'_defined'(_')" [10] 999)
invXXX :: "Elem => Elem" ("(inv''/ _)" [62] 62)
qdrXX :: "Elem => Elem" ("(qdr/ _)" [62] 62)
sinXX :: "Elem => Elem" ("(sin/ _)" [62] 62)

instance Elem::type
by intro_classes

axioms
ga_nonEmpty : "EX x. g__defined(x)"

ga_notDefBottom [simp] : "ALL x. (~ g__defined(x)) = (x = g__bottom)"

ga_totality [simp] : "ALL x_1. g__defined(-' x_1) = g__defined(x_1)"

ga_totality_1 [simp] : "g__defined(0')"

ga_totality_2 [simp] : "g__defined(1')"

ga_totality_3 [simp] : "g__defined(2)"

ga_totality_4 [simp] : "ALL x_1. ALL x_2. g__defined(x_1 *' x_2) = (g__defined(x_1) & g__defined(x_2))"

ga_totality_5 [simp] : "ALL x_1. ALL x_2. g__defined(x_1 +' x_2) = (g__defined(x_1) & g__defined(x_2))"

ga_totality_6 [simp] : "ALL x_1. ALL x_2. g__defined(x_1 -' x_2) = (g__defined(x_1) & g__defined(x_2))"

ga_totality_7 [simp] : "ALL x_1. g__defined(cos x_1) = g__defined(x_1)"

ga_totality_8 [simp] : "ALL x_1. g__defined(qdr x_1) = g__defined(x_1)"

ga_totality_9 [simp] : "ALL x_1. g__defined(sin x_1) = g__defined(x_1)"

ga_strictness  : "ALL x_1. ALL x_2. g__defined(x_1 /' x_2) --> g__defined(x_1) & g__defined(x_2)"

ga_strictness_1  : "ALL x_1. g__defined(inv' x_1) --> g__defined(x_1)"

Ax1  : "ALL x. ALL y. g__defined(x) & g__defined(y) --> sin (x -' y) = sin x *' cos y -' cos x *' sin y"

Ax2  : "ALL x. ALL y. g__defined(x) & g__defined(y) --> cos (x -' y) = cos x *' cos y +' sin x *' sin y"

th_ef1 : "ALL x. g__defined(x) --> 2 *' x = x +' x"

th_ef2  : "ALL x. ALL y. g__defined(x) & g__defined(y) --> qdr (x +' y) = qdr x +' 2 *' x *' y +' qdr y"

th_ef3  : "ALL x. ALL y. g__defined(x) & g__defined(y) --> qdr (x -' y) = qdr x +' -' 2 *' x *' y +' qdr y"

th_ef4  : "ALL x. ALL y. g__defined(x) & g__defined(y) --> (x +' y) *' (x -' y) = qdr x -' qdr y"

Ax1_1  : "2 = 1' +' 1'"

Ax2_1 [simp]  : "ALL x. ALL y. g__defined(x) & g__defined(y) --> x -' y = x +' -' y"

Ax3  : "ALL x. g__defined(x) --> qdr x = x *' x"

Ax4 [simp] : "ALL x. ALL y. g__defined(x) & g__defined(y) --> g__defined(x /' y) = (~ y = 0')"

Ax5  : "ALL x. ALL y. g__defined(x) & g__defined(y) --> g__defined(x /' y) --> x /' y = inv' y *' x"

th_f0 [simp] : "ALL x. g__defined(x) --> -' -' x = x"

th_f1  : "ALL x. g__defined(x) --> -' x = -' 1' *' x"

th_f2 [simp] : "ALL x. g__defined(x) --> 0' *' x = 0'"

th_f3 [simp] : "ALL x. g__defined(x) --> 1' *' x = x"

th_f4 [simp] : "ALL x. ALL y. g__defined(x) & g__defined(y) --> -' x *' y = -' (x *' y)"

th_f5 [simp] : "ALL x. ALL y. g__defined(x) & g__defined(y) --> x *' y = 0' --> x = 0' | y = 0'"

th_f6_h : "ALL x. ALL y. ALL z. g__defined(x) & g__defined(y) & g__defined(z) --> (y +' z) *' x = x *' (y +' z)"

th_f6  : "ALL x. ALL y. ALL z. g__defined(x) & g__defined(y) & g__defined(z) --> (y +' z) *' x = y *' x +' z *' x"

th_f7 [simp] : "ALL x. g__defined(x) --> g__defined(inv' x) & g__defined(inv' inv' x) --> inv' inv' x = x"

th_f8 [simp] : "-' 1' *' -' 1' = 1'"

th_f10 [simp] : "ALL x. ALL y. g__defined(x) & g__defined(y) --> x *' -' y = -' (x *' y)"

th_f11 [simp] : "ALL x. ALL y. g__defined(x) & g__defined(y) --> -' x *' -' y = -' -' (x *' y)"

th_f12 [simp] : "ALL x. ALL y. g__defined(x) & g__defined(y) --> -' x *' -' y = x *' y"

ga_assoc___PlusX__ [simp] : "ALL x. ALL y. ALL z. g__defined(x) & g__defined(y) & g__defined(z) --> x +' (y +' z) = x +' y +' z"

ga_comm___PlusX__  : "ALL x. ALL y. g__defined(x) & g__defined(y) --> x +' y = y +' x"

ga_right_unit___PlusX__ [simp] : "ALL x. g__defined(x) --> x +' 0' = x"

ga_left_unit___PlusX__ [simp] : "ALL x. g__defined(x) --> 0' +' x = x"

ga_assoc___xX__ [simp] : "ALL x. ALL y. ALL z. g__defined(x) & g__defined(y) & g__defined(z) --> x *' (y *' z) = x *' y *' z"

ga_comm___xX__ : "ALL x. ALL y. g__defined(x) & g__defined(y) --> x *' y = y *' x"

ga_right_unit___xX__ [simp] : "ALL x. g__defined(x) --> x *' 1' = x"

ga_left_unit___xX__ [simp] : "ALL x. g__defined(x) --> 1' *' x = x"

Ax9 [simp] : "~ 0' = 1'"

Ax10 [simp] : "ALL x. g__defined(x) --> x +' -' x = 0'"

Ax11 [simp] : "ALL x. g__defined(x) --> g__defined(inv' x) = (~ x = 0')"

Ax12 : "ALL x. g__defined(x) --> g__defined(inv' x) --> x *' inv' x = 1'"

Ax13  : "ALL x. ALL y. ALL z. g__defined(x) & g__defined(y) & g__defined(z) --> x *' (y +' z) = x *' y +' x *' z"

ML "reset trace_simp"
theorem th_sc1 : "sin 0' = 0'"
apply(insert ga_nonEmpty)
apply(erule exE)
apply (subst Ax1[THEN spec, THEN spec, of "x", of "x", simplified])
apply (simp)
using ga_comm___xX__ apply(simp)
done

ML "Header.record \"th_sc1\""

end