(*<*)
theory v2_isar_T
  imports Main "../../QML"
begin
(*>*)

consts planTable :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>" ("P")
(* (P x y p) \<equiv> x made from y according to p *)

axiomatization where refl :"(\<forall>x. x r x)"

lemma
assumes compossibilty2: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))))\<rfloor>"
assumes origin_uniqueness2: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))))\<rfloor>"
assumes sufficiency2: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<diamond>(P x y p) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (P x' y p) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx)))\<rfloor>"
shows origin_essentialism2: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p))) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p')))\<rfloor>"
proof (rule allI)
  fix w (* for the outer \<lfloor> \<rfloor> *)
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
  proof (rule allI)
    fix x (* for table x *)
    show "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
    proof (rule allI)
      fix y (* for material y *)
      show "(\<^bold>\<forall>z. \<^bold>\<forall>p. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
      proof (rule allI)
        fix z (* for material z *)
        show "(\<^bold>\<forall>p. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
        proof (rule allI)
          fix p (* for plan p *)
          show "((\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
          proof (rule impI)
            assume antecedent:  "((\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p))) w"
            show  "(\<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
              proof (rule notI)
                assume "((\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w"
                from antecedent have "((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (P x y p)) w"
                  by simp
                then have non_overlapping: "\<not>(y \<^bold>=\<^sup>L z) w" by (rule conjE)
                have table_x_from_y: "(P x y p w)"
                  using `((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (P x y p)) w` by (rule conjE)

                have compossibilty2_ante: "((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) w"
                  using table_x_from_y and `((\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w` and non_overlapping by auto

                have "((\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w" using `((\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p'))) w` by simp
                then obtain v where v: "w r v \<and> (((\<^bold>\<forall>p'. P x z p')) v)" by (rule exE)
                then have sufficiency2_ante: "(\<^bold>\<diamond>(P x z p)) w" by auto
                (* have "w r v" using `w r v \<and> (((\<^bold>\<forall>p'. P x z p')) v)` by (rule conjE) *)

                from compossibilty2 have "((\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))))) w"..
                then have "((\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))))) w" by (rule allE)
                then have "((\<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))))) w" by (rule allE)
                then have "((\<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))))) w" by (rule allE)
                then have "(((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p)) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p)))) w" by (rule allE)
                then have "\<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. (P x' z p))) w" using compossibilty2_ante by (rule mp)
                then obtain u where u: "w r u \<and> ((P x y p \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p)) u)" by (rule exE)
                then have "(\<^bold>\<exists>x'. P x' z p) u" by auto
                then obtain x' where x': "P x' z p u" by (rule exE)

                have "w r u"
                  using `w r u \<and> ((P x y p \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p)) u)` by (rule conjE)

                from sufficiency2 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<diamond>(P x y p) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>t. (P t y p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w"..
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<diamond>(P x y p) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>t. (P t y p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<diamond>(P x z p) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>t. (P t z p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have "(\<^bold>\<diamond>(P x z p) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>t. (P t z p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have "(\<^bold>\<box>(\<^bold>\<forall>t. (P t z p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w" using sufficiency2_ante by (rule mp)
                then have "w r u \<longrightarrow> ((\<^bold>\<forall>t. (P t z p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx)) u)" by (rule allE)
                then have "((\<^bold>\<forall>t. (P t z p) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx)) u)"
                  using `w r u` by (rule mp)
                then have "((P x' z p) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx)) u" by (rule allE)
                then have "(x' \<^bold>=\<^sup>L x) u" using `P x' z p u` by (rule mp)
                then have "(P x z p) u" using `(P x' z p) u` by auto
                moreover from u have "(P x y p) u" by simp
                then have "(P x y p) u \<and> (P x z p) u" using `(P x z p) u` by (rule conjI)
                then have conj_existence: "(P x y p \<^bold>\<and> P x z p) u" by simp
                then have impossible_arg: "(P x y p u) \<and> (P x z p u) \<and> \<not>((y \<^bold>=\<^sup>L z) u)"
                  using non_overlapping by auto

               from origin_uniqueness2 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u"..
               then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
               then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
               then have "(\<^bold>\<forall>p. \<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
               then have "(\<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
               then have "(\<^bold>\<box>(\<^bold>\<not>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by auto
               then have "(\<^bold>\<not>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" using refl by blast
               then show "False" using impossible_arg by (rule notE)
              qed
            qed
          qed
        qed
      qed
    qed
  qed

(*<*)
end
(*>*)


(* Author: Andrew Boyton, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

header "A simplified version of the actual capDL specification."

theory Types_D
imports "~~/src/HOL/Word/Word"
begin

(*
 * Objects are named by 32 bit words.
 * This name may correspond to the memory address of the object.
 *)
type_synonym cdl_object_id = "32 word"

type_synonym cdl_object_set = "cdl_object_id set"

(* The type we use to represent object sizes. *)
type_synonym cdl_size_bits = nat

(* An index into a CNode, TCB, or other kernel object that contains caps. *)
type_synonym cdl_cnode_index = nat

(* A reference to a capability slot. *)
type_synonym cdl_cap_ref = "cdl_object_id \<times> cdl_cnode_index"

(* The possible access-control rights that exist in the system. *)
datatype cdl_right = AllowRead | AllowWrite | AllowGrant

(*
 * Kernel capabilities.
 *
 * Such capabilities (or "caps") give the holder particular rights to
 * a kernel object or system hardware.
 *
 * Caps have attributes such as the object they point to, the rights
 * they give the holder, or how the holder is allowed to interact with
 * the target object.
 *
 * This is a simplified, cut-down version of this datatype for
 * demonstration purposes.
 *)
datatype cdl_cap =
    NullCap
  | EndpointCap cdl_object_id "cdl_right set"
  | CNodeCap cdl_object_id
  | TcbCap cdl_object_id

(* A mapping from capability identifiers to capabilities. *)
type_synonym cdl_cap_map = "cdl_cnode_index \<Rightarrow> cdl_cap option"

translations
  (type) "cdl_cap_map" <= (type) "nat \<Rightarrow> cdl_cap option"
  (type) "cdl_cap_ref" <= (type) "cdl_object_id \<times> nat"

(* A user cap pointer. *)
type_synonym cdl_cptr = "32 word"

(* Kernel objects *)
record cdl_tcb =
  cdl_tcb_caps :: cdl_cap_map
  cdl_tcb_fault_endpoint :: cdl_cptr

record cdl_cnode =
  cdl_cnode_caps :: cdl_cap_map
  cdl_cnode_size_bits :: cdl_size_bits

(*
 * Kernel objects.
 *
 * These are in-memory objects that may, over the course of the system
 * execution, be created or deleted by users.
 *
 * Again, a simplified version of the real datatype.
 *)
datatype cdl_object =
    Endpoint
  | Tcb cdl_tcb
  | CNode cdl_cnode

(*
 * The current state of the system.
 *
 * The state record contains the following primary pieces of information:
 *
 * objects:
 *   The objects that currently exist in the system.
 *
 * current_thread:
 *   The currently running thread. Operations will always be performed
 *   on behalf of this thread.
 *
 * ghost_state: (Used for separation logic)
 *   Which fields are owned by an object.
 *   In capDL this is all of the fields (or none of them).
 *   In any concrete state, this will be all of the fields.
 *)

(* The ghost state tracks which components (fields and slots) are owned by an object.
 * Fields + slots are encoded as None + Some nat.
 *)
type_synonym cdl_heap = "cdl_object_id \<Rightarrow> cdl_object option"
type_synonym cdl_component  = "nat option"
type_synonym cdl_components = "cdl_component set"
type_synonym cdl_ghost_state = "cdl_object_id \<Rightarrow> cdl_components"

translations
  (type) "cdl_heap" <= (type) "cdl_object_id \<Rightarrow> cdl_object option"
  (type) "cdl_ghost_state" <= (type) "cdl_object_id \<Rightarrow> nat option set"

record cdl_state =
  cdl_objects :: "cdl_heap"
  cdl_current_thread :: "cdl_object_id option"
  cdl_ghost_state :: "cdl_ghost_state"

(* Kernel objects types. *)
datatype cdl_object_type =
    EndpointType
  | TcbType
  | CNodeType

(* Return the type of an object. *)
definition
  object_type :: "cdl_object \<Rightarrow> cdl_object_type"
where
  "object_type x \<equiv>
    case x of
        Endpoint \<Rightarrow> EndpointType
      | Tcb _ \<Rightarrow> TcbType
      | CNode _ \<Rightarrow> CNodeType"

(*
 * Getters and setters for various data types.
 *)

(* Capability getters / setters *)

definition cap_objects :: "cdl_cap \<Rightarrow> cdl_object_id set"
where
    "cap_objects cap \<equiv>
       case cap of
           TcbCap x \<Rightarrow> {x}
         | CNodeCap x \<Rightarrow> {x}
         | EndpointCap x _ \<Rightarrow> {x}"

definition cap_has_object :: "cdl_cap \<Rightarrow> bool"
where
    "cap_has_object cap \<equiv>
       case cap of
           NullCap          \<Rightarrow> False
         | _                \<Rightarrow> True"

definition cap_object :: "cdl_cap \<Rightarrow> cdl_object_id"
where
    "cap_object cap \<equiv>
       if cap_has_object cap
         then THE obj_id. cap_objects cap = {obj_id}
         else undefined "

lemma cap_object_simps:
  "cap_object (TcbCap x) = x"
  "cap_object (CNodeCap x) = x"
  "cap_object (EndpointCap x j) = x"
  by (simp_all add:cap_object_def cap_objects_def cap_has_object_def)

definition
  cap_rights :: "cdl_cap \<Rightarrow> cdl_right set"
where
  "cap_rights c \<equiv> case c of
      EndpointCap _ x \<Rightarrow> x
    | _ \<Rightarrow> UNIV"

definition
  update_cap_rights :: "cdl_right set \<Rightarrow> cdl_cap \<Rightarrow> cdl_cap"
where
  "update_cap_rights r c \<equiv> case c of
      EndpointCap f1 _ \<Rightarrow> EndpointCap f1 r
    | _ \<Rightarrow> c"

(* Kernel object getters / setters *)
definition
  object_slots :: "cdl_object \<Rightarrow> cdl_cap_map"
where
  "object_slots obj \<equiv> case obj of
    CNode x \<Rightarrow> cdl_cnode_caps x
  | Tcb x \<Rightarrow> cdl_tcb_caps x
  | _ \<Rightarrow> empty"

definition
  update_slots :: "cdl_cap_map \<Rightarrow> cdl_object \<Rightarrow> cdl_object"
where
  "update_slots new_val obj \<equiv> case obj of
    CNode x \<Rightarrow> CNode (x\<lparr>cdl_cnode_caps := new_val\<rparr>)
  | Tcb x \<Rightarrow> Tcb (x\<lparr>cdl_tcb_caps := new_val\<rparr>)
  | _ \<Rightarrow> obj"

(* Adds new caps to an object. It won't overwrite on a collision. *)
definition
  add_to_slots :: "cdl_cap_map \<Rightarrow> cdl_object \<Rightarrow> cdl_object"
where
  "add_to_slots new_val obj \<equiv> update_slots (new_val ++ (object_slots obj)) obj"

definition
  slots_of :: "cdl_heap \<Rightarrow> cdl_object_id \<Rightarrow> cdl_cap_map"
where
  "slots_of h \<equiv> \<lambda>obj_id.
  case h obj_id of
    None \<Rightarrow> empty
  | Some obj \<Rightarrow> object_slots obj"

definition
  has_slots :: "cdl_object \<Rightarrow> bool"
where
  "has_slots obj \<equiv> case obj of
    CNode _ \<Rightarrow> True
  | Tcb _ \<Rightarrow> True
  | _ \<Rightarrow> False"

definition
  object_at :: "(cdl_object \<Rightarrow> bool) \<Rightarrow> cdl_object_id \<Rightarrow> cdl_heap \<Rightarrow> bool"
where
  "object_at P p s \<equiv> \<exists>object. s p = Some object \<and> P object"

abbreviation
  "ko_at k \<equiv> object_at (op = k)"

end


(*  Title:      ZF/UNITY/Mutex.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge

Based on "A Family of 2-Process Mutual Exclusion Algorithms" by J Misra.

Variables' types are introduced globally so that type verification
reduces to the usual ZF typechecking \<in> an ill-tyed expression will
reduce to the empty set.
*)

section\<open>Mutual Exclusion\<close>

theory Mutex
imports SubstAx
begin

text\<open>Based on "A Family of 2-Process Mutual Exclusion Algorithms" by J Misra

Variables' types are introduced globally so that type verification reduces to
the usual ZF typechecking: an ill-tyed expressions reduce to the empty set.
\<close>

abbreviation "p == Var([0])"
abbreviation "m == Var([1])"
abbreviation "n == Var([0,0])"
abbreviation "u == Var([0,1])"
abbreviation "v == Var([1,0])"

axiomatization where \<comment>\<open>* Type declarations  *\<close>
  p_type:  "type_of(p)=bool & default_val(p)=0" and
  m_type:  "type_of(m)=int  & default_val(m)=#0" and
  n_type:  "type_of(n)=int  & default_val(n)=#0" and
  u_type:  "type_of(u)=bool & default_val(u)=0" and
  v_type:  "type_of(v)=bool & default_val(v)=0"

definition
  (** The program for process U **)
  "U0 == {<s,t>:state*state. t = s(u:=1, m:=#1) & s`m = #0}"

definition
  "U1 == {<s,t>:state*state. t = s(p:= s`v, m:=#2) &  s`m = #1}"

definition
  "U2 == {<s,t>:state*state. t = s(m:=#3) & s`p=0 & s`m = #2}"

definition
  "U3 == {<s,t>:state*state. t=s(u:=0, m:=#4) & s`m = #3}"

definition
  "U4 == {<s,t>:state*state. t = s(p:=1, m:=#0) & s`m = #4}"

   (** The program for process V **)

definition
  "V0 == {<s,t>:state*state. t = s (v:=1, n:=#1) & s`n = #0}"

definition
  "V1 == {<s,t>:state*state. t = s(p:=not(s`u), n:=#2) & s`n = #1}"

definition
  "V2 == {<s,t>:state*state. t  = s(n:=#3) & s`p=1 & s`n = #2}"

definition
  "V3 == {<s,t>:state*state. t = s (v:=0, n:=#4) & s`n = #3}"

definition
  "V4 == {<s,t>:state*state. t  = s (p:=0, n:=#0) & s`n = #4}"

definition
  "Mutex == mk_program({s:state. s`u=0 & s`v=0 & s`m = #0 & s`n = #0},
              {U0, U1, U2, U3, U4, V0, V1, V2, V3, V4}, Pow(state*state))"

  (** The correct invariants **)

definition
  "IU == {s:state. (s`u = 1\<longleftrightarrow>(#1 $\<le> s`m & s`m $\<le> #3))
                     & (s`m = #3 \<longrightarrow> s`p=0)}"

definition
  "IV == {s:state. (s`v = 1 \<longleftrightarrow> (#1 $\<le> s`n & s`n $\<le> #3))
                      & (s`n = #3 \<longrightarrow> s`p=1)}"

  (** The faulty invariant (for U alone) **)

definition
  "bad_IU == {s:state. (s`u = 1 \<longleftrightarrow> (#1 $\<le> s`m & s`m  $\<le> #3))&
                   (#3 $\<le> s`m & s`m $\<le> #4 \<longrightarrow> s`p=0)}"

(** Variables' types **)

declare p_type [simp] u_type [simp] v_type [simp] m_type [simp] n_type [simp]

lemma u_value_type: "s \<in> state ==>s`u \<in> bool"
apply (unfold state_def)
apply (drule_tac a = u in apply_type, auto)
done

lemma v_value_type: "s \<in> state ==> s`v \<in> bool"
apply (unfold state_def)
apply (drule_tac a = v in apply_type, auto)
done

lemma p_value_type: "s \<in> state ==> s`p \<in> bool"
apply (unfold state_def)
apply (drule_tac a = p in apply_type, auto)
done

lemma m_value_type: "s \<in> state ==> s`m \<in> int"
apply (unfold state_def)
apply (drule_tac a = m in apply_type, auto)
done

lemma n_value_type: "s \<in> state ==>s`n \<in> int"
apply (unfold state_def)
apply (drule_tac a = n in apply_type, auto)
done

declare p_value_type [simp] u_value_type [simp] v_value_type [simp]
        m_value_type [simp] n_value_type [simp]

declare p_value_type [TC] u_value_type [TC] v_value_type [TC]
        m_value_type [TC] n_value_type [TC]

text\<open>Mutex is a program\<close>

lemma Mutex_in_program [simp,TC]: "Mutex \<in> program"
by (simp add: Mutex_def)

declare Mutex_def [THEN def_prg_Init, simp]
declare Mutex_def [program]

declare  U0_def [THEN def_act_simp, simp]
declare  U1_def [THEN def_act_simp, simp]
declare  U2_def [THEN def_act_simp, simp]
declare  U3_def [THEN def_act_simp, simp]
declare  U4_def [THEN def_act_simp, simp]

declare  V0_def [THEN def_act_simp, simp]
declare  V1_def [THEN def_act_simp, simp]
declare  V2_def [THEN def_act_simp, simp]
declare  V3_def [THEN def_act_simp, simp]
declare  V4_def [THEN def_act_simp, simp]

declare  U0_def [THEN def_set_simp, simp]
declare  U1_def [THEN def_set_simp, simp]
declare  U2_def [THEN def_set_simp, simp]
declare  U3_def [THEN def_set_simp, simp]
declare  U4_def [THEN def_set_simp, simp]

declare  V0_def [THEN def_set_simp, simp]
declare  V1_def [THEN def_set_simp, simp]
declare  V2_def [THEN def_set_simp, simp]
declare  V3_def [THEN def_set_simp, simp]
declare  V4_def [THEN def_set_simp, simp]

declare  IU_def [THEN def_set_simp, simp]
declare  IV_def [THEN def_set_simp, simp]
declare  bad_IU_def [THEN def_set_simp, simp]

lemma IU: "Mutex \<in> Always(IU)"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety, auto)
done

lemma IV: "Mutex \<in> Always(IV)"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety)
done

(*The safety property: mutual exclusion*)
lemma mutual_exclusion: "Mutex \<in> Always({s \<in> state. ~(s`m = #3 & s`n = #3)})"
apply (rule Always_weaken)
apply (rule Always_Int_I [OF IU IV], auto)
done

(*The bad invariant FAILS in V1*)

lemma less_lemma: "[| x$<#1; #3 $\<le> x |] ==> P"
apply (drule_tac j = "#1" and k = "#3" in zless_zle_trans)
apply (drule_tac [2] j = x in zle_zless_trans, auto)
done

lemma "Mutex \<in> Always(bad_IU)"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety, auto)
apply (subgoal_tac "#1 $\<le> #3")
apply (drule_tac x = "#1" and y = "#3" in zle_trans, auto)
apply (simp (no_asm) add: not_zless_iff_zle [THEN iff_sym])
apply auto
(*Resulting state: n=1, p=false, m=4, u=false.
  Execution of V1 (the command of process v guarded by n=1) sets p:=true,
  violating the invariant!*)
oops

(*** Progress for U ***)

lemma U_F0: "Mutex \<in> {s \<in> state. s`m=#2} Unless {s \<in> state. s`m=#3}"
by (unfold op_Unless_def Mutex_def, safety)

lemma U_F1:
     "Mutex \<in> {s \<in> state. s`m=#1} \<longmapsto>w {s \<in> state. s`p = s`v & s`m = #2}"
by (unfold Mutex_def, ensures U1)

lemma U_F2: "Mutex \<in> {s \<in> state. s`p =0 & s`m = #2} \<longmapsto>w {s \<in> state. s`m = #3}"
apply (cut_tac IU)
apply (unfold Mutex_def, ensures U2)
done

lemma U_F3: "Mutex \<in> {s \<in> state. s`m = #3} \<longmapsto>w {s \<in> state. s`p=1}"
apply (rule_tac B = "{s \<in> state. s`m = #4}" in LeadsTo_Trans)
 apply (unfold Mutex_def)
 apply (ensures U3)
apply (ensures U4)
done

lemma U_lemma2: "Mutex \<in> {s \<in> state. s`m = #2} \<longmapsto>w {s \<in> state. s`p=1}"
apply (rule LeadsTo_Diff [OF LeadsTo_weaken_L
                             Int_lower2 [THEN subset_imp_LeadsTo]])
apply (rule LeadsTo_Trans [OF U_F2 U_F3], auto)
apply (auto dest!: p_value_type simp add: bool_def)
done

lemma U_lemma1: "Mutex \<in> {s \<in> state. s`m = #1} \<longmapsto>w {s \<in> state. s`p =1}"
by (rule LeadsTo_Trans [OF U_F1 [THEN LeadsTo_weaken_R] U_lemma2], blast)

lemma eq_123: "i \<in> int ==> (#1 $\<le> i & i $\<le> #3) \<longleftrightarrow> (i=#1 | i=#2 | i=#3)"
apply auto
apply (auto simp add: neq_iff_zless)
apply (drule_tac [4] j = "#3" and i = i in zle_zless_trans)
apply (drule_tac [2] j = i and i = "#1" in zle_zless_trans)
apply (drule_tac j = i and i = "#1" in zle_zless_trans, auto)
apply (rule zle_anti_sym)
apply (simp_all (no_asm_simp) add: zless_add1_iff_zle [THEN iff_sym])
done

lemma U_lemma123: "Mutex \<in> {s \<in> state. #1 $\<le> s`m & s`m $\<le> #3} \<longmapsto>w {s \<in> state. s`p=1}"
by (simp add: eq_123 Collect_disj_eq LeadsTo_Un_distrib U_lemma1 U_lemma2 U_F3)

(*Misra's F4*)
lemma u_Leadsto_p: "Mutex \<in> {s \<in> state. s`u = 1} \<longmapsto>w {s \<in> state. s`p=1}"
by (rule Always_LeadsTo_weaken [OF IU U_lemma123], auto)

(*** Progress for V ***)

lemma V_F0: "Mutex \<in> {s \<in> state. s`n=#2} Unless {s \<in> state. s`n=#3}"
by (unfold op_Unless_def Mutex_def, safety)

lemma V_F1: "Mutex \<in> {s \<in> state. s`n=#1} \<longmapsto>w {s \<in> state. s`p = not(s`u) & s`n = #2}"
by (unfold Mutex_def, ensures "V1")

lemma V_F2: "Mutex \<in> {s \<in> state. s`p=1 & s`n = #2} \<longmapsto>w {s \<in> state. s`n = #3}"
apply (cut_tac IV)
apply (unfold Mutex_def, ensures "V2")
done

lemma V_F3: "Mutex \<in> {s \<in> state. s`n = #3} \<longmapsto>w {s \<in> state. s`p=0}"
apply (rule_tac B = "{s \<in> state. s`n = #4}" in LeadsTo_Trans)
 apply (unfold Mutex_def)
 apply (ensures V3)
apply (ensures V4)
done

lemma V_lemma2: "Mutex \<in> {s \<in> state. s`n = #2} \<longmapsto>w {s \<in> state. s`p=0}"
apply (rule LeadsTo_Diff [OF LeadsTo_weaken_L
                             Int_lower2 [THEN subset_imp_LeadsTo]])
apply (rule LeadsTo_Trans [OF V_F2 V_F3], auto)
apply (auto dest!: p_value_type simp add: bool_def)
done

lemma V_lemma1: "Mutex \<in> {s \<in> state. s`n = #1} \<longmapsto>w {s \<in> state. s`p = 0}"
by (rule LeadsTo_Trans [OF V_F1 [THEN LeadsTo_weaken_R] V_lemma2], blast)

lemma V_lemma123: "Mutex \<in> {s \<in> state. #1 $\<le> s`n & s`n $\<le> #3} \<longmapsto>w {s \<in> state. s`p = 0}"
by (simp add: eq_123 Collect_disj_eq LeadsTo_Un_distrib V_lemma1 V_lemma2 V_F3)

(*Misra's F4*)
lemma v_Leadsto_not_p: "Mutex \<in> {s \<in> state. s`v = 1} \<longmapsto>w {s \<in> state. s`p = 0}"
by (rule Always_LeadsTo_weaken [OF IV V_lemma123], auto)

(** Absence of starvation **)

(*Misra's F6*)
lemma m1_Leadsto_3: "Mutex \<in> {s \<in> state. s`m = #1} \<longmapsto>w {s \<in> state. s`m = #3}"
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
apply (rule_tac [2] U_F2)
apply (simp add: Collect_conj_eq)
apply (subst Un_commute)
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
 apply (rule_tac [2] PSP_Unless [OF v_Leadsto_not_p U_F0])
apply (rule U_F1 [THEN LeadsTo_weaken_R], auto)
apply (auto dest!: v_value_type simp add: bool_def)
done

(*The same for V*)
lemma n1_Leadsto_3: "Mutex \<in> {s \<in> state. s`n = #1} \<longmapsto>w {s \<in> state. s`n = #3}"
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
apply (rule_tac [2] V_F2)
apply (simp add: Collect_conj_eq)
apply (subst Un_commute)
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
 apply (rule_tac [2] PSP_Unless [OF u_Leadsto_p V_F0])
apply (rule V_F1 [THEN LeadsTo_weaken_R], auto)
apply (auto dest!: u_value_type simp add: bool_def)
done

end


(* Authors: Lammich, Wimmer *)
section \<open>Generic Worklist Algorithm with Subsumption\<close>
theory Worklist_Subsumption_PW_Multiset
  imports "$AFP/Refine_Imperative_HOL/Sepref" Unified_PW
begin

subsection \<open>Deriving the Standard Worklist Algorithm from the Generalized Version\<close>

(* XXX Move to misc *)
lemma mset_remove_member:
  "x \<in># A - B" if "x \<in># A" "x \<notin># B"
  using that
  by (metis count_greater_zero_iff in_diff_count not_in_iff)

context Search_Space_Defs_Empty begin

  definition "worklist_inv_frontier passed wait =
    (\<forall> a \<in> passed. \<forall> a'. E a a' \<and> \<not> empty a' \<longrightarrow> (\<exists> b' \<in> passed \<union> set_mset wait. a' \<preceq> b'))"

  definition "add_succ_spec wait a \<equiv> SPEC (\<lambda>(wait',brk).
    if \<exists>a'. E a a' \<and> F a' then
      brk
    else
      \<not>brk \<and> set_mset wait' \<subseteq> set_mset wait \<union> {a' . E a a'} \<and>
      (\<forall> s \<in> set_mset wait \<union> {a' . E a a' \<and> \<not> empty a'}. \<exists> s' \<in> set_mset wait'. s \<preceq> s')
  )"

  definition "worklist_inv \<equiv> \<lambda> (passed, wait, brk).
    pw_inv (passed, wait, brk) \<and>
    \<not> brk \<longrightarrow> worklist_inv_frontier passed wait (* \<and>
    (\<forall> a \<in> set_mset wait. \<not> empty a) *)
    "

  definition worklist_algo where
    "worklist_algo = do
      {
        if F a\<^sub>0 then RETURN True
        else do {
          (passed, wait) \<leftarrow> RETURN ({}, {#a\<^sub>0#});
          (passed, wait, brk) \<leftarrow> WHILEIT worklist_inv (\<lambda> (passed, wait, brk). \<not> brk \<and> wait \<noteq> {#})
            (\<lambda> (passed, wait, brk). do
              {
                (a, wait) \<leftarrow> take_from_mset wait;
                ASSERT (reachable a);
                if (\<exists> a' \<in> passed. a \<preceq> a') then RETURN (passed, wait, brk) else
                do
                  {
                    (wait,brk) \<leftarrow> add_succ_spec wait a;
                    let passed = insert a passed;
                    RETURN (passed, wait, brk)
                  }
              }
            )
            (passed, wait, False);
            RETURN brk
        }
      }
    "

end

subsubsection \<open>Correctness Proof\<close>

context Search_Space' begin

  lemma add_succs_ref_aux_1:
    "(if (\<exists> a' \<in> passed. a \<preceq> a') then RETURN (passed, wait, brk) else
        do
          {
            (wait,brk) \<leftarrow> add_succ_spec wait a;
            let passed = insert a passed;
            RETURN (passed, wait, brk)
          }
      ) \<le> \<Down> Id (add_pw_spec passed' wait' a')"
    if "(\<forall> a \<in> passed \<union> set_mset wait. \<not> F a)" "worklist_inv_frontier passed (wait + {#a#})"
    "reachable a" "passed \<union> set_mset wait \<subseteq> Collect reachable" "\<not> brk" "\<not> F a"
    "(wait, wait') \<in> Id" "(passed, passed') \<in> Id" "(a, a') \<in> Id"
    unfolding add_pw_spec_def using that
    apply auto
    subgoal for b a'
      unfolding worklist_inv_frontier_def
      apply (frule final_non_empty)
      apply clarsimp
      apply (drule mono, assumption, simp, blast, blast dest: empty_E)
      by (blast intro: F_mono trans dest: empty_mono)
    subgoal
      unfolding add_succ_spec_def by (auto simp: pw_le_iff refine_pw_simps)
    subgoal premises prems for a'' b
    proof -
      from prems obtain b' where b': "E a'' b'" "b \<preceq> b'"
        by (metis (mono_tags, lifting) empty_E mono subset_Collect_conv)
      with prems have "\<not> empty b'" by - (rule empty_mono)
      with b' prems(2) \<open>a'' \<in> passed'\<close> consider "b' \<preceq> a'" | "\<exists>x\<in>passed' \<union> set_mset wait'. b' \<preceq> x"
        unfolding worklist_inv_frontier_def by auto
      then show ?thesis
      proof cases
        case 1
        then show ?thesis
          by (meson b'(2) local.trans prems(12) prems(13) subsetCE sup.cobounded2)
      next
        case 2
        with b'(2) show ?thesis by (auto intro: trans)
      qed
    qed
    unfolding add_succ_spec_def by (auto simp: pw_le_iff refine_pw_simps)

context
begin

  private lemma aux3:
    assumes
      "set_mset wait \<subseteq> Collect reachable"
      "a \<in># wait"
      "\<forall> s \<in> set_mset (wait - {#a#}) \<union> {a'. E a a' \<and> \<not> empty a'}. \<exists> s' \<in> set_mset wait'. s \<preceq> s'"
      "worklist_inv_frontier passed wait"
    shows "worklist_inv_frontier (insert a passed) wait'"
  proof -
    from assms(1,2) have "reachable a"
      by (simp add: subset_iff)
    with finitely_branching have [simp, intro!]: "finite (Collect (E a))" .

    show ?thesis unfolding worklist_inv_frontier_def
      apply safe
      subgoal
        using assms by auto
      subgoal for b b'
      proof -
        assume A: "E b b'" "\<not> empty b'" "b \<in> passed"
        with assms obtain b'' where b'': "b'' \<in> passed \<union> set_mset wait" "b' \<preceq> b''"
          unfolding worklist_inv_frontier_def by blast
        from this(1) show ?thesis
          apply standard
          subgoal
            using \<open>b' \<preceq> b''\<close> by auto
          subgoal
            apply (cases "a = b''")
            subgoal
              using b''(2) by blast
            subgoal premises prems
            proof -
              from prems have "b'' \<in># wait - {#a#}"
                by (auto simp: mset_remove_member)
              with assms prems \<open>b' \<preceq> b''\<close> show ?thesis
                by (blast intro: local.trans)
            qed
            done
          done
      qed
      done
  qed

  lemma add_succs_ref_aux_2:
    "(if (\<exists> a' \<in> passed. a \<preceq> a') then RETURN (passed, wait, brk) else
        do
          {
            (wait,brk) \<leftarrow> add_succ_spec wait a;
            let passed = insert a passed;
            RETURN (passed, wait, brk)
          }
      ) \<le> SPEC (\<lambda> (passed, wait, brk). (\<not> brk \<longrightarrow> worklist_inv_frontier passed wait))"
    if "worklist_inv_frontier passed (wait + {#a#})" "reachable a"
       "passed \<union> set_mset wait \<subseteq> Collect reachable"
    using that
    apply clarsimp
    apply safe
    subgoal
      unfolding worklist_inv_frontier_def by (auto intro: trans)
    subgoal
      unfolding add_succ_spec_def
      apply (auto simp add: pw_le_iff refine_pw_simps)
      apply (rule aux3)
         prefer 4
         apply assumption
      defer
        apply (simp; fail)
        (* s/h *)
        apply (simp add: worklist_inv_frontier_def)
      by (simp add: Multiset.diff_union_cancelR; fail)
    done

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

lemma add_succs_ref[refine]:
  "(if (\<exists> a' \<in> passed. a \<preceq> a') then RETURN (passed, wait, brk) else
      do
        {
          (wait,brk) \<leftarrow> add_succ_spec wait a;
          let passed = insert a passed;
          RETURN (passed, wait, brk)
        }
    ) \<le>
    \<Down> {((passed, wait, brk),(passed', wait',brk')).
        passed = passed' \<and> wait = wait' \<and> brk = brk' \<and>
        (\<not> brk \<longrightarrow> worklist_inv_frontier passed wait)} (add_pw_spec passed' wait' a')"
  if "(\<forall> a \<in> passed \<union> set_mset wait. \<not> F a)" "worklist_inv_frontier passed (wait + {#a#})"
  "reachable a" "passed \<union> set_mset wait \<subseteq> Collect reachable" "\<not> brk" "\<not> F a"
  "(wait, wait') \<in> Id" "(passed, passed') \<in> Id" "(a, a') \<in> Id"
  using add_succs_ref_aux_1[OF that] add_succs_ref_aux_2[OF that(2-4)]
  by (simp add: pw_le_iff refine_pw_simps)

lemma [refine]:
  "take_from_mset wait \<le>
    \<Down> {((x, wait), (y, wait')).
      x = y \<and> wait = wait' \<and> (\<forall> a \<in> set_mset wait. \<not> F a) \<and> set_mset wait \<subseteq> Collect reachable \<and>
      worklist_inv_frontier passed (wait + {#x#}) \<and> \<not> F x} (take_from_mset wait')"
  if "wait = wait'" "wait \<noteq> {#}" "(\<forall> a \<in> set_mset wait. \<not> F a)" "set_mset wait \<subseteq> Collect reachable"
      "worklist_inv_frontier passed wait"
  using that
  by (auto 4 5 simp: pw_le_iff refine_pw_simps dest: in_diffD dest!: take_from_mset_correct)

lemma [refine]:
  "RETURN ({}, {#a\<^sub>0#}) \<le> \<Down> (Id \<inter> {((p, w), (p', w')). worklist_inv (p, w, False)}) init_pw_spec"
  unfolding init_pw_spec_def worklist_inv_def pw_inv_def worklist_inv_frontier_def
  by (auto simp: pw_le_iff refine_pw_simps)

lemma worklist_algo_ref[refine]:
  "worklist_algo \<le> \<Down> Id pw_algo"
  unfolding worklist_algo_def pw_algo_def
    using [[goals_limit=20]]
    apply refine_rcg
   unfolding pw_inv_def worklist_inv_def worklist_inv_frontier_def pw_inv_frontier_def
      by auto (* slow *)

theorem worklist_algo_correct:
  "worklist_algo \<le> SPEC (\<lambda> brk. brk \<longleftrightarrow> F_reachable)"
proof -
  note worklist_algo_ref
  also note pw_algo_correct
  finally show ?thesis .
qed

end \<comment> \<open>Search Space'\<close>

context Search_Space''_Defs
begin

  definition "worklist_inv_frontier' passed wait =
    (\<forall> a \<in> passed. \<forall> a'. E a a' \<and> \<not> empty a' \<longrightarrow> (\<exists> b' \<in> passed \<union> set_mset wait. a' \<preceq> b'))"

  definition "start_subsumed' passed wait = (\<exists> a \<in> passed \<union> set_mset wait. a\<^sub>0 \<preceq> a)"

  definition "worklist_inv' \<equiv> \<lambda> (passed, wait, brk).
    worklist_inv (passed, wait, brk) \<and> (\<forall> a \<in> passed. \<not> empty a) \<and> (\<forall> a \<in> set_mset wait. \<not> empty a)
      "

  definition "add_succ_spec' wait a \<equiv> SPEC (\<lambda>(wait',brk).
    (
    if \<exists>a'. E a a' \<and> F a' then
        brk
      else
        \<not>brk \<and> set_mset wait' \<subseteq> set_mset wait \<union> {a' . E a a'} \<and>
        (\<forall> s \<in> set_mset wait \<union> {a' . E a a' \<and> \<not> empty a'}. \<exists> s' \<in> set_mset wait'. s \<preceq> s')
    ) \<and> (\<forall> s \<in> set_mset wait'. \<not> empty s)
    )"

  definition worklist_algo' where
    "worklist_algo' = do
      {
        if F a\<^sub>0 then RETURN True
        else do {
          let passed = {};
          let wait = {#a\<^sub>0#};
          (passed, wait, brk) \<leftarrow> WHILEIT worklist_inv' (\<lambda> (passed, wait, brk). \<not> brk \<and> wait \<noteq> {#})
            (\<lambda> (passed, wait, brk). do
              {
                (a, wait) \<leftarrow> take_from_mset wait;
                ASSERT (reachable a);
                if (\<exists> a' \<in> passed. a \<unlhd> a') then RETURN (passed, wait, brk) else
                do
                  {
                    (wait,brk) \<leftarrow> add_succ_spec' wait a;
                    let passed = insert a passed;
                    RETURN (passed, wait, brk)
                  }
              }
            )
            (passed, wait, False);
            RETURN brk
        }
      }
    "

end \<comment> \<open>Search Space' Defs\<close>

context Search_Space''_start
begin

  lemma worklist_algo_list_inv_ref[refine]:
    fixes x x'
    assumes
      "\<not> F a\<^sub>0" "\<not> F a\<^sub>0"
      "(x, x') \<in> {
        ((passed,wait,brk), (passed',wait',brk')). passed = passed' \<and> wait = wait' \<and> brk = brk' \<and>
        (\<forall> a \<in> passed. \<not> empty a) \<and> (\<forall> a \<in> set_mset wait. \<not> empty a)}"
      "worklist_inv x'"
    shows "worklist_inv' x"
    using assms
    unfolding worklist_inv'_def worklist_inv_def
    by auto

  lemma [refine]:
    "take_from_mset wait \<le>
    \<Down> {((x, wait), (y, wait')). x = y \<and> wait = wait' \<and> \<not> empty x \<and>
        (\<forall> a \<in> set_mset wait. \<not> empty a)} (take_from_mset wait')"
    if "wait = wait'" "\<forall> a \<in> set_mset wait. \<not> empty a" "wait \<noteq> {#}"
    using that
    by (auto 4 5 simp: pw_le_iff refine_pw_simps dest: in_diffD dest!: take_from_mset_correct)

  lemma [refine]:
    "add_succ_spec' wait x \<le>
    \<Down> ({(wait, wait'). wait = wait' \<and>
        (\<forall> a \<in> set_mset wait. \<not> empty a)} \<times>\<^sub>r bool_rel) (add_succ_spec wait' x')"
    if "wait = wait'" "x = x'" "\<forall> a \<in> set_mset wait. \<not> empty a"
    using that
    unfolding add_succ_spec'_def add_succ_spec_def
    by (auto simp: pw_le_iff refine_pw_simps)

 lemma worklist_algo'_ref[refine]: "worklist_algo' \<le> \<Down>Id worklist_algo"
    using [[goals_limit=15]]
    unfolding worklist_algo'_def worklist_algo_def
    apply (refine_rcg)
                   prefer 4
                   apply assumption
                  apply refine_dref_type
    by (auto simp: empty_subsumes')

end \<comment> \<open>Search Space' Start\<close>

context Search_Space''_Defs
begin

  definition worklist_algo'' where
    "worklist_algo'' \<equiv>
      if empty a\<^sub>0 then RETURN False else worklist_algo'
    "

end \<comment> \<open>Search Space' Defs\<close>

context Search_Space''
begin

  lemma worklist_algo''_correct:
    "worklist_algo'' \<le> SPEC (\<lambda> brk. brk \<longleftrightarrow> F_reachable)"
  proof (cases "empty a\<^sub>0")
    case True
    then show ?thesis
      unfolding worklist_algo''_def F_reachable_def reachable_def
      using empty_E_star final_non_empty by auto
  next
    case False
    interpret Search_Space''_start
      by standard (rule \<open>\<not> empty _\<close>)
    note worklist_algo'_ref
    also note worklist_algo_correct
    finally show ?thesis
      using False unfolding worklist_algo''_def by simp
  qed

end \<comment> \<open>Search Space''\<close>

end \<comment> \<open>End of Theory\<close>