theory Alarm
imports "../../lib/VDMToolkit"
begin

(*****************************************)

type_synonym Period   = VDMToken

(* If you don't add these, you will need to know it's inv_True where needed.
   Arguably you have to have a initialisation proof for every invariant as
   they will participate (i.e. any lemmas they require) in latter feasibility
   proofs. Of course the inv_True cases can be ignored
 *)
definition
  inv_Period :: "Period \<Rightarrow> \<bool>"
  where
  "inv_Period \<equiv> inv_True"

type_synonym ExpertId = VDMToken

definition
 inv_ExpertId :: "ExpertId \<Rightarrow> \<bool>"
 where
 "inv_ExpertId \<equiv> inv_True"

datatype Qualification = Elec | Mech | Bio | Chem

definition
  inv_Qualification :: "Qualification \<Rightarrow> \<bool>"
  where
  "inv_Qualification \<equiv> inv_True"

record Alarm =
  alarm_alarmtext :: "char VDMSeq"
  alarm_quali     :: Qualification

(* Always have True invariant for all types, even when not defined so that
   they are available for later translations, as well as readability and partial proofs

   Arguably, it should also be from Alarm_scheme (e.g. compose ... end in VDM), given that
   in VDM the syntax of the defined type for records can't talk about the record itself.
 *)
definition
  inv_Alarm :: "Alarm \<Rightarrow> \<bool>"
  where
  "inv_Alarm \<equiv> inv_True"

record Expert =
  expert_expertid  :: ExpertId
  expert_quali     :: "Qualification VDMSet"

definition
  inv_Expert :: "Expert \<Rightarrow> \<bool>"
  where
  "inv_Expert e \<equiv>
      let eq = (expert_quali e) in
        inv_SetElems inv_True eq \<and>
        eq \<noteq> {}"

lemmas inv_Expert_defs = inv_SetElems_def inv_Expert_def

(* You could add the theorem directly without the need of a definition; I like to
   separate them again to enable code generation in separate parts.
 *)
definition
  PO_Expert_init :: \<bool>
  where
  "PO_Expert_init \<equiv> \<exists> e . inv_Expert e"

theorem PO_Expert_init: PO_Expert_init
  unfolding PO_Expert_init_def inv_Expert_def Let_def
  apply (rule exI[of _ "\<lparr> expert_expertid = ''X'', expert_quali = {Bio}\<rparr>"])
  by simp

(* Useful in inv_Plant witness *)
lemma l_inv_Expert_w[simp]: "expert_quali e \<noteq> {} \<Longrightarrow> inv_Expert e"
  by (simp add: inv_Expert_def)

type_synonym Schedule = "Period \<rightharpoonup> Expert set"

(* This is fine but will entail more complicated proofs unnecessarily *)
definition
  inv_Schedule :: "Schedule \<Rightarrow> \<bool>"
  where
  "inv_Schedule s \<equiv>
      inv_Map inv_Period (inv_SetElems inv_Expert) s
 \<and>
      (\<forall> exs1 \<in> rng s .
          exs1 \<noteq> {} \<and>
          (\<forall> ex1 \<in> exs1 . \<forall> ex2 \<in> exs1 .
              ex1 \<noteq> ex2 \<longrightarrow> (expert_quali ex1) \<noteq> (expert_quali ex2)))"

definition
  inv_Schedule2 :: "Schedule \<Rightarrow> \<bool>"
  where
  "inv_Schedule2 s \<equiv>
      inv_Map inv_Period (inv_SetElems inv_Expert) s
 \<and>
      (\<forall> exs1 \<in> rng s .
          exs1 \<noteq> {} \<and>
          (\<forall> ex1 \<in> exs1 . \<forall> ex2 \<in> (exs1 - {ex1}) .
              (expert_quali ex1) = (expert_quali ex2)))"

definition
  PO_Schedule_init :: \<bool>
  where
  "PO_Schedule_init \<equiv> \<exists> s . inv_Schedule s"

(* These existential proofs are harder becuase of the required witness in the \<exists>;
   one strategy is to let schematic variables and crunch goal close to clarer subgoals
   and that will also allow safe/simp etc to work, but won't finish the proof
 *)
theorem PO_Schedule_init: PO_Schedule_init
  unfolding PO_Schedule_init_def inv_Schedule_def
  (* Because you have the VDM AST you know what introduction rules will be needed
     based on the structure of the tree
   *)
  (*apply (intro exI conjI ballI impI) *)
  apply (intro exI, safe)
  (* First goal is a nice suggestion for a weakening lemma *)
  (* Second goal is telling me the original model is redudant *)
  (* Third goal is dependant on the witness provided for ?s *)
  oops

(* Weakening lemmas trade given goals to simpler/easier (often multiple) subgoals,
   with True as the ultimate aim as the "sub goal" needed, as the example below (which isn't true)
 *)
lemma l_inv_Schedule_inv_Map_w:
    "\<lbrakk> inv_VDMSet (dom s) ; inv_VDMSet (ran s) ;
       inv_SetElems (inv_SetElems inv_Expert) (ran s) \<rbrakk>
     \<Longrightarrow>
      inv_Map inv_Period (inv_SetElems inv_Expert) s"
  unfolding inv_Map_def inv_Period_def by simp

theorem PO_Schedule_init: PO_Schedule_init
  unfolding PO_Schedule_init_def inv_Schedule_def
  (* Like with Event-B, you can imainge at modelling time, asking the user to provide
     a satisfying witness for the model. See AlarmSL.vdmsl
  apply (intro exI[of _ "\<lparr>expert_period = ''e1'', expert_quali = {Bio}\<rparr>"])
   *)
  apply (intro exI, safe)
  apply (rule l_inv_Schedule_inv_Map_w)
  oops

  value "[ [''p1'', ''p2''] [\<mapsto>]
           [{ \<lparr>expert_expertid = ''e1'', expert_quali = {Bio}\<rparr> },
            { \<lparr>expert_expertid = ''e2'', expert_quali = {Elec}\<rparr> }
           ] ]"

theorem PO_Schedule_init: PO_Schedule_init
  unfolding PO_Schedule_init_def inv_Schedule_def
  apply (rule exI[of _
                    "[ [''p1'', ''p2'']
                       [\<mapsto>]
                       [{ \<lparr>expert_expertid = ''e1'', expert_quali = {Bio}\<rparr> },
                        { \<lparr>expert_expertid = ''e2'', expert_quali = {Elec}\<rparr> }
                       ]
                     ]"
                 ], safe)
    apply (rule l_inv_Schedule_inv_Map_w)
      apply (simp add: inv_VDMSet_def)
     apply (simp add: inv_VDMSet_def)
    apply (simp add: inv_SetElems_def inv_Expert_def)
    (* Here you see why map enumerations / comprehensions are tricky: Isabelle likes them
       list-based, and doesn't have enough automation.
     *)
    unfolding rng_def ran_def
     apply (safe, simp split:if_splits)
    apply (simp split:if_splits)
    apply auto
    oops (* proof is finished, but forget it to try again nicer *)

(* As a general principle, let's define / translate the witnesses defined with @witness! *)

definition
  witness_Schedule :: Schedule
  where
  "witness_Schedule \<equiv> [ [''p1'', ''p2''] [\<mapsto>]
           [{ \<lparr>expert_expertid = ''e1'', expert_quali = {Bio, Elec}\<rparr> },
            { \<lparr>expert_expertid = ''e2'', expert_quali = {Elec, Bio}\<rparr> }
           ] ]"

lemmas witness_Schedule_defs = witness_Schedule_def inv_Schedule_def

lemma l_witness_Schedule: "inv_Schedule witness_Schedule"
  unfolding witness_Schedule_defs
  apply safe
  (* the simplifier will work if you chain all the necessary facts at once *)
  apply (simp add: l_inv_Schedule_inv_Map_w inv_VDMSet_def inv_Expert_defs)
  unfolding rng_defs
  by (auto split:if_splits)

(* Ain't that a much neater proof?! This shows how the use of designed witnesses work well
   and can be chained too, as defined in the example for the witness for Plant
 *)
theorem PO_Schedule_init: PO_Schedule_init
  unfolding PO_Schedule_init_def using l_witness_Schedule by blast

record Plant =
  plant_schedule :: Schedule
  plant_alarms   :: "Alarm VDMSet"

definition
  pre_QualificationOK :: "Expert VDMSet \<Rightarrow> Qualification \<Rightarrow> \<bool>"
  where
  "pre_QualificationOK exs reqquali \<equiv>
      inv_VDMSet exs \<and>
      inv_SetElems inv_Expert exs \<and>
      inv_Qualification reqquali"

definition
  post_QualificationOK :: "Expert VDMSet \<Rightarrow> Qualification \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
  "post_QualificationOK exs q RESULT \<equiv>
    pre_QualificationOK exs q \<and>
    inv_True RESULT"

definition
  QualificationOK :: "Expert VDMSet \<Rightarrow> Qualification \<Rightarrow> \<bool>"
  where
  "QualificationOK exs reqquali \<equiv>
      \<exists> ex \<in> exs . reqquali \<in> (expert_quali ex)"

definition
  PO_QualificationOK_feas0 :: \<bool>
  where
  "PO_QualificationOK_feas0 \<equiv> \<forall> exs q . pre_QualificationOK exs q \<longrightarrow> (\<exists> r . r = QualificationOK exs q \<and> post_QualificationOK exs q r)"

theorem PO_QualificationOK_feas0: PO_QualificationOK_feas0
  unfolding PO_QualificationOK_feas0_def post_QualificationOK_def
  by (safe, simp)

(* This is better for later proofs; arguably doesn't matter*)
theorem PO_QualificationOK_feas:
  "pre_QualificationOK exs q \<Longrightarrow> post_QualificationOK exs q (QualificationOK exs q)"
  by (simp add: post_QualificationOK_def)

(* Here because QualificationOK is a boolean valued function, and we are defining
   another boolean valued function with the invariant, then they appear together

   Initialisation proof below shows why it's wrong; go look.
 *)
definition
  inv_Plant_wrong :: "Plant \<Rightarrow> \<bool>"
  where
  "inv_Plant_wrong p \<equiv>
      let sch = (plant_schedule p);
          alm = (plant_alarms p)
      in
         \<forall> a \<in> alm . \<forall> peri \<in> dom sch .
            pre_QualificationOK (the (sch peri)) (alarm_quali a) \<and>
            QualificationOK (the (sch peri)) (alarm_quali a)"

definition
  PO_Plant_wrong_init :: \<bool>
  where
  "PO_Plant_wrong_init \<equiv> \<exists> s . inv_Plant_wrong s"

lemma PO_plant_init_l1_w:
    "peri \<in> dom (plant_schedule s) \<Longrightarrow>
       inv_VDMSet (the (plant_schedule s peri))"
  apply safe
  unfolding inv_VDMSet_def
  apply simp
  apply (cases s, simp) using [[show_types]]
    (* Can't know whether range elements of plant_schedule are finite sets;
       missing inv_Schedule for it, as well as inv_VDMSet for the plant_alarms!
     *)
  oops
lemma PO_plant_init_l2_w:
    "peri \<in> dom (plant_schedule s) \<Longrightarrow>
       inv_SetElems inv_Expert (the (plant_schedule s peri))"
  unfolding inv_Expert_defs
  apply (simp,safe)
    (* Again missing inv_Expert for result of plant_schedule!@@@! *)
  oops

theorem PO_Plant_wrong_init: PO_Plant_wrong_init
  unfolding PO_Plant_wrong_init_def inv_Plant_wrong_def Let_def
  apply (intro exI ballI conjI)
  unfolding pre_QualificationOK_def inv_Qualification_def
    (* can the goals be true in general? create the lemmas

       lemmas work, but are unprovable, see comments
   apply (frule PO_plant_init_l1_w)
    apply (frule PO_plant_init_l2_w)
   apply (simp)
     *)
    defer
  unfolding QualificationOK_def
  apply (rule bexI)
    (* we now know our witness needs goals 1-2 *)
  oops

definition
  inv_Plant :: "Plant \<Rightarrow> \<bool>"
  where
  "inv_Plant p \<equiv>
      let sch = (plant_schedule p);
          alm = (plant_alarms p)
      in
         inv_Schedule sch \<and> inv_SetElems inv_Alarm alm \<and>
         (\<forall> a \<in> alm . \<forall> peri \<in> dom sch .
            pre_QualificationOK (the (sch peri)) (alarm_quali a) \<and>
            QualificationOK (the (sch peri)) (alarm_quali a))"

definition
  witness_Plant :: Plant
  where
  "witness_Plant \<equiv> \<lparr> plant_schedule = witness_Schedule, plant_alarms = {} \<rparr>"

(* @TODO come up with a measure/heuristic for what to expand based on the AST
         structure / user defined with @expand annotation? *)
lemmas witness_Plant_defs = witness_Plant_def inv_Plant_def Let_def

lemma l_witness_Plant: "inv_Plant witness_Plant"
  unfolding witness_Plant_defs
  apply safe
  apply (simp add: l_witness_Schedule)
  (* Alarms ought to be there? *)
  by simp_all

definition
  PO_Plant_init :: \<bool>
  where
  "PO_Plant_init \<equiv> \<exists> s . inv_Plant s"

theorem PO_Plant_init: PO_Plant_init
  unfolding PO_Plant_init_def using l_witness_Plant by blast

(* Out of interest let's see if a nicer witness works as well *)
definition
  inv_Plant1 :: "Plant \<Rightarrow> \<bool>"
  where
  "inv_Plant1 p \<equiv> inv_Plant p \<and> inv_VDMSet1 (plant_alarms p)"

definition
  witness_Plant1 :: Plant
  where
  "witness_Plant1 \<equiv> witness_Plant\<lparr> plant_alarms :=
      {\<lparr> alarm_alarmtext = ''A1'', alarm_quali = Bio \<rparr>,
       \<lparr> alarm_alarmtext = ''A2'', alarm_quali = Elec \<rparr>
      }
                     \<rparr>"

(* @TODO come up with a measure/heuristic for what to expand based on the AST
         structure / user defined with @expand annotation? *)
lemmas witness_Plant1_defs = witness_Plant1_def inv_Plant1_def witness_Plant_def Let_def

lemma l_witness_Plant1: "inv_Plant1 witness_Plant1"
  unfolding witness_Plant1_defs
  apply (simp,safe)
  unfolding inv_Plant_def
   apply (simp add: l_witness_Schedule)
  unfolding witness_Schedule_def pre_QualificationOK_def inv_Alarm_def
   apply (simp add: inv_Qualification_def QualificationOK_def)
  by (simp add: inv_VDMSet1_defs)

definition
  PO_Plant1_init :: \<bool>
  where
  "PO_Plant1_init \<equiv> \<exists> s . inv_Plant1 s"

theorem PO_Plant1_init: PO_Plant1_init
  unfolding PO_Plant1_init_def using l_witness_Plant1 by blast

(*****************************************)

(*Useful artificial functions to show the point *)

definition
  pre_g :: "Qualification \<Rightarrow> \<bool>"
  where
  "pre_g q \<equiv> inv_Qualification q \<and> q \<noteq> Chem"

definition
  post_g :: "Qualification \<Rightarrow> VDMNat \<Rightarrow> \<bool>"
  where
  "post_g q RESULT \<equiv>
      pre_g q \<and>
      inv_VDMNat RESULT \<and>
      RESULT mod 10 = 0 \<and> RESULT \<ge> 10"

definition
  g :: "Qualification \<Rightarrow> VDMNat"
  where
  "g q \<equiv> (case q of Elec \<Rightarrow> 10 | Mech \<Rightarrow> 20 | Bio \<Rightarrow> 30)"

definition
  PO_g_feas :: \<bool>
  where
  "PO_g_feas \<equiv> \<forall> q . pre_g q \<longrightarrow> (\<exists> r . r = g q \<and> post_g q r)"

theorem PO_g_feas: PO_g_feas
  unfolding PO_g_feas_def post_g_def g_def pre_g_def
  apply simp
  unfolding inv_Qualification_def inv_True_def inv_VDMNat_def
  by (intro allI impI, case_tac q, auto)

(* Given the number of times Expert VDMSet is used as a type, it would make
   translation more readble to have it defined as a type of its own like

   Experts = set of Expert

   and then translate it as well.
 *)
definition
  pre_f :: "Expert VDMSet \<Rightarrow> Qualification \<Rightarrow> \<bool>"
  where
  "pre_f exs q \<equiv>
      inv_VDMSet exs \<and> inv_SetElems inv_Expert exs \<and> inv_Qualification q \<and>
      (pre_QualificationOK exs q \<and> QualificationOK exs q \<longrightarrow> pre_g q)"

definition
  post_f :: "Expert VDMSet \<Rightarrow> Qualification \<Rightarrow> VDMNat \<Rightarrow> \<bool>"
  where
  "post_f exs q RESULT \<equiv>
     pre_f exs q \<and>
     inv_VDMNat RESULT \<and>
     post_vdm_card exs (vdm_card exs) \<and>
     post_g q (g q) \<and>
     RESULT mod 2 = 0
     "

definition
  f :: "Expert VDMSet \<Rightarrow> Qualification \<Rightarrow> VDMNat"
  where
  "f exs q \<equiv> vdm_card exs + g q"

definition
  PO_f_feas :: \<bool>
  where
  "PO_f_feas \<equiv> \<forall> exs q . pre_f exs q \<longrightarrow> (\<exists> r . r = f exs q \<and> post_f exs q r)"

(* Even the proof scripts can be automatically generated, roughly, as particular strategies.
   Some of those can take advantage of Eisbach as well, or skip-in-case-failure modes etc.

   Unfold + simp, from types \<rightarrow> post \<rightarrow> pre \<rightarrow> def top-most first

   LATTER: there is also the possibility of having "lemmas" statememnts defined to compose/combine
   various def expansions in one.
 *)
theorem PO_f_feasibility: PO_f_feas
  unfolding PO_f_feas_def
  (*  apply (simp )*)
  unfolding post_f_def
  apply simp
  unfolding post_g_def
  apply simp
  unfolding post_vdm_card_def
  unfolding f_def g_def
    (* vdm_card_def, say because it's a basic function; don't go there;
use lemmas instead *)

  unfolding pre_f_def pre_g_def
  apply simp
  unfolding pre_QualificationOK_def
  apply simp
  unfolding QualificationOK_def
  (* go to the invariants then*)
  apply safe
  (* or to the subgoals of interest; when to have them? Here was one with a late strategy, let's see one with an earlier strategy *)
    oops

lemmas PO_f_top_level_def =  PO_f_feas_def post_f_def post_g_def

theorem PO_f_feasibility: PO_f_feas
  unfolding PO_f_top_level_def
  apply (simp)
  apply safe
      (* At this point as part of the translation strategy you could spawn each
         subgoal as a lemma to be used in this proof. That is not optimal and a choice
         of what is a lemma is needed; possibly the AST can give hints to this
       *)
  oops

lemma PO_f_g: "pre_g q \<Longrightarrow> 0 \<le> g q"
  unfolding g_def pre_g_def by (cases q, auto)

lemma PO_f_l1_l1:
    "inv_VDMSet exs \<Longrightarrow> inv_SetElems inv_Expert exs  \<Longrightarrow> pre_QualificationOK exs q"
  unfolding pre_QualificationOK_def
  by (simp  add: inv_Qualification_def) (* this showed missing inv_VDMSet exs in pre_f *)

lemma PO_f_l1_l2:
    "e \<in> exs \<Longrightarrow> q \<in> expert_quali e \<Longrightarrow> QualificationOK exs q"
  unfolding QualificationOK_def inv_Expert_def Let_def
  by (rule bexI, simp_all)

lemma PO_f_l1_l3_f:
    "inv_VDMSet exs \<Longrightarrow> e \<in> exs \<Longrightarrow> inv_SetElems inv_Expert exs \<Longrightarrow> \<exists> ex\<in>exs. \<exists>q . q \<in> expert_quali ex"
  unfolding inv_SetElems_def QualificationOK_def
  apply (elim ballE[of _ _ e], intro bexI[of _ e])
  apply (simp_all)
  unfolding inv_Expert_def Let_def
  by auto (* constructing this took a whiel because of the necessary bindings in various places *)

lemma PO_f_l1: "pre_f exs q \<Longrightarrow> inv_VDMNat (f exs q)"
  unfolding f_def pre_f_def pre_QualificationOK_def
  apply (elim conjE ) (* don't impE here, as the pre for g might fail; in which case we get a contradictory case *)
   apply (meson PO_f_l1_l3_f empty_iff l_inv_SetElems_empty)
   defer
  thm equals0D empty_iff
   apply (simp add: PO_f_g inv_VDMNat_def inv_VDMSet_def)
  unfolding inv_VDMNat_def
  apply (rule PO_f_l1_l2)
  oops (* this seems to show there is something missing in pre_f for when pre_g fails it doesn't work! *)

lemma PO_f_l2: "pre_f exs q \<Longrightarrow> post_vdm_card exs (vdm_card exs)"
  unfolding post_vdm_card_def pre_vdm_card_def pre_f_def
  using PO_feas_vdm_card post_vdm_card_def pre_vdm_card_def by blast

lemma PO_f_l3: "pre_f exs q \<Longrightarrow> pre_g q"
  unfolding pre_f_def
  apply (elim conjE impE, intro conjI)
    apply (simp add: PO_f_l1_l1)
   defer apply simp
  apply (subgoal_tac "exs \<noteq> {}")

  unfolding QualificationOK_def find_theorems "_ \<noteq> {}"
    apply (simp add: ex_in_conv[of exs,symmetric])
  apply (rule bexI[of _ "\<lparr>expert_expertid = ''E1'', expert_quali = {q}\<rparr>"], simp)
  unfolding inv_SetElems_def inv_Expert_def Let_def apply simp
   apply (frule PO_f_l1_l3_f, simp_all)
    oops (* missing pre? *)

lemma PO_f_l3: "pre_f exs q \<Longrightarrow> exs \<noteq> {} \<Longrightarrow> pre_g q"
  unfolding pre_f_def
  apply (elim conjE impE, intro conjI)
    apply (simp add: PO_f_l1_l1)
   defer apply simp
    find_theorems "_ \<Longrightarrow> QualificationOK _ _ "
    apply (simp add: ex_in_conv[of exs,symmetric], safe)
    apply (rule PO_f_l1_l2, simp)
  oops

lemma PO_f_l4: "pre_f exs q \<Longrightarrow> inv_VDMNat (g q)" oops
lemma PO_f_l5: "pre_f exs q \<Longrightarrow> g q mod 10 = 0" oops
lemma PO_f_l6: "pre_f exs q \<Longrightarrow> 10 \<le> g q" oops
lemma PO_f_l7: "pre_f exs q \<Longrightarrow> f exs q mod 2 = 0" oops

theorem PO_f_feasibility: PO_f_feas
  unfolding PO_f_top_level_def
(*  apply (simp add: PO_f_l1 PO_f_l2 PO_f_l3 PO_f_l4 PO_f_l5 PO_f_l6 PO_f_l7) *)
    oops

definition
  pre_f_stronger_old :: "Expert VDMSet \<Rightarrow> Qualification \<Rightarrow> \<bool>"
  where
  "pre_f_stronger_old exs q \<equiv>
      inv_VDMSet exs \<and> inv_SetElems inv_Expert exs \<and> inv_Qualification q \<and>
      pre_QualificationOK exs q \<and> QualificationOK exs q \<and> pre_g q"

definition
  pre_f_stronger :: "Expert VDMSet \<Rightarrow> Qualification \<Rightarrow> \<bool>"
  where
  "pre_f_stronger exs q \<equiv>
      inv_VDMSet exs \<and> inv_SetElems inv_Expert exs \<and> inv_Qualification q \<and>
      pre_QualificationOK exs q \<and> QualificationOK exs q \<and> pre_g q \<and>
      vdm_card exs mod 2 = 0"

definition
  post_f_stronger :: "Expert VDMSet \<Rightarrow> Qualification \<Rightarrow> VDMNat \<Rightarrow> \<bool>"
  where
  "post_f_stronger exs q RESULT \<equiv>
     pre_f_stronger exs q \<and>
     inv_VDMNat RESULT \<and>
     post_vdm_card exs (vdm_card exs) \<and>
     post_g q (g q) \<and>
     RESULT mod 2 = 0
     "

definition
  PO_f_stronger_feas :: \<bool>
  where
  "PO_f_stronger_feas \<equiv> \<forall> exs q . pre_f_stronger exs q \<longrightarrow> (\<exists> r . r = f exs q \<and> post_f_stronger exs q r)"

lemmas PO_f_stronger_top_level_def =  PO_f_stronger_feas_def post_f_stronger_def post_g_def

lemma PO_f_stronger_l0:
  "pre_f_stronger exs q \<Longrightarrow> pre_g q"
  unfolding pre_f_stronger_def by simp

lemma PO_f_stronger_l1:
  "pre_f_stronger exs q \<Longrightarrow> finite exs"
  unfolding pre_f_stronger_def inv_VDMSet_def by simp

lemma PO_g_mod_10: "pre_g q \<Longrightarrow> g q mod 10 = 0"
  unfolding pre_g_def g_def
  by (case_tac q, simp_all)

lemma PO_g_geq_10: "pre_g q \<Longrightarrow> g q \<ge> 10"
  unfolding pre_g_def g_def
  by (case_tac q, simp_all)

(* difficulty in this one is the chaining of forward reasoning facts *)
lemma PO_f_stronger_l2: "pre_f_stronger exs q \<Longrightarrow> f exs q \<ge> 0"
  unfolding  f_def
  apply (frule PO_f_stronger_l0, frule PO_g_geq_10, frule PO_f_stronger_l1)
  apply (frule l_vdm_card_positive)
  by linarith

lemma PO_f_stronger_l3_l0: "pre_g q \<Longrightarrow> g q mod 2 = 0"
  unfolding pre_g_def g_def by (case_tac q, auto)

lemma PO_f_stronger_l4:
  "pre_f_stronger exs q \<Longrightarrow> int (card exs) mod 2 = 0"
  unfolding pre_f_stronger_def vdm_card_def
  by (simp split: if_splits)

lemma PO_f_stronger_l3: "pre_f_stronger exs q \<Longrightarrow> f exs q mod 2 = 0"
  unfolding f_def
  apply (cut_tac PO_f_stronger_l0 PO_f_stronger_l3_l0, simp_all)
  apply (frule PO_f_stronger_l1)
  find_theorems "_ + _ mod _"
  by (simp add: mod_add_eq PO_f_stronger_l4)
  (* Aha! missing precondition *)

theorem PO_f_feasibility: PO_f_stronger_feas
  unfolding PO_f_stronger_top_level_def
  apply (intro allI impI)
    apply (simp add: PO_f_g inv_VDMNat_def PO_f_stronger_l0)
    apply (simp add: PO_f_stronger_l0 PO_g_mod_10 PO_g_geq_10)
  apply (simp add: PO_f_stronger_l1 PO_f_stronger_l2 PO_f_stronger_l3)
  by (simp add: inv_VDMNat_def post_vdm_card_def)

(*****************************************)

(* pre / post of those *)
definition
  NumberOfExperts :: "Period \<Rightarrow> Plant \<Rightarrow> VDMNat"
where
  "NumberOfExperts peri plant \<equiv>
      vdm_card (the ((plant_schedule plant) peri))"

definition
  ExpertIsOnDuty :: "Expert \<Rightarrow> Plant \<Rightarrow> Period VDMSet"
where
  "ExpertIsOnDuty ex p \<equiv>
      let s = (plant_schedule p) in
        { peri | peri . peri \<in> dom s \<and> ex \<in> (the(s(peri))) }"

lemma "{ x | x . x \<in> {0,1,(2::nat)} \<and> x > 0 } = {1,2}" by auto

(* arguably, we ought also to have pre_dom *)
definition
  pre_ExpertToPage :: "Alarm \<Rightarrow> Period \<Rightarrow> Plant \<Rightarrow> \<bool>"
  where
  "pre_ExpertToPage a peri plant \<equiv>
      inv_Alarm a \<and> inv_Period peri \<and> inv_Plant plant \<and>
      peri \<in> dom (plant_schedule plant) \<and>
      a \<in> (plant_alarms plant)"

definition
  post_ExpertToPage :: "Alarm \<Rightarrow> Period \<Rightarrow> Plant \<Rightarrow> Expert \<Rightarrow> \<bool>"
  where
  "post_ExpertToPage a peri plant RESULT \<equiv>
      pre_ExpertToPage a peri plant \<and> inv_Expert RESULT \<and>
      RESULT \<in> (the ((plant_schedule plant) peri)) \<and>
      (alarm_quali a) \<in> (expert_quali RESULT)"

definition
  PO_ExpertToPage_feas :: \<bool>
  where
  "PO_ExpertToPage_feas \<equiv> \<forall> a peri plant .
      pre_ExpertToPage a peri plant \<longrightarrow> (\<exists> r . post_ExpertToPage a peri plant r)"

theorem PO_ExpertToPage_feas
  unfolding PO_ExpertToPage_feas_def post_ExpertToPage_def
  apply (simp,safe)
  unfolding pre_ExpertToPage_def
  apply (safe, simp)
  apply (subgoal_tac "y={}", simp) oops (* missing set1 in Expert *)

record R =
   x :: int
   y :: int
value "let R=\<lparr> x = 10, y = 20  \<rparr> in R \<lparr> x := 20 \<rparr>"
value "let R=\<lparr> x = 10, y = 20  \<rparr> in \<lparr> x = (x R)+10, y = (y R) \<rparr>"

lemma "[ x \<mapsto> (10::nat) ] = A" oops
lemma "(Map.empty(x \<mapsto> (10::nat)))( x \<mapsto> 20) = A" apply simp oops

definition
	pre_ChangeExpert :: "Plant \<Rightarrow> Expert \<Rightarrow> Expert \<Rightarrow> Period \<Rightarrow> \<bool>"
	where
	"pre_ChangeExpert p ex1 ex2 peri \<equiv>
     inv_Plant p \<and> inv_Expert ex1 \<and> inv_Expert ex2 \<and> inv_Period peri"

definition
	post_ChangeExpert :: "Plant \<Rightarrow> Expert \<Rightarrow> Expert \<Rightarrow> Period \<Rightarrow> Plant \<Rightarrow> \<bool>"
	where
	"post_ChangeExpert p ex1 ex2 peri RESULT \<equiv>
     pre_ChangeExpert p ex1 ex2 peri \<and> inv_Plant RESULT \<and>
     True"

definition
	ChangeExpert :: "Plant \<Rightarrow> Expert \<Rightarrow> Expert \<Rightarrow> Period \<Rightarrow> Plant"
	where
	"ChangeExpert p ex1 ex2 peri \<equiv>
      let plan = (plant_schedule p) in
        p\<lparr> plant_schedule := plan ++ [peri \<mapsto> ((the(plan peri)) - {ex1}) \<union> {ex2}]\<rparr>"

definition
  PO_ChangeExpert_feas :: \<bool>
  where
  "PO_ChangeExpert_feas \<equiv> \<forall> p ex1 ex2 peri .
      pre_ChangeExpert p ex1 ex2 peri  \<longrightarrow>
        (\<exists> r . r = ChangeExpert p ex1 ex2 peri \<and> post_ChangeExpert p ex1 ex2 peri r)"

theorem PO_ChangeExpert_feas
  unfolding PO_ChangeExpert_feas_def post_ChangeExpert_def
  apply (simp, safe)
  unfolding ChangeExpert_def
  apply simp
  unfolding inv_Plant_def Let_def
  apply (simp, safe)
  apply (simp_all)
  oops

end


(*  Author: Andreas Lochbihler, ETH Zurich
    Author: Joshua Schneider, ETH Zurich
*)

subsection \<open>Pointwise arithmetic on infinite binary trees\<close>

theory Cotree_Algebra
imports Cotree
begin

subsubsection \<open>Constants and operators\<close>

instantiation tree :: (zero) zero begin
definition [applicative_unfold]: "0 = pure_tree 0"
instance ..
end

instantiation tree :: (one) one begin
definition [applicative_unfold]: "1 = pure_tree 1"
instance ..
end

instantiation tree :: (plus) plus begin
definition [applicative_unfold]: "plus x y = pure (+) \<diamondop> x \<diamondop> (y :: 'a tree)"
instance ..
end

lemma plus_tree_simps [simp]:
  "root (t + t') = root t + root t'"
  "left (t + t') = left t + left t'"
  "right (t + t') = right t + right t'"
by(simp_all add: plus_tree_def)

friend_of_corec plus where "t + t' = Node (root t + root t') (left t + left t') (right t + right t')"
subgoal by(rule tree.expand; simp)
subgoal by transfer_prover
done

instantiation tree :: (minus) minus begin
definition [applicative_unfold]: "minus x y = pure (-) \<diamondop> x \<diamondop> (y :: 'a tree)"
instance ..
end

lemma minus_tree_simps [simp]:
  "root (t - t') = root t - root t'"
  "left (t - t') = left t - left t'"
  "right (t - t') = right t - right t'"
by(simp_all add: minus_tree_def)

instantiation tree :: (uminus) uminus begin
definition [applicative_unfold tree]: "uminus = ((\<diamondop>) (pure uminus) :: 'a tree \<Rightarrow> 'a tree)"
instance ..
end

instantiation tree :: (times) times begin
definition [applicative_unfold]: "times x y = pure (*) \<diamondop> x \<diamondop> (y :: 'a tree)"
instance ..
end

lemma times_tree_simps [simp]:
  "root (t * t') = root t * root t'"
  "left (t * t') = left t * left t'"
  "right (t * t') = right t * right t'"
by(simp_all add: times_tree_def)

instance tree :: (Rings.dvd) Rings.dvd ..

instantiation tree :: (modulo) modulo begin
definition [applicative_unfold]: "x div y = pure_tree (div) \<diamondop> x \<diamondop> (y :: 'a tree)"
definition [applicative_unfold]: "x mod y = pure_tree (mod) \<diamondop> x \<diamondop> (y :: 'a tree)"
instance ..
end

lemma mod_tree_simps [simp]:
  "root (t mod t') = root t mod root t'"
  "left (t mod t') = left t mod left t'"
  "right (t mod t') = right t mod right t'"
by(simp_all add: modulo_tree_def)

subsubsection \<open>Algebraic instances\<close>

instance tree :: (semigroup_add) semigroup_add
using add.assoc by intro_classes applicative_lifting

instance tree :: (ab_semigroup_add) ab_semigroup_add
using add.commute by intro_classes applicative_lifting

instance tree :: (semigroup_mult) semigroup_mult
using mult.assoc by intro_classes applicative_lifting

instance tree :: (ab_semigroup_mult) ab_semigroup_mult
using mult.commute by intro_classes applicative_lifting

instance tree :: (monoid_add) monoid_add
by intro_classes (applicative_lifting, simp)+

instance tree :: (comm_monoid_add) comm_monoid_add
by intro_classes (applicative_lifting, simp)

instance tree :: (comm_monoid_diff) comm_monoid_diff
by intro_classes (applicative_lifting, simp add: diff_diff_add)+

instance tree :: (monoid_mult) monoid_mult
by intro_classes (applicative_lifting, simp)+

instance tree :: (comm_monoid_mult) comm_monoid_mult
by intro_classes (applicative_lifting, simp)

instance tree :: (cancel_semigroup_add) cancel_semigroup_add
proof
  fix a b c :: "'a tree"
  assume "a + b = a + c"
  thus "b = c"
  proof (coinduction arbitrary: a b c)
    case (Eq_tree a b c)
    hence "root (a + b) = root (a + c)"
          "left (a + b) = left (a + c)"
          "right (a + b) = right (a + c)"
      by simp_all
    thus ?case by (auto)
  qed
next
  fix a b c :: "'a tree"
  assume "b + a = c + a"
  thus "b = c"
  proof (coinduction arbitrary: a b c)
    case (Eq_tree a b c)
    hence "root (b + a) = root (c + a)"
          "left (b + a) = left (c + a)"
          "right (b + a) = right (c + a)"
      by simp_all
    thus ?case by (auto)
  qed
qed

instance tree :: (cancel_ab_semigroup_add) cancel_ab_semigroup_add
by intro_classes (applicative_lifting, simp add: diff_diff_eq)+

instance tree :: (cancel_comm_monoid_add) cancel_comm_monoid_add ..

instance tree :: (group_add) group_add
by intro_classes (applicative_lifting, simp)+

instance tree :: (ab_group_add) ab_group_add
by intro_classes (applicative_lifting, simp)+

instance tree :: (semiring) semiring
by intro_classes (applicative_lifting, simp add: ring_distribs)+

instance tree :: (mult_zero) mult_zero
by intro_classes (applicative_lifting, simp)+

instance tree :: (semiring_0) semiring_0 ..

instance tree :: (semiring_0_cancel) semiring_0_cancel ..

instance tree :: (comm_semiring) comm_semiring
by intro_classes(rule distrib_right)

instance tree :: (comm_semiring_0) comm_semiring_0 ..

instance tree :: (comm_semiring_0_cancel) comm_semiring_0_cancel ..

lemma pure_tree_inject[simp]: "pure_tree x = pure_tree y \<longleftrightarrow> x = y"
proof
  assume "pure_tree x = pure_tree y"
  hence "root (pure_tree x) = root (pure_tree y)" by simp
  thus "x = y" by simp
qed simp

instance tree :: (zero_neq_one) zero_neq_one
by intro_classes (applicative_unfold tree)

instance tree :: (semiring_1) semiring_1 ..

instance tree :: (comm_semiring_1) comm_semiring_1 ..

instance tree :: (semiring_1_cancel) semiring_1_cancel ..

instance tree :: (comm_semiring_1_cancel) comm_semiring_1_cancel
by(intro_classes; applicative_lifting, rule right_diff_distrib')

instance tree :: (ring) ring ..

instance tree :: (comm_ring) comm_ring ..

instance tree :: (ring_1) ring_1 ..

instance tree :: (comm_ring_1) comm_ring_1 ..

instance tree :: (numeral) numeral ..

instance tree :: (neg_numeral) neg_numeral ..

instance tree :: (semiring_numeral) semiring_numeral ..

lemma of_nat_tree: "of_nat n = pure_tree (of_nat n)"
proof (induction n)
  case 0 show ?case by (simp add: zero_tree_def)
next
  case (Suc n)
  have "1 + pure (of_nat n) = pure (1 + of_nat n)" by applicative_nf rule
  with Suc.IH show ?case by simp
qed

instance tree :: (semiring_char_0) semiring_char_0
by intro_classes (simp add: inj_on_def of_nat_tree)

lemma numeral_tree_simps [simp]:
  "root (numeral n) = numeral n"
  "left (numeral n) = numeral n"
  "right (numeral n) = numeral n"
by(induct n)(auto simp add: numeral.simps plus_tree_def one_tree_def)

lemma numeral_tree_conv_pure [applicative_unfold]: "numeral n = pure (numeral n)"
by(rule pure_tree_unique)(rule tree.expand; simp)

instance tree :: (ring_char_0) ring_char_0 ..

end


section \<open>Nested DFS\<close>
theory Nested_DFS
imports DFS_Find_Path
begin
text \<open>Nested DFS is a standard method for Buchi-Automaton emptiness check.\<close>

subsection \<open>Auxiliary Lemmas\<close>

lemma closed_restrict_aux:
  assumes CL: "E``F \<subseteq> F \<union> S"
  assumes NR: "E\<^sup>*``U \<inter> S = {}"
  assumes SS: "U \<subseteq> F"
  shows "E\<^sup>*``U \<subseteq> F"
  \<comment> \<open>Auxiliary lemma to show that nodes reachable from a finished node must
      be finished if, additionally, no stack node is reachable\<close>
proof clarify
  fix u v
  assume A: "(u,v)\<in>E\<^sup>*" "u\<in>U"
  hence M: "E\<^sup>*``{u} \<inter> S = {}" "u\<in>F" using NR SS by blast+

  from A(1) M show "v\<in>F"
    apply (induct rule: converse_rtrancl_induct)
    using CL apply (auto dest: rtrancl_Image_advance_ss)
    done

qed

subsection \<open>Instantiation of the Framework\<close>
record 'v blue_dfs_state = "'v state" +
  lasso :: "('v list \<times> 'v list) option" (* pr \<times> pl *)
  red  :: "'v set"

type_synonym 'v blue_dfs_param = "('v, ('v,unit) blue_dfs_state_ext) parameterization"

lemma lasso_more_cong[cong]:"state.more s = state.more s' \<Longrightarrow> lasso s = lasso s'"
  by (cases s, cases s') simp
lemma red_more_cong[cong]: "state.more s = state.more s' \<Longrightarrow> red s = red s'"
  by (cases s, cases s') simp

abbreviation "dropWhileNot v \<equiv> dropWhile ((\<noteq>) v)"
abbreviation "takeWhileNot v \<equiv> takeWhile ((\<noteq>) v)"

locale BlueDFS_defs = graph_defs G
  for G :: "('v, 'more) graph_rec_scheme"  +
  fixes accpt :: "'v \<Rightarrow> bool"
begin

  definition "blue s \<equiv> dom (finished s) - red s"
  definition "cyan s \<equiv> set (stack s)"
  definition "white s \<equiv> - dom (discovered s)"

  abbreviation "red_dfs R ss x \<equiv> find_path1_restr_spec (G \<lparr> g_V0 := {x} \<rparr>) ss R"

  definition mk_blue_witness
    :: "'v blue_dfs_state \<Rightarrow> 'v fpr_result \<Rightarrow> ('v,unit) blue_dfs_state_ext"
    where
    "mk_blue_witness s redS \<equiv> case redS of
                 Inl R' \<Rightarrow> \<lparr> lasso = None, red = (R' \<^cancel>\<open>\<union> red s\<close>) \<rparr>
               | Inr (vs, v) \<Rightarrow> let rs = rev (stack s) in
                             \<lparr> lasso = Some (rs, vs@dropWhileNot v rs), red = red s\<rparr>"

  definition run_red_dfs
    :: "'v \<Rightarrow> 'v blue_dfs_state \<Rightarrow> ('v,unit) blue_dfs_state_ext nres"
    where
    "run_red_dfs u s \<equiv> case lasso s of None \<Rightarrow> do {
             redS \<leftarrow> red_dfs (red s) (\<lambda>x. x = u \<or> x \<in> cyan s) u;
             RETURN (mk_blue_witness s redS)
           }
          | _ \<Rightarrow> NOOP s"

  text \<open> Schwoon-Esparza extension \<close>
  definition "se_back_edge u v s \<equiv> case lasso s of
    None \<Rightarrow>
      \<comment> \<open>it's a back edge, so \<open>u\<close> and \<open>v\<close> are both on stack\<close>
      \<comment> \<open>we differentiate whether \<open>u\<close> or \<open>v\<close> is the 'culprit'\<close>
      \<comment> \<open>to generate a better counter example\<close>
      if accpt u then
         let rs = rev (tl (stack s));
             ur = rs;
             ul = u#dropWhileNot v rs
         in RETURN \<lparr>lasso = Some (ur,ul), red = red s\<rparr>
      else if accpt v then
         let rs = rev (stack s);
             vr = takeWhileNot v rs;
             vl = dropWhileNot v rs
         in RETURN \<lparr>lasso = Some (vr,vl), red = red s\<rparr>
      else NOOP s
  | _ \<Rightarrow> NOOP s"

  definition blue_dfs_params :: "'v blue_dfs_param"
    where "blue_dfs_params = \<lparr>
    on_init = RETURN \<lparr> lasso = None, red = {} \<rparr>,
    on_new_root = \<lambda>v0 s. NOOP s,
    on_discover = \<lambda>u v s. NOOP s,
    on_finish = \<lambda>u s. if accpt u then run_red_dfs u s else NOOP s,
    on_back_edge = se_back_edge,
    on_cross_edge = \<lambda>u v s. NOOP s,
    is_break = \<lambda>s. lasso s \<noteq> None \<rparr>"

  schematic_goal blue_dfs_params_simps[simp]:
    "on_init blue_dfs_params = ?OI"
    "on_new_root blue_dfs_params = ?ONR"
    "on_discover blue_dfs_params = ?OD"
    "on_finish blue_dfs_params = ?OF"
    "on_back_edge blue_dfs_params = ?OBE"
    "on_cross_edge blue_dfs_params = ?OCE"
    "is_break blue_dfs_params = ?IB"
    unfolding blue_dfs_params_def gen_parameterization.simps
    by (rule refl)+

  sublocale param_DFS_defs G blue_dfs_params
    by unfold_locales

end

locale BlueDFS = BlueDFS_defs G accpt + param_DFS G blue_dfs_params
  for G :: "('v, 'more) graph_rec_scheme" and accpt :: "'v \<Rightarrow> bool"

lemma BlueDFSI:
  assumes "fb_graph G"
  shows "BlueDFS G"
proof -
  interpret fb_graph G by fact
  show ?thesis by unfold_locales
qed

locale BlueDFS_invar = BlueDFS +
  DFS_invar where param = blue_dfs_params

context BlueDFS_defs begin

lemma BlueDFS_invar_eq[simp]:
  shows "DFS_invar G blue_dfs_params s \<longleftrightarrow> BlueDFS_invar G accpt s"
proof
  assume "DFS_invar G blue_dfs_params s"
  interpret DFS_invar G blue_dfs_params s by fact
  show "BlueDFS_invar G accpt s" by unfold_locales
next
  assume "BlueDFS_invar G accpt s"
  then interpret BlueDFS_invar G accpt s .
  show "DFS_invar G blue_dfs_params s" by unfold_locales
qed

end

subsection \<open>Correctness Proof\<close>
context BlueDFS begin

  definition "blue_basic_invar s \<equiv>
    case lasso s of
      None \<Rightarrow> restr_invar E (red s) (\<lambda>x. x\<in>set (stack s))
        \<and> red s \<subseteq> dom (finished s)
    | Some l \<Rightarrow> True"

  lemma (in BlueDFS_invar) red_DFS_precond_aux:
    assumes BI: "blue_basic_invar s"
    assumes [simp]: "lasso s = None"
    assumes SNE: "stack s \<noteq> []"
    shows
      "fb_graph (G \<lparr> g_V0 := {hd (stack s)} \<rparr>)"
    and "fb_graph (G \<lparr> g_E := E \<inter> UNIV \<times> - red s, g_V0 := {hd (stack s)} \<rparr>)"
    and "restr_invar E (red s) (\<lambda>x. x \<in> set (stack s))"
    using stack_reachable \<open>stack s \<noteq> []\<close>
    apply (rule_tac fb_graph_subset, auto) []
    using stack_reachable \<open>stack s \<noteq> []\<close>
    apply (rule_tac fb_graph_subset, auto) []

    using BI apply (simp add: blue_basic_invar_def)
    done

  lemma (in BlueDFS_invar) red_dfs_pres_bbi:
    assumes BI: "blue_basic_invar s"
    assumes [simp]: "lasso s = None" and SNE: "stack s \<noteq> []"
    assumes "pending s `` {hd (stack s)} = {}"
    shows "run_red_dfs (hd (stack s)) (finish (hd (stack s)) s) \<le>\<^sub>n
      SPEC (\<lambda>e.
        DFS_invar G blue_dfs_params (finish (hd (stack s)) s\<lparr>state.more := e\<rparr>)
        \<longrightarrow> blue_basic_invar (finish (hd (stack s)) s\<lparr>state.more := e\<rparr>))"
  proof -
    have [simp]: "(\<lambda>x. x = hd (stack s) \<or> x \<in> cyan (finish (hd (stack s)) s)) =
      (\<lambda>x. x\<in>set (stack s))"
      using \<open>stack s \<noteq> []\<close>
      unfolding finish_def cyan_def by (auto simp: neq_Nil_conv)

    show ?thesis
      unfolding run_red_dfs_def
      apply simp
      apply (refine_vcg)
      apply simp
    proof -
      fix fp1
      define s' where "s' = finish (hd (stack s)) s"
      assume FP_spec:
        "find_path1_restr_pred (G \<lparr> g_V0 := {hd (stack s)} \<rparr>) (\<lambda>x. x \<in> set (stack s)) (red s) fp1"
      assume "BlueDFS_invar G accpt (s'\<lparr>state.more := mk_blue_witness s' fp1\<rparr>)"
      then interpret i: BlueDFS_invar G accpt "(s'\<lparr>state.more := mk_blue_witness s' fp1\<rparr>)"
        by simp

      have [simp]:
        "red s' = red s"
        "discovered s' = discovered s"
        "dom (finished s') = insert (hd (stack s)) (dom (finished s))"
        unfolding s'_def finish_def by auto

      {
        fix R'
        assume [simp]: "fp1 = Inl R'"
        from FP_spec[unfolded find_path1_restr_pred_def, simplified]
        have
          R'FMT: "R' = red s \<union> E\<^sup>+ `` {hd (stack s)}"
          and RI: "restr_invar E R' (\<lambda>x. x \<in> set (stack s))"
          by auto

        from BI have "red s \<subseteq> dom (finished s)"
          unfolding blue_basic_invar_def by auto
        also have "E\<^sup>+ `` {hd (stack s)} \<subseteq> dom (finished s)"
        proof (intro subsetI, elim ImageE, simp)
          fix v
          assume "(hd (stack s),v)\<in>E\<^sup>+"

          then obtain u where "(hd (stack s),u)\<in>E" and "(u,v)\<in>E\<^sup>*"
            by (auto simp: trancl_unfold_left)

          from RI have NR: "E\<^sup>+ `` {hd (stack s)} \<inter> set (stack s) = {}"
            unfolding restr_invar_def by (auto simp: R'FMT)

          with \<open>(hd (stack s),u)\<in>E\<close> have "u\<notin>set (stack s)" by auto
          with i.finished_closed[simplified] \<open>(hd (stack s),u)\<in>E\<close>
          have UID: "u\<in>dom (finished s)" by (auto simp: stack_set_def)

          from NR \<open>(hd (stack s),u)\<in>E\<close> have NR': "E\<^sup>*``{u} \<inter> set (stack s) = {}"
            by (auto simp: trancl_unfold_left)

          have CL: "E `` dom (finished s) \<subseteq> dom (finished s) \<union> set (stack s)"
            using finished_closed discovered_eq_finished_un_stack
            by simp

          from closed_restrict_aux[OF CL NR'] UID
          have "E\<^sup>* `` {u} \<subseteq> dom (finished s)" by simp
          with \<open>(u,v)\<in>E\<^sup>*\<close>  show "v \<in> dom (finished s)" by auto
        qed
        finally (sup_least)
        have "R' \<subseteq> dom (finished s) \<and> red s \<subseteq> dom (finished s)"
          by (simp add: R'FMT)
      } note aux1 = this

      show "blue_basic_invar (s'\<lparr>state.more := mk_blue_witness s' fp1\<rparr>)"
        unfolding blue_basic_invar_def mk_blue_witness_def
        apply (simp split: option.splits sum.splits)
        apply (intro allI conjI impI)

        using FP_spec SNE
        apply (auto
          simp: s'_def blue_basic_invar_def find_path1_restr_pred_def
          simp: restr_invar_def
          simp: neq_Nil_conv) []

        apply (auto dest!: aux1) []
        done
    qed
  qed

  lemma blue_basic_invar: "is_invar blue_basic_invar"
  proof (induct rule: establish_invarI)
    case (finish s) then interpret BlueDFS_invar where s=s by simp

    have [simp]: "(\<lambda>x. x = hd (stack s) \<or> x \<in> cyan (finish (hd (stack s)) s)) =
      (\<lambda>x. x\<in>set (stack s))"
      using \<open>stack s \<noteq> []\<close>
      unfolding finish_def cyan_def by (auto simp: neq_Nil_conv)

    from finish show ?case
      apply (simp)
      apply (intro conjI impI)
      apply (rule leof_trans[OF red_dfs_pres_bbi], assumption+, simp)

      apply (auto simp: restr_invar_def blue_basic_invar_def neq_Nil_conv) []
      done
  qed (auto simp: blue_basic_invar_def cond_def se_back_edge_def
            simp: restr_invar_def empty_state_def pred_defs
            simp: DFS_invar.discovered_eq_finished_un_stack
            simp del: BlueDFS_invar_eq
            split: option.splits)

  lemmas (in BlueDFS_invar) s_blue_basic_invar
    = blue_basic_invar[THEN make_invar_thm]

  lemmas (in BlueDFS_invar) red_DFS_precond
    = red_DFS_precond_aux[OF s_blue_basic_invar]

  sublocale DFS G blue_dfs_params
    apply unfold_locales

    apply (clarsimp_all
      simp:  se_back_edge_def run_red_dfs_def refine_pw_simps pre_on_defs
      split: option.splits)

    unfolding nofail_SPEC_iff
    apply (refine_vcg)
      apply (erule BlueDFS_invar.red_DFS_precond, auto) []

      apply (simp add: cyan_def finish_def)
      apply (erule BlueDFS_invar.red_DFS_precond, auto) []

      apply (rule TrueI)
    done

end

context BlueDFS_invar
begin

  context assumes [simp]: "lasso s = None"
  begin
    lemma red_closed:
      "E `` red s \<subseteq> red s"
      using s_blue_basic_invar
      unfolding blue_basic_invar_def restr_invar_def
      by simp

    lemma red_stack_disjoint:
      "set (stack s) \<inter> red s = {}"
      using s_blue_basic_invar
      unfolding blue_basic_invar_def restr_invar_def
      by auto

    lemma red_finished: "red s \<subseteq> dom (finished s)"
      using s_blue_basic_invar
      unfolding blue_basic_invar_def
      by auto

    (* Play of Colors *)
    lemma all_nodes_colored: "white s \<union> blue s \<union> cyan s \<union> red s = UNIV "
      unfolding white_def blue_def cyan_def
      by (auto simp: stack_set_def)

    lemma colors_disjoint:
      "white s \<inter> (blue s \<union> cyan s \<union> red s) = {}"
      "blue s \<inter> (white s \<union> cyan s \<union> red s) = {}"
      "cyan s \<inter> (white s \<union> blue s \<union> red s) = {}"
      "red s \<inter> (white s \<union> blue s \<union> cyan s) = {}"
      unfolding white_def blue_def cyan_def
      using finished_discovered red_finished
      unfolding stack_set_def
      by blast+

  end

  lemma (in BlueDFS) i_no_accpt_cyle_in_finish:
    "is_invar (\<lambda>s. lasso s = None \<longrightarrow> (\<forall>x. accpt x \<and> x \<in> dom (finished s) \<longrightarrow> (x,x) \<notin> E\<^sup>+))"
  proof (induct rule: establish_invarI)
    case (finish s s' u) then interpret BlueDFS_invar where s=s by simp

    let ?onstack = "\<lambda>x. x\<in>set (stack s)"
    let ?rE = "rel_restrict E (red s)"

    from finish obtain sh st where [simp]: "stack s = sh#st"
      by (auto simp: neq_Nil_conv)

    have 1: "g_E (G \<lparr> g_V0 := {hd (stack s)} \<rparr>) = E" by simp

    { (* TODO/FIXME: Ughly proof structure! *)
      fix R'::"'v set"
      let ?R' = "R' \<^cancel>\<open>\<union> red s\<close>"
      let ?s = "s'\<lparr> lasso := None, red := ?R'\<rparr>"

      assume "\<And>v. (hd (stack s), v) \<in> ?rE\<^sup>+ \<Longrightarrow> \<not> ?onstack v"
      and accpt: "accpt u"
      and NL[simp]: "lasso s = None"
      hence no_hd_cycle: "(hd (stack s), hd (stack s)) \<notin> ?rE\<^sup>+"
        by auto

      from finish have "stack s \<noteq> []" by simp
      from hd_in_set[OF this] have "hd (stack s) \<notin> red s"
        using red_stack_disjoint
        by auto
      hence "(hd (stack s),hd (stack s)) \<notin> E\<^sup>+"
        using no_hd_cycle rel_restrict_tranclI red_closed[OF NL]
        by metis
      with accpt finish have
        "\<forall>x. accpt x \<and> x \<in> dom (finished ?s) \<longrightarrow> (x,x) \<notin> E\<^sup>+"
        by auto
    } with finish have
      "red_dfs (red s) ?onstack (hd (stack s))
         \<le> SPEC (\<lambda>x. \<forall>R. x = Inl R \<longrightarrow>
             DFS_invar G blue_dfs_params (lasso_update Map.empty s'\<lparr>red := R \<^cancel>\<open>\<union> red s\<close>\<rparr>) \<longrightarrow>
             (\<forall>x. accpt x \<and> x\<in>dom (finished s') \<longrightarrow> (x, x) \<notin> E\<^sup>+))"
      apply -
      apply (rule find_path1_restr_spec_rule, intro conjI)

      apply (rule red_DFS_precond, simp_all) []
      unfolding 1
      apply (rule red_DFS_precond, simp_all) []

      apply (auto simp: find_path1_restr_pred_def restr_invar_def)
      done
    note aux = leof_trans[OF this[simplified,THEN leof_lift]]

    note [refine_vcg del] = find_path1_restr_spec_rule

    from finish show ?case
      apply simp
      apply (intro conjI impI)
        unfolding run_red_dfs_def mk_blue_witness_def cyan_def
        apply clarsimp
        apply (refine_vcg aux)
        apply (auto split: sum.splits)
      done
  next
    case back_edge thus ?case
      by (simp add: se_back_edge_def split: option.split)
  qed simp_all

  lemma no_accpt_cycle_in_finish:
    "\<lbrakk>lasso s = None; accpt v; v \<in> dom (finished s)\<rbrakk> \<Longrightarrow> (v,v) \<notin> E\<^sup>+"
    using i_no_accpt_cyle_in_finish[THEN make_invar_thm]
    by blast

end

context BlueDFS
begin
  definition lasso_inv where
    "lasso_inv s \<equiv> \<forall>pr pl. lasso s = Some (pr,pl) \<longrightarrow>
                                      pl \<noteq> []
                                    \<and> (\<exists>v0\<in>V0. path E v0 pr (hd pl))
                                    \<and> accpt (hd pl)
                                    \<and> path E (hd pl) pl (hd pl)"

  lemma (in BlueDFS_invar) se_back_edge_lasso_inv:
    assumes b_inv: "lasso_inv s"
    and ne: "stack s \<noteq> []"
    and R: "lasso s = None"
    and p:"(hd (stack s), v) \<in> pending s"
    and v: "v \<in> dom (discovered s)" "v \<notin> dom (finished s)"
    and s': "s' = back_edge (hd (stack s)) v (s\<lparr>pending := pending s - {(u,v)}\<rparr>)"
    shows "se_back_edge (hd (stack s)) v s'
                \<le> SPEC (\<lambda>e. DFS_invar G blue_dfs_params (s'\<lparr>state.more := e\<rparr>) \<longrightarrow>
                            lasso_inv (s'\<lparr>state.more := e\<rparr>))"
  proof -

    from v stack_set_def have v_in: "v \<in> set (stack s)" by simp
    from p have uv_edg: "(hd (stack s), v) \<in> E" by (auto dest: pendingD)

    {
      assume accpt: "accpt (hd (stack s))"
      let ?ur = "rev (tl (stack s))"
      let ?ul = "hd (stack s)#dropWhileNot v (rev (tl (stack s)))"
      let ?s = "s'\<lparr>lasso := Some (?ur, ?ul), red := red s\<rparr>"

      assume "DFS_invar G blue_dfs_params ?s"

      have [simp]: "stack ?s = stack s"
        by (simp add: s')

      have hd_ul[simp]: "hd ?ul = hd (stack s)" by simp

      have "?ul \<noteq> []" by simp

      moreover have P:"\<exists>v0\<in>V0. path E v0 ?ur (hd ?ul)"
        using stack_is_path[OF ne]
        by auto
      moreover
      from accpt have "accpt (hd ?ul)" by simp

      moreover have "path E (hd ?ul) ?ul (hd ?ul)"
      proof (cases "v = hd (stack s)")
        case True
        with distinct_hd_tl stack_distinct have ul: "?ul = [hd (stack s)]"
          by force
        from True uv_edg show ?thesis
          by (subst ul)+ (simp add: path1)
      next
        case False with v_in ne have "v \<in> set ?ur"
          by (auto simp add: neq_Nil_conv)
        with P show ?thesis
          by (fastforce intro: path_prepend
                           dropWhileNot_path[where p="?ur"]
                           uv_edg)
      qed

      ultimately have "lasso_inv ?s" by (simp add: lasso_inv_def)
    }

    moreover
    {
      assume accpt: "accpt v"
      let ?vr = "takeWhileNot v (rev (stack s))"
      let ?vl = "dropWhileNot v (rev (stack s))"
      let ?s = "s'\<lparr>lasso := Some(?vr, ?vl), red := red s\<rparr>"

      assume "DFS_invar G blue_dfs_params ?s"

      have [simp]: "stack ?s = stack s"
        by (simp add: s')

      from ne v_in have hd_vl[simp]: "hd ?vl = v"
        by (induct ("stack s") rule: rev_nonempty_induct) auto

      from v_in have "?vl \<noteq> []" by simp

      moreover from hd_succ_stack_is_path[OF ne] uv_edg have
        P: "\<exists>v0\<in>V0. path E v0 (rev (stack s)) v"
        by auto
      with ne v_in have "\<exists>v0\<in>V0. path E v0 ?vr (hd ?vl)"
        by (force intro: takeWhileNot_path)

      moreover from accpt have "accpt (hd ?vl)" by simp

      moreover from P ne v_in have "path E (hd ?vl) ?vl (hd ?vl)"
        by (force intro: dropWhileNot_path)

      ultimately have "lasso_inv ?s" by (simp add: lasso_inv_def)
    }

    moreover
    {
      assume "\<not> accpt (hd (stack s))" "\<not> accpt v"
      let ?s = "s'\<lparr>state.more := state.more s'\<rparr>"

      assume "DFS_invar G blue_dfs_params ?s"

      from assms have "lasso_inv ?s"
        by (auto simp add: lasso_inv_def)
    }

    (* TODO: Clean up this proof, separate logical arguments from framework
      boilerplate! *)
    ultimately show ?thesis
      using R s'
      unfolding se_back_edge_def
      by (auto split: option.splits)
  qed

  lemma lasso_inv:
    "is_invar lasso_inv"
  proof (induct rule: establish_invarI)
    case (finish s s' u) then interpret BlueDFS_invar where s=s by simp
    (* TODO/FIXME: Ughly proof structure *)
    let ?onstack = "\<lambda>x. x \<in> set (stack s)"
    let ?rE = "rel_restrict E (red s)"
    let ?revs = "rev (tl (stack s))"

    note ne = \<open>stack s \<noteq> []\<close>

    note [simp] = \<open>u=hd (stack s)\<close>

    from finish have [simp]:
      "\<And>x. x = hd (stack s) \<or> x \<in> set (stack s') \<longleftrightarrow> x\<in>set (stack s)"
      "red s' = red s"
      "lasso s' = lasso s"
      by (auto simp: neq_Nil_conv)

    {
      fix v vs
      let ?cyc = "vs @ dropWhileNot v ?revs"
      let ?s = "s'\<lparr>lasso := Some (?revs, ?cyc), red := red s\<rparr>"

      assume "DFS_invar G blue_dfs_params ?s"
        and vs: "vs \<noteq> []" "path ?rE (hd (stack s)) vs v"
        and v: "?onstack v"
        and accpt: "accpt (hd (stack s))"
      from vs have P: "path E (hd (stack s)) vs v"
        by (metis path_mono rel_restrict_sub)

      have hds[simp]: "hd vs = hd (stack s)" "hd ?cyc = hd (stack s)"
        using vs path_hd
        by simp_all

      from vs have "?cyc \<noteq> []" by simp

      moreover have P0: "\<exists>v0\<in>V0. path E v0 ?revs (hd ?cyc)"
        using stack_is_path[OF ne]
        by auto

      moreover from accpt have "accpt (hd ?cyc)" by simp

      moreover have "path E (hd ?cyc) ?cyc (hd ?cyc)"
      proof (cases "tl (stack s) = []")
        case True with ne last_stack_in_V0 obtain v0 where "v0 \<in> V0"
          and [simp]: "stack s = [v0]"
          by (auto simp: neq_Nil_conv)
        with v True finish have [simp]: "v = v0" by simp

        from True P show ?thesis by simp
      next
        case False note tl_ne = this

        show ?thesis
        proof (cases "v = hd (stack s)")
          case True hence "v \<notin> set ?revs"
            using ne stack_distinct by (auto simp: neq_Nil_conv)
          hence "?cyc = vs" by fastforce
          with P True show ?thesis by (simp del: dropWhile_eq_Nil_conv)
        next
          case False with finish v have "v \<in> set ?revs"
            by (auto simp: neq_Nil_conv)
          with tl_ne False P0  show ?thesis
            by (force intro: path_conc[OF P]
                dropWhileNot_path[where p="?revs"])
        qed
      qed

      ultimately have "lasso_inv ?s" by (simp add: lasso_inv_def)
    }
    hence "accpt (hd (stack s)) \<longrightarrow> lasso s = None \<longrightarrow>
            red_dfs (red s) ?onstack (hd (stack s)) \<le> SPEC (\<lambda>rs. \<forall>vs v.
                rs = Inr (vs,v) \<longrightarrow>
                  DFS_invar G blue_dfs_params (s'\<lparr>lasso := Some (?revs, vs @ dropWhileNot v ?revs), red:= red s\<rparr>) \<longrightarrow>
                   lasso_inv (s'\<lparr>lasso := Some (?revs, vs @ dropWhileNot v ?revs), red:=red s\<rparr>))"
      apply clarsimp
      apply (rule find_path1_restr_spec_rule, intro conjI)
      apply (rule red_DFS_precond, simp_all add: ne) []
      apply (simp, rule red_DFS_precond, simp_all add: ne) []

      using red_stack_disjoint ne

      apply clarsimp
      apply rprems
      apply (simp_all add: find_path1_restr_pred_def restr_invar_def)
      apply (fastforce intro: path_restrict_tl rel_restrictI)
      done
    note aux1 = this[rule_format,THEN leof_lift]

    show ?case
      apply simp
      unfolding run_red_dfs_def mk_blue_witness_def cyan_def

      apply (simp
        add: run_red_dfs_def mk_blue_witness_def cyan_def
        split: option.splits)
      apply (intro conjI impI)
      apply (refine_vcg leof_trans[OF aux1])
      using finish
      apply (auto simp add: lasso_inv_def split: sum.split)
      done
  next
    case (back_edge s s' u v) then interpret BlueDFS_invar where s=s by simp

    from back_edge se_back_edge_lasso_inv[THEN leof_lift] show ?case
      by auto
  qed (simp_all add: lasso_inv_def empty_state_def)
end

context BlueDFS_invar
begin
  lemmas s_lasso_inv = lasso_inv[THEN make_invar_thm]

  lemma
    assumes "lasso s = Some (pr,pl)"
    shows loop_nonempty: "pl \<noteq> []"
    and accpt_loop: "accpt (hd pl)"
    and loop_is_path: "path E (hd pl) pl (hd pl)"
    and loop_reachable: "\<exists>v0\<in>V0. path E v0 pr (hd pl)"
    using assms s_lasso_inv
    by (simp_all add: lasso_inv_def)

  lemma blue_dfs_correct:
    assumes NC: "\<not> cond s"
    shows "case lasso s of
      None \<Rightarrow> \<not>(\<exists>v0\<in>V0. \<exists>v. (v0,v) \<in> E\<^sup>* \<and> accpt v \<and> (v,v) \<in> E\<^sup>+)
    | Some (pr,pl) \<Rightarrow> (\<exists>v0\<in>V0. \<exists>v.
        path E v0 pr v \<and> accpt v \<and> pl\<noteq>[] \<and> path E v pl v)"
  proof (cases "lasso s")
    case None
    moreover
    {
      fix v v0
      assume "v0 \<in> V0" "(v0,v) \<in> E\<^sup>*" "accpt v" "(v,v) \<in> E\<^sup>+"
      moreover
      hence "v \<in> reachable" by (auto)
      with nc_finished_eq_reachable NC None have "v \<in> dom (finished s)"
        by simp
      moreover note no_accpt_cycle_in_finish None
      ultimately have False by blast
    }
    ultimately show ?thesis by auto
  next
    case (Some prpl) with s_lasso_inv show ?thesis
      by (cases prpl)
         (auto intro: path_is_rtrancl path_is_trancl simp: lasso_inv_def)
  qed

end

subsection \<open>Interface\<close>

interpretation BlueDFS_defs for G accpt .

definition "nested_dfs_spec G accpt \<equiv> \<lambda>r. case r of
  None \<Rightarrow> \<not>(\<exists>v0\<in>g_V0 G. \<exists>v. (v0,v) \<in> (g_E G)\<^sup>* \<and> accpt v \<and> (v,v) \<in> (g_E G)\<^sup>+)
| Some (pr,pl) \<Rightarrow> (\<exists>v0\<in>g_V0 G. \<exists>v.
    path (g_E G) v0 pr v \<and> accpt v \<and> pl\<noteq>[] \<and> path (g_E G) v pl v)"

definition "nested_dfs G accpt \<equiv> do {
  ASSERT (fb_graph G);
  s \<leftarrow> it_dfs TYPE('a) G accpt;
  RETURN (lasso s)
}"

theorem nested_dfs_correct:
  assumes "fb_graph G"
  shows "nested_dfs G accpt \<le> SPEC (nested_dfs_spec G accpt)"
proof -
  interpret fb_graph G by fact
  interpret BlueDFS G accpt by unfold_locales

  show ?thesis
    unfolding nested_dfs_def
    apply (refine_rcg refine_vcg)
    apply fact
    apply (rule weaken_SPEC[OF it_dfs_correct])
    apply clarsimp
  proof -
    fix s
    assume "BlueDFS_invar G accpt s"
    then interpret BlueDFS_invar G accpt s .

    assume "\<not>cond TYPE('b) G accpt s"
    from blue_dfs_correct[OF this] show "nested_dfs_spec G accpt (lasso s)"
      unfolding nested_dfs_spec_def by simp
  qed
qed

subsection \<open>Implementation\<close>

record 'v bdfs_state_impl = "'v simple_state" +
  lasso_impl :: "('v list \<times> 'v list) option"
  red_impl :: "'v set"

definition "bdfs_erel \<equiv> {(\<lparr>lasso_impl=li,red_impl=ri\<rparr>,\<lparr>lasso=l, red=r\<rparr>)
  | li ri l r. li=l \<and> ri=r}"

abbreviation "bdfs_rel \<equiv> \<langle>bdfs_erel\<rangle>simple_state_rel"

definition mk_blue_witness_impl
  :: "'v bdfs_state_impl \<Rightarrow> 'v fpr_result \<Rightarrow> ('v,unit) bdfs_state_impl_ext"
  where
  "mk_blue_witness_impl s redS \<equiv>
    case redS of
      Inl R' \<Rightarrow> \<lparr> lasso_impl = None, red_impl = (R' \<^cancel>\<open>\<union> red_impl s\<close>) \<rparr>
    | Inr (vs, v) \<Rightarrow> let
        rs = rev (map fst (CAST (ss_stack s)))
      in \<lparr>
        lasso_impl = Some (rs, vs@dropWhileNot v rs),
        red_impl = red_impl s\<rparr>"

lemma mk_blue_witness_impl[refine]:
  "\<lbrakk> (si,s)\<in>bdfs_rel; (ri,r)\<in>\<langle>Id, \<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>sum_rel \<rbrakk>
  \<Longrightarrow> (mk_blue_witness_impl si ri, mk_blue_witness s r)\<in>bdfs_erel"
  unfolding mk_blue_witness_impl_def mk_blue_witness_def
  apply parametricity
  apply (cases si, cases s)
  apply (auto simp: bdfs_erel_def simple_state_rel_def) []
  apply (rule introR[where R="\<langle>Id\<rangle>list_rel"])
  apply (cases si, cases s)
  apply (auto simp: bdfs_erel_def simple_state_rel_def comp_def) []
  apply (cases si, cases s)
  apply (auto simp: bdfs_erel_def simple_state_rel_def) []
  done

definition "cyan_impl s \<equiv> on_stack s"
lemma cyan_impl[refine]: "\<lbrakk>(si,s)\<in>bdfs_rel\<rbrakk> \<Longrightarrow> (cyan_impl si, cyan s)\<in>Id"
  unfolding cyan_impl_def cyan_def
  by (auto simp: bdfs_erel_def simple_state_rel_def)

definition run_red_dfs_impl
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> 'v \<Rightarrow> 'v bdfs_state_impl \<Rightarrow> ('v,unit) bdfs_state_impl_ext nres"
  where
  "run_red_dfs_impl G u s \<equiv> case lasso_impl s of None \<Rightarrow> do {
           redS \<leftarrow> red_dfs TYPE('more) G (red_impl s) (\<lambda>x. x = u \<or> x \<in> cyan_impl s) u;
           RETURN (mk_blue_witness_impl s redS)
         }
        | _ \<Rightarrow> RETURN (simple_state.more s)"

  lemma run_red_dfs_impl[refine]: "\<lbrakk>(Gi,G)\<in>Id; (ui,u)\<in>Id; (si,s)\<in>bdfs_rel\<rbrakk>
    \<Longrightarrow> run_red_dfs_impl Gi ui si \<le>\<Down>bdfs_erel (run_red_dfs TYPE('a) G u s)"
    unfolding run_red_dfs_impl_def run_red_dfs_def
    apply refine_rcg
    apply refine_dref_type
    apply (cases si, cases s, auto simp: bdfs_erel_def simple_state_rel_def) []
    apply (cases si, cases s,
      auto simp: bdfs_erel_def simple_state_rel_def cyan_impl_def cyan_def) []
    apply (auto simp: bdfs_erel_def simple_state_rel_def) [2]
    done

  definition "se_back_edge_impl accpt u v s \<equiv> case lasso_impl s of
    None \<Rightarrow>
      if accpt u then
         let rs = rev (map fst (tl (CAST (ss_stack s))));
             ur = rs;
             ul = u#dropWhileNot v rs
         in RETURN \<lparr>lasso_impl = Some (ur,ul), red_impl = red_impl s\<rparr>
      else if accpt v then
         let rs = rev (map fst (CAST (ss_stack s)));
             vr = takeWhileNot v rs;
             vl = dropWhileNot v rs
         in RETURN \<lparr>lasso_impl = Some (vr,vl), red_impl = red_impl s\<rparr>
      else RETURN (simple_state.more s)
  | _ \<Rightarrow> RETURN (simple_state.more s)"

  lemma se_back_edge_impl[refine]: "\<lbrakk> (accpti,accpt)\<in>Id; (ui,u)\<in>Id; (vi,v)\<in>Id; (si,s)\<in>bdfs_rel \<rbrakk>
    \<Longrightarrow> se_back_edge_impl accpt ui vi si \<le>\<Down>bdfs_erel (se_back_edge accpt u v s)"
    unfolding se_back_edge_impl_def se_back_edge_def
    apply refine_rcg
    apply refine_dref_type
    apply simp_all
    apply (simp_all add: bdfs_erel_def simple_state_rel_def)
    apply (cases si, cases s, (auto) [])
    apply (cases si, cases s, (auto simp: map_tl comp_def) [])
    apply (cases si, cases s, (auto simp: comp_def) [])
    done

  lemma NOOP_impl: "(si, s) \<in> bdfs_rel
    \<Longrightarrow> RETURN (simple_state.more si) \<le> \<Down> bdfs_erel (NOOP s)"
    apply (simp add: pw_le_iff refine_pw_simps)
    apply (auto simp: simple_state_rel_def)
    done

  definition bdfs_params_impl
    :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> ('v,'v bdfs_state_impl,('v,unit)bdfs_state_impl_ext) gen_parameterization"
  where "bdfs_params_impl G accpt \<equiv> \<lparr>
    on_init = RETURN \<lparr>lasso_impl = None, red_impl = {}\<rparr>,
    on_new_root = \<lambda>v0 s. RETURN (simple_state.more s),
    on_discover = \<lambda>u v s. RETURN (simple_state.more s),
    on_finish = \<lambda>u s.
      if accpt u then run_red_dfs_impl G u s else RETURN (simple_state.more s),
    on_back_edge = se_back_edge_impl accpt,
    on_cross_edge = \<lambda>u v s. RETURN (simple_state.more s),
    is_break = \<lambda>s. lasso_impl s \<noteq> None \<rparr>"

  lemmas bdfs_params_impl_simps[simp, DFS_code_unfold] =
    gen_parameterization.simps[mk_record_simp, OF bdfs_params_impl_def]

  interpretation impl: simple_impl_defs G "bdfs_params_impl G accpt" "blue_dfs_params TYPE('a) G accpt"
    for G accpt .

context BlueDFS begin

  sublocale impl: simple_impl G blue_dfs_params "bdfs_params_impl G accpt" bdfs_erel
    apply unfold_locales

    apply (simp_all
      add: bdfs_params_impl_def run_red_dfs_impl se_back_edge_impl NOOP_impl)
    apply parametricity
    apply (clarsimp_all simp: pw_le_iff refine_pw_simps bdfs_erel_def simple_state_rel_def)
    apply (rename_tac si s x y, case_tac si, case_tac s)
    apply (auto simp add: bdfs_erel_def simple_state_rel_def) []
    done

  lemmas impl = impl.simple_tailrec_refine
end

definition "nested_dfs_impl G accpt \<equiv> do {
  ASSERT (fb_graph G);
  s \<leftarrow> impl.tailrec_impl TYPE('a) G accpt;
  RETURN (lasso_impl s)
}"

lemma nested_dfs_impl[refine]:
  assumes "(Gi,G)\<in>Id"
  assumes "(accpti,accpt)\<in>Id"
  shows "nested_dfs_impl Gi accpti \<le>\<Down>(\<langle>\<langle>Id\<rangle>list_rel \<times>\<^sub>r \<langle>Id\<rangle>list_rel\<rangle>option_rel)
    (nested_dfs G accpt)"
  using assms
  unfolding nested_dfs_impl_def nested_dfs_def
  apply refine_rcg
  apply simp_all
  apply (rule intro_prgR[where R=bdfs_rel])
  defer
  apply (rename_tac si s)
  apply (case_tac si, case_tac s)
  apply (auto simp: bdfs_erel_def simple_state_rel_def) []
proof -
  assume "fb_graph G"
  then interpret fb_graph G .
  interpret BlueDFS G by unfold_locales

  from impl show "impl.tailrec_impl TYPE('b) G accpt \<le>\<Down>bdfs_rel (it_dfs TYPE('b) G accpt)" .
qed

subsection \<open>Synthesis of Executable Code\<close>
(* Straightforward autoref implementation *)
record ('v,'si,'nsi)bdfs_state_impl' = "('si,'nsi)simple_state_impl" +
  lasso_impl' :: "('v list \<times> 'v list) option"
  red_impl' :: 'nsi

definition [to_relAPP]: "bdfs_state_erel' Vi \<equiv> {
  (\<lparr>lasso_impl' = li, red_impl'=ri\<rparr>,\<lparr>lasso_impl = l, red_impl = r\<rparr>) | li ri l r.
    (li,l)\<in>\<langle>\<langle>Vi\<rangle>list_rel \<times>\<^sub>r \<langle>Vi\<rangle>list_rel\<rangle>option_rel \<and> (ri,r)\<in>\<langle>Vi\<rangle>dflt_ahs_rel}"

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

lemmas [autoref_rel_intf] = REL_INTFI[of bdfs_state_erel' i_bdfs_state_ext]

lemma [autoref_rules]:
  fixes ns_rel vis_rel Vi
  defines "R \<equiv> \<langle>ns_rel,vis_rel,\<langle>Vi\<rangle>bdfs_state_erel'\<rangle>ss_impl_rel"
  shows
    "(bdfs_state_impl'_ext, bdfs_state_impl_ext)
      \<in> \<langle>\<langle>Vi\<rangle>list_rel \<times>\<^sub>r \<langle>Vi\<rangle>list_rel\<rangle>option_rel \<rightarrow> \<langle>Vi\<rangle>dflt_ahs_rel \<rightarrow> unit_rel \<rightarrow> \<langle>Vi\<rangle>bdfs_state_erel'"
    "(lasso_impl', lasso_impl) \<in> R \<rightarrow> \<langle>\<langle>Vi\<rangle>list_rel \<times>\<^sub>r \<langle>Vi\<rangle>list_rel\<rangle>option_rel"
    "(red_impl', red_impl) \<in> R \<rightarrow> \<langle>Vi\<rangle>dflt_ahs_rel"
  unfolding bdfs_state_erel'_def ss_impl_rel_def R_def
  by auto

schematic_goal nested_dfs_code:
  assumes Vid: "V = (Id :: ('v::hashable \<times> 'v) set)"
  assumes [unfolded Vid, autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext"
    "(accpti,accpt) \<in> (V \<rightarrow> bool_rel)"
  notes [unfolded Vid, autoref_tyrel] =
    TYRELI[where R="\<langle>V\<rangle>dflt_ahs_rel"]
    TYRELI[where R="\<langle>V\<rangle>ras_rel"]
  shows "(nres_of ?c, nested_dfs_impl G accpt)
    \<in> \<langle>\<langle>\<langle>V\<rangle>list_rel \<times>\<^sub>r \<langle>V\<rangle>list_rel\<rangle>option_rel\<rangle>nres_rel"
  unfolding nested_dfs_impl_def[abs_def] Vid
    se_back_edge_impl_def run_red_dfs_impl_def mk_blue_witness_impl_def
    cyan_impl_def
    DFS_code_unfold
  (*apply (subst aux1)*)
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done

concrete_definition nested_dfs_code uses nested_dfs_code

export_code nested_dfs_code checking SML

subsection \<open>Conclusion\<close>
text \<open>
  We have implemented an efficiently executable nested DFS algorithm.
  The following theorem declares this implementation to the Autoref tool,
  such that it uses it to synthesize efficient code for @{const nested_dfs}.
  Note that you will need the lemma @{thm [source] nested_dfs_correct} to link
  @{const nested_dfs} to an abstract specification, which is usually done in
  a previous refinement step.
\<close>
theorem nested_dfs_autoref[autoref_rules]:
  assumes "PREFER_id V"
  shows "(\<lambda> G accpt. nres_of (nested_dfs_code G accpt),nested_dfs) \<in>
    \<langle>Rm, V\<rangle>g_impl_rel_ext \<rightarrow> (V \<rightarrow> bool_rel) \<rightarrow>
    \<langle>\<langle>\<langle>V\<rangle>list_rel \<times>\<^sub>r \<langle>V\<rangle>list_rel\<rangle>option_rel\<rangle>nres_rel"
proof -
  from assms have Vid: "V=Id" by simp
  note nested_dfs_code.refine[OF Vid,param_fo, THEN nres_relD]
  also note nested_dfs_impl
  finally show ?thesis by (fastforce intro: nres_relI)
qed

end