theory utp_fault_rea_designs
imports  utp_reactive
begin
subsection {*Sequential C-program alphabet*}

text {*In order to record the interaction of a sequential C program with its execution environment,
       we extend the alphabet of UTP by two additional global state variables:
      \begin{itemize}
       \<^item> fault: a variable of type @{typ "'f option"} used to record a fault of a given guard is
         not satisfied.
       \<^item> abrupt: a boolean variable used to
     \end{itemize}

*}

alphabet 'f cp_vars = "'t rp_vars" +
  abrupt:: bool
  fault :: "'f option"
  (*wait :: bool*)

declare cp_vars.splits [alpha_splits]

subsubsection {*Alphabet proofs*}
text {*
  The two locale interpretations below are a technicality to improve automatic
  proof support via the predicate and relational tactics. This is to enable the
  (re-)interpretation of state spaces to remove any occurrences of lens types
  after the proof tactics @{method pred_simp} and @{method rel_simp}, or any
  of their derivatives have been applied. Eventually, it would be desirable to
  automate both interpretations as part of a custom outer command for defining
  alphabets.
*}

interpretation cp_vars:
  lens_interp "\<lambda> (ok, wait, tr, r).
  (ok, wait, tr, abrupt\<^sub>v r, fault\<^sub>v r, more r)"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

interpretation cp_vars_rel: lens_interp "\<lambda>(ok, ok', wait, tr, wait', tr', r, r').
  (ok, ok', wait, wait', tr, tr', abrupt\<^sub>v r, abrupt\<^sub>v r', fault\<^sub>v r, fault\<^sub>v r', more r, more r')"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

subsubsection {*Type lifting*}

type_synonym ('t, 'f, '\<alpha>) cp = "('t, ('f, '\<alpha>) cp_vars_scheme) rp"
type_synonym ('t,'f,'\<alpha>,'\<beta>) rel_cp  = "(('t,'f,'\<alpha>) cp, ('t,'f,'\<beta>) cp) rel"
type_synonym ('t,'f,'\<alpha>) hrel_cp  = "(('t,'f,'\<alpha>) cp) hrel"

subsubsection {*Syntactic type setup*}

translations
  (type) "('t, 'f, '\<alpha>) cp" <= (type) "('t, ('f, '\<alpha>) cp_vars_scheme) rp_vars_scheme des"
  (type) "('t, 'f, '\<alpha>) cp" <= (type) "('t, ('f, '\<alpha>) cp_vars_scheme) rp_vars_ext des"
  (type) "('t, 'f,'\<alpha>,'\<beta>) rel_cp" <= (type) "(('t,'f,'\<alpha>) cp, (_,_,'\<beta>) cp) rel"

notation cp_vars_child_lens\<^sub>a ("\<Sigma>\<^sub>c")
notation cp_vars_child_lens ("\<Sigma>\<^sub>C")

syntax
  "_svid_st_alpha"  :: "svid" ("\<Sigma>\<^sub>C")
  "_svid_st_a"  :: "svid" ("\<Sigma>\<^sub>c")
translations
  "_svid_st_alpha" => "CONST cp_vars_child_lens"
   "_svid_st_a" => "CONST cp_vars_child_lens\<^sub>a"

lemma cvars_ord [usubst]:
  "$fault \<prec>\<^sub>v $fault\<acute>" "$abrupt \<prec>\<^sub>v $abrupt\<acute>"  "$ok \<prec>\<^sub>v $ok\<acute>"
  "$ok \<prec>\<^sub>v $wait\<acute>" "$ok \<prec>\<^sub>v $wait" "$ok\<acute> \<prec>\<^sub>v $wait\<acute>"  "$ok\<acute> \<prec>\<^sub>v $wait"
  "$ok \<prec>\<^sub>v $fault\<acute>" "$ok \<prec>\<^sub>v $fault" "$ok\<acute> \<prec>\<^sub>v $fault\<acute>"  "$ok\<acute> \<prec>\<^sub>v $fault"
  "$ok \<prec>\<^sub>v $abrupt\<acute>" "$ok \<prec>\<^sub>v $abrupt" "$ok\<acute> \<prec>\<^sub>v $abrupt\<acute>"  "$ok\<acute> \<prec>\<^sub>v $abrupt"
  "$fault \<prec>\<^sub>v $abrupt\<acute>" "$fault \<prec>\<^sub>v $abrupt" "$fault\<acute> \<prec>\<^sub>v $abrupt\<acute>"  "$fault\<acute> \<prec>\<^sub>v $abrupt"
  "$fault \<prec>\<^sub>v $wait\<acute>" "$fault \<prec>\<^sub>v $wait" "$fault\<acute> \<prec>\<^sub>v $wait\<acute>"  "$fault\<acute> \<prec>\<^sub>v $wait"
  "$abrupt \<prec>\<^sub>v $wait\<acute>" "$abrupt \<prec>\<^sub>v $wait" "$abrupt\<acute> \<prec>\<^sub>v $wait\<acute>"  "$abrupt\<acute> \<prec>\<^sub>v $wait"
  by (simp_all add: var_name_ord_def)

abbreviation abrupt_f::"('t::ordered_cancel_monoid_diff,'f, '\<alpha>, '\<beta>) rel_cp \<Rightarrow>
                        ('t,'f, '\<alpha>, '\<beta>) rel_cp"
where "abrupt_f R \<equiv> R\<lbrakk>false/$abrupt\<rbrakk>"

abbreviation abrupt_t::"('t::ordered_cancel_monoid_diff,'f, '\<alpha>, '\<beta>) rel_cp \<Rightarrow>
                        ('t,'f, '\<alpha>, '\<beta>) rel_cp"
where "abrupt_t R \<equiv> R\<lbrakk>true/$abrupt\<rbrakk>"

syntax
  "_abrupt_f"  :: "logic \<Rightarrow> logic" ("_\<^sub>a\<^sub>f" [1000] 1000)
  "_abrupt_t"  :: "logic \<Rightarrow> logic" ("_\<^sub>a\<^sub>t" [1000] 1000)

translations
  "P \<^sub>a\<^sub>f" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ivar CONST abrupt) false) P"
  "P \<^sub>a\<^sub>t" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ivar CONST abrupt) true) P"

subsection {*UTP-Relations lift and drop*}

abbreviation lift_desr ("\<lceil>_\<rceil>\<^sub>C")
where "\<lceil>P\<rceil>\<^sub>C \<equiv> P \<oplus>\<^sub>p (\<Sigma>\<^sub>C \<times>\<^sub>L \<Sigma>\<^sub>C)"

abbreviation lift_pre_desr ("\<lceil>_\<rceil>\<^sub>C\<^sub><")
where "\<lceil>p\<rceil>\<^sub>C\<^sub>< \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub><\<rceil>\<^sub>C"

abbreviation lift_post_desr ("\<lceil>_\<rceil>\<^sub>C\<^sub>>")
where "\<lceil>p\<rceil>\<^sub>C\<^sub>> \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub>>\<rceil>\<^sub>C"

abbreviation drop_desr ("\<lfloor>_\<rfloor>\<^sub>C")
where "\<lfloor>P\<rfloor>\<^sub>C \<equiv> P \<restriction>\<^sub>p (\<Sigma>\<^sub>C \<times>\<^sub>L \<Sigma>\<^sub>C)"

subsection {* Reactive lemmas *}

lemma unrest_ok_lift_rea [unrest]:
  "$ok \<sharp> \<lceil>P\<rceil>\<^sub>C" "$ok\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>C"
  by (pred_auto)+

lemma unrest_wait_lift_rea [unrest]:
  "$abrupt \<sharp> \<lceil>P\<rceil>\<^sub>C" "$abrupt\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>C"
  by (pred_auto)+

lemma unrest_tr_lift_rea [unrest]:
  "$fault \<sharp> \<lceil>P\<rceil>\<^sub>C" "$fault\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>C"
  by (pred_auto)+

lemma seqr_wait_true [usubst]: "(P ;; Q) \<^sub>a\<^sub>t = (P \<^sub>a\<^sub>t ;; Q)"
  by (rel_auto)

lemma seqr_wait_false [usubst]: "(P ;; Q) \<^sub>a\<^sub>f = (P \<^sub>a\<^sub>f ;; Q)"
  by (rel_auto)

subsection{*Healthiness conditions*}
text {*In UTP healthiness conditions is away to express invariant on the alphabet.
       The following healthiness condition express that programs in, wait, fault or
       abrupt state do not progress.*}
definition C3_def [upred_defs]: "C3(P) =
           (P \<triangleleft>  \<not>$wait \<and> \<not>$abrupt \<and> $fault =\<^sub>u \<guillemotleft>None\<guillemotright> \<triangleright> II )"

subsection {*exec semantics*}
text {*We introduce an execution semantics for the designs containing a specific values for
       the auxiliary variables composing C-program alphabet. Under this execution function
       we consider only \emph{stable} initial state ie., normal initial state.
       Since Simpl semantics is defined only for initial normal state, using this semantics
       will allow for an equivalent semantics as the one of Simpl language.*}

abbreviation
 "Simpl P \<equiv> C3(true \<turnstile> (P))"

subsection{*Control flow statements*}

text{*In the sequel we introduce the control-flow statements for C programming language.*}

definition skip_c :: "('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp" ("SKIP")
where [urel_defs]:"SKIP = Simpl ($tr\<acute> =\<^sub>u $tr \<and> \<not>$wait\<acute> \<and> \<not>$abrupt\<acute> \<and> $fault\<acute> =\<^sub>u \<guillemotleft>None\<guillemotright> \<and> \<lceil>II\<rceil>\<^sub>C)"

definition stuck_c :: "('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp" ("STUCK")
where [urel_defs]: "STUCK = (\<not>$ok\<acute> \<or> $wait\<acute> \<or> $abrupt\<acute> \<or> $fault\<acute> \<noteq>\<^sub>u \<guillemotleft>None\<guillemotright>)"

definition assigns_c :: "'\<alpha> usubst \<Rightarrow> ('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp" ("\<langle>_\<rangle>\<^sub>C")
where [urel_defs]: "assigns_c \<sigma> =
                    C3(\<lceil>true\<rceil>\<^sub>D \<turnstile> ($tr\<acute> =\<^sub>u $tr \<and> \<not>$wait\<acute> \<and> \<not>$abrupt\<acute> \<and> $fault\<acute> =\<^sub>u \<guillemotleft>None\<guillemotright> \<and> \<lceil>\<langle>\<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>C))"

subsection{*THROW*}

definition throw_c :: "('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp" ("THROW")
where [urel_defs]: "THROW = Simpl ($tr\<acute> =\<^sub>u $tr \<and> \<not>$wait\<acute> \<and> $abrupt\<acute> \<and> $fault\<acute> =\<^sub>u \<guillemotleft>None\<guillemotright> \<and> \<lceil>II\<rceil>\<^sub>C)"

subsection{*Conditional*}

abbreviation If_c::"'\<alpha> cond \<Rightarrow>('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp \<Rightarrow> ('t,'f,'\<alpha>) hrel_cp \<Rightarrow>
                    ('t,'f,'\<alpha>) hrel_cp" ("bif (_)/ then (_) else (_) eif")where
  "If_c b P Q \<equiv> (P \<triangleleft> \<lceil>b\<rceil>\<^sub>C\<^sub>< \<triangleright> Q)"

subsection{*GUARD*}

abbreviation guard_c :: "'f \<Rightarrow> '\<alpha> cond \<Rightarrow> ('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp"
where "guard_c f b \<equiv> (bif b
                        then SKIP
                        else Simpl ($tr\<acute> =\<^sub>u $tr \<and> \<not>$wait\<acute> \<and> \<not>$abrupt\<acute> \<and> $fault\<acute> =\<^sub>u \<guillemotleft>Some f\<guillemotright> \<and> \<lceil>II\<rceil>\<^sub>C)
                      eif)"

subsection{*Synchronisation*}

abbreviation sync_c :: "'\<alpha> cond \<Rightarrow> ('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp"
where "sync_c b \<equiv> (bif b
                     then SKIP
                     else Simpl ($tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<and> \<not>$abrupt\<acute> \<and> $fault\<acute> =\<^sub>u \<guillemotleft>None\<guillemotright> \<and> \<lceil>II\<rceil>\<^sub>C)
                   eif)"

subsection{*assert and assume*}

definition rassume_c :: "'\<alpha> upred \<Rightarrow> ('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp" ("_\<^sup>\<top>\<^sup>C" [999] 999) where
[urel_defs]: "rassume_c c = (bif c then SKIP else \<top>\<^sub>D eif)"

definition rassert_c :: "'\<alpha> upred \<Rightarrow> ('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp" ("_\<^sub>\<bottom>\<^sub>C" [999] 999) where
[urel_defs]: "rassert_c c = (bif c then SKIP else \<bottom>\<^sub>D eif)"

subsection{*Exceptions*}

abbreviation catch_c :: "('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp \<Rightarrow> ('t,'f,'\<alpha>) hrel_cp \<Rightarrow>
                         ('t,'f,'\<alpha>) hrel_cp" ("try (_) catch /(_) end")
where "try P catch Q end \<equiv> (P ;; ((abrupt:== (\<not> &abrupt) ;;Q) \<triangleleft> $abrupt \<triangleright> II))"

subsection{*Scoping*}

definition block_c ("bob INIT (_) BODY /(_) RESTORE /(_) RETURN/(_) eob") where
[urel_defs]:
  "bob INIT init BODY body RESTORE restore RETURN return eob=
    (Abs_uexpr (\<lambda>(s, s').
     \<lbrakk>init ;; body ;; Abs_uexpr (\<lambda>(t, t').
                       \<lbrakk>(abrupt:== (\<not> &abrupt) ;;restore (s, s') (t, t');; THROW) \<triangleleft> $abrupt \<triangleright> II;;
         restore (s, s') (t, t');; return(s, s') (t, t')\<rbrakk>\<^sub>e (t, t'))\<rbrakk>\<^sub>e (s, s')))"

subsection{*Loops*}
purge_notation while ("while\<^sup>\<top> _ do _ od")

definition While :: "'\<alpha> cond \<Rightarrow> ('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp \<Rightarrow>
                     ('t,'f,'\<alpha>) hrel_cp" ("while\<^sup>\<top> _ do _ od") where
"While b C = (\<nu> X \<bullet> bif b then (C ;; X) else SKIP eif)"

purge_notation while_top ("while _ do _ od")

abbreviation While_top :: "'\<alpha> cond \<Rightarrow> ('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp \<Rightarrow>
                           ('t,'f,'\<alpha>) hrel_cp" ("while _ do _ od") where
"while b do P od \<equiv> while\<^sup>\<top> b do P od"

purge_notation while_bot ("while\<^sub>\<bottom> _ do _ od")

definition While_bot :: "'\<alpha> cond \<Rightarrow> ('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp \<Rightarrow>
                         ('t,'f,'\<alpha>) hrel_cp" ("while\<^sub>\<bottom> _ do _ od") where
"while\<^sub>\<bottom> b do P od =  (\<mu> X \<bullet> bif b then (P ;; X) else SKIP eif)"

subsection{*While-loop inv*}
text {* While loops with invariant decoration *}

purge_notation while_inv ("while _ invr _ do _ od" 70)

definition While_inv :: "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> ('t::ordered_cancel_monoid_diff,'f,'\<alpha>) hrel_cp \<Rightarrow>
                         ('t,'f,'\<alpha>) hrel_cp" ("while _ invr _ do _ od" 70) where
"while b invr p do S od = while b do S od"

declare While_def [urel_defs]
declare While_inv_def [urel_defs]
declare While_bot_def [urel_defs]

syntax
  "_assignmentc" :: "svid_list \<Rightarrow> uexprs \<Rightarrow> logic"  (infixr "\<Midarrow>" 55)

translations
  "_assignmentc xs vs" => "CONST assigns_c (_mk_usubst (CONST id) xs vs)"
  "x \<Midarrow> v" <= "CONST assigns_c (CONST subst_upd (CONST id) (CONST svar x) v)"
  "x \<Midarrow> v" <= "CONST assigns_c (CONST subst_upd (CONST id) x v)"
  "x,y \<Midarrow> u,v" <= "CONST assigns_c (CONST subst_upd (CONST subst_upd (CONST id) (CONST svar x) u) (CONST svar y) v)"

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

(*
 * A theoretical framework for reasoning about non-interference
 * of monadic programs.
 *)

theory EquivValid
imports Corres_UL
begin

section{* State equivalence validity *}

text{*

A generalised information flow property.

Often, we read in the entire state, but then only examine part of it.
The following property may be used to split up binds whose first part
does this.

@{term "I"} is the state relation that holds invariantly.

@{term "A"} (also) holds between initial states.

@{term "B"} (also) holds between final states.

@{term "P"} holds in the initial state for @{term "f"}.

@{term "P'"} holds in the initial state for @{term "f'"}.

*}

definition
  equiv_valid_2 :: "('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s,'b) nondet_monad \<Rightarrow> ('s,'c) nondet_monad \<Rightarrow> bool"
where
  "equiv_valid_2 I A B R P P' f f' \<equiv> \<forall>s t.
       P s \<and> P' t \<and> I s t \<and> A s t
     \<longrightarrow> (\<forall>(rva, s') \<in> fst (f s). \<forall>(rvb, t') \<in> fst (f' t).
          R rva rvb \<and> I s' t' \<and> B s' t')"

lemma equiv_valid_2_bind_general:
  assumes r2: "\<And> rv rv'. R' rv rv' \<Longrightarrow> equiv_valid_2 D B C R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes r1: "equiv_valid_2 D A B R' P P' f f'"
  assumes hoare: "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes hoare': "\<lbrace> S' \<rbrace> f' \<lbrace> Q' \<rbrace>"
  shows "equiv_valid_2 D A C R (\<lambda> s. P s \<and> S s) (\<lambda> s. P' s \<and> S' s) (f >>= g) (f' >>= g')"
  using assms
  unfolding bind_def equiv_valid_2_def valid_def
  apply fastforce
  done

(* almost all of the time, the second relation doesn't change *)
lemma equiv_valid_2_bind:
  assumes r2: "\<And> rv rv'. R' rv rv' \<Longrightarrow> equiv_valid_2 D A A R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes r1: "equiv_valid_2 D A A R' P P' f f'"
  assumes hoare: "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes hoare': "\<lbrace> S' \<rbrace> f' \<lbrace> Q' \<rbrace>"
  shows "equiv_valid_2 D A A R (\<lambda> s. P s \<and> S s) (\<lambda> s. P' s \<and> S' s) (f >>= g) (f' >>= g')"
  using assms by (blast intro: equiv_valid_2_bind_general)

lemma equiv_valid_2_guard_imp:
  assumes reads_res: "equiv_valid_2 D A B R Q Q' f f'"
  assumes guard_imp: "\<And> s. P s \<Longrightarrow> Q s"
  assumes guard_imp': "\<And> s. P' s \<Longrightarrow> Q' s"
  shows "equiv_valid_2 D A B R P P' f f'"
  using assms
  by (fastforce simp: equiv_valid_2_def)

lemma equiv_valid_2_bind_pre:
  assumes r2: "\<And> rv rv'. R' rv rv' \<Longrightarrow> equiv_valid_2 D A A R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes r1: "equiv_valid_2 D A A R' P P' f f'"
  assumes hoare: "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes hoare': "\<lbrace> S' \<rbrace> f' \<lbrace> Q' \<rbrace>"
  assumes guard_imp: "\<And> s. T s \<Longrightarrow> P s \<and> S s"
  assumes guard_imp': "\<And> s. T' s \<Longrightarrow> P' s \<and> S' s"
  shows "equiv_valid_2 D A A R T T' (f >>= g) (f' >>= g')"
  using assms by (blast intro: equiv_valid_2_bind[THEN equiv_valid_2_guard_imp])

lemma return_ev2:
  assumes rel: "\<And> s t. \<lbrakk>P s; P' t; I s t; A s t\<rbrakk> \<Longrightarrow> R a b"
  shows "equiv_valid_2 I A A R P P' (return a) (return b)"
  by(auto simp: equiv_valid_2_def return_def rel)

lemma equiv_valid_2_liftE:
  "equiv_valid_2 D A B R P P' f f' \<Longrightarrow>
   equiv_valid_2 D A B (E \<oplus> R) P P' (liftE f) (liftE f')"
  apply(unfold liftE_def)
  apply(rule equiv_valid_2_guard_imp)
  apply(rule_tac Q="\<top>\<top>" and Q'="\<top>\<top>" and R'=R in equiv_valid_2_bind_general)
       apply(fastforce intro: return_ev2)
      apply assumption
     apply(rule wp_post_taut)+
   by(simp_all)

lemma equiv_valid_2_liftE_bindE_general:
  assumes r2: "\<And> rv rv'. R' rv rv' \<Longrightarrow> equiv_valid_2 D B C R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes hoare: "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes hoare':  "\<lbrace> S' \<rbrace> f' \<lbrace> Q' \<rbrace>"
  assumes r1: "equiv_valid_2 D A B R' P P' f f'"
  shows "equiv_valid_2 D A C R (P and S) (P' and S') (liftE f >>=E g) (liftE f' >>=E g')"
  apply(unfold bindE_def)
  apply(rule equiv_valid_2_guard_imp)
  apply(rule_tac Q="\<lambda> rv. K (\<forall> v. rv \<noteq> Inl v) and (\<lambda> s. \<forall> v. rv = Inr v \<longrightarrow> Q v s)" and Q'="\<lambda> rv. K (\<forall> v. rv \<noteq> Inl v) and (\<lambda> s. \<forall> v. rv = Inr v \<longrightarrow> Q' v s)" in equiv_valid_2_bind_general)
       prefer 2
       apply(rule_tac E="dc" in equiv_valid_2_liftE)
       apply(rule r1)
      apply(clarsimp simp: lift_def split: sum.split)
      apply(insert r2, fastforce simp: equiv_valid_2_def)[1]
     apply(simp add: liftE_def, wp, fastforce intro!: hoare_strengthen_post[OF hoare])
    apply(simp add: liftE_def, wp, fastforce intro!: hoare_strengthen_post[OF hoare'])
   by(auto)

lemma equiv_valid_2_liftE_bindE:
  assumes r2: "\<And> rv rv'. R' rv rv' \<Longrightarrow> equiv_valid_2 D A A R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes hoare: "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes hoare':  "\<lbrace> S' \<rbrace> f' \<lbrace> Q' \<rbrace>"
  assumes r1: "equiv_valid_2 D A A R' P P' f f'"
  shows "equiv_valid_2 D A A R (P and S) (P' and S') (liftE f >>=E g) (liftE f' >>=E g')"
  using assms by(blast intro: equiv_valid_2_liftE_bindE_general)

lemma equiv_valid_2_rvrel_imp:
  "\<lbrakk>equiv_valid_2 I A A R P P' f f'; \<And> s t. R s t \<Longrightarrow> R' s t\<rbrakk> \<Longrightarrow>
   equiv_valid_2 I A A R' P P' f f'"
  apply(fastforce simp: equiv_valid_2_def)
  done

subsection{* Specialised fixed-state state equivalence validity *}

text{*

For resolve_address_bits and rec_del: talk about a fixed initial
state. Note we only do this for one of the computations; the other
state can be constrained by how it is related to this one by @{term
"I"} and so forth.

Also captures the typical case where the relation between the return
values is equality and the required preconditions are identical.

wp can cope with this.

*}

definition
  spec_equiv_valid :: "'s \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s,'b) nondet_monad \<Rightarrow> bool"
where
  "spec_equiv_valid st I A B P f \<equiv> equiv_valid_2 I A B (op =) (P and (op = st)) P f f"

abbreviation spec_equiv_valid_inv where
  "spec_equiv_valid_inv st I A P f \<equiv> spec_equiv_valid st I A A P f"

subsection{* Specialised state equivalence validity *}

text{*

Most of the time we deal with the streamlined version.

wp can cope with this too.

*}

definition
  equiv_valid :: "('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s,'b) nondet_monad \<Rightarrow> bool"
where
  "equiv_valid I A B P f \<equiv> \<forall>st. spec_equiv_valid st I A B P f"

lemma equiv_valid_def2:
  "equiv_valid I A B P f = equiv_valid_2 I A B (op =) P P f f"
  by (simp add: equiv_valid_def spec_equiv_valid_def equiv_valid_2_def)

abbreviation equiv_valid_rv where
  "equiv_valid_rv I A B R P f \<equiv> equiv_valid_2 I A B R P P f f"

(* this is probably way more general than we need for all but a few special cases *)
lemma bind_ev_general:
  assumes reads_res_2: "\<And>rv. equiv_valid I B C (Q rv) (g rv)"
  assumes reads_res_1: "equiv_valid I A B P' f"
  assumes hoare: "\<lbrace> P'' \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid I A C (\<lambda>s. P' s \<and> P'' s) (f >>= g)"
  unfolding equiv_valid_def2
  apply (rule equiv_valid_2_bind_general[where R'="op ="])
     apply (auto intro: reads_res_1[unfolded equiv_valid_def2] reads_res_2[unfolded equiv_valid_def2])[2]
   apply (rule hoare)
  apply (rule hoare)
  done

lemma bind_ev:
  assumes reads_res_2: "\<And>rv. equiv_valid I A A (Q rv) (g rv)"
  assumes reads_res_1: "equiv_valid I A A P' f"
  assumes hoare: "\<lbrace> P'' \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid I A A (\<lambda>s. P' s \<and> P'' s) (f >>= g)"
  using assms by (blast intro: bind_ev_general)

lemma equiv_valid_guard_imp:
  assumes reads_res: "equiv_valid I A B Q f"
  assumes guard_imp: "\<And> s. P s \<Longrightarrow> Q s"
  shows "equiv_valid I A B P f"
  using assms by (fastforce simp: equiv_valid_def2 equiv_valid_2_def)

lemmas bind_ev_pre = bind_ev[THEN equiv_valid_guard_imp]

lemma gen_asm_ev':
  assumes "Q \<Longrightarrow> equiv_valid D A B P f"
  shows "equiv_valid D A B (P and K Q) f"
  using assms by (fastforce simp: equiv_valid_def2 equiv_valid_2_def)

declare K_def [simp del]

lemmas gen_asm_ev =
  gen_asm_ev'[where P="\<top>", simplified]
  gen_asm_ev'
  gen_asm_ev'[simplified K_def, where P="\<top>", simplified]
  gen_asm_ev'[simplified K_def]

declare K_def [simp]

text {*
  This is a further streamlined version that we expect to get the most from
  automating, and for the most part, we shouldn't need to deal with the
  extra generality of the properties above.
*}
abbreviation equiv_valid_inv where
  "equiv_valid_inv I A P f \<equiv> equiv_valid I A A P f"

abbreviation equiv_valid_rv_inv where
  "equiv_valid_rv_inv I A R P f \<equiv> equiv_valid_rv I A A R P f"

lemma get_evrv:
  "equiv_valid_rv_inv I A (I And A) \<top> get"
  by(auto simp: equiv_valid_2_def get_def)

lemma equiv_valid_rv_bind_general:
  assumes ev1:
  "equiv_valid_rv I A B W P f"
  assumes ev2:
  "\<And> rv rv'. W rv rv' \<Longrightarrow> equiv_valid_2 I B C R (Q rv) (Q rv') (g rv) (g rv')"
  assumes hoare:
  "\<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid_rv I A C R P (f >>= g)"
  apply(rule equiv_valid_2_guard_imp)
  apply(rule equiv_valid_2_bind_general[OF ev2])
       apply(assumption)
      apply(rule ev1)
     apply(rule hoare)
    apply(rule hoare)
   apply(simp_all)
  done

lemma equiv_valid_rv_bind:
  assumes ev1:
  "equiv_valid_rv_inv I A W P f"
  assumes ev2:
  "\<And> rv rv'. W rv rv' \<Longrightarrow> equiv_valid_2 I A A R (Q rv) (Q rv') (g rv) (g rv')"
  assumes hoare:
  "\<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid_rv_inv I A R P (f >>= g)"
  using assms by(blast intro: equiv_valid_rv_bind_general)

lemma modify_ev2:
  assumes "\<And> s t. \<lbrakk>I s t; A s t; P s; P' t\<rbrakk> \<Longrightarrow> R () () \<and> I (f s) (f' t) \<and> B (f s) (f' t)"
  shows
  "equiv_valid_2 I A B R P P' (modify f) (modify f')"
  apply(clarsimp simp: equiv_valid_2_def in_monad)
  using assms by auto

lemma put_ev2:
  assumes "\<And> s t. \<lbrakk>I s t; A s t; P s; P' t\<rbrakk> \<Longrightarrow> R () () \<and> I x x' \<and> B x x'"
  shows
  "equiv_valid_2 I A B R P P' (put x) (put x')"
  apply(clarsimp simp: equiv_valid_2_def in_monad)
  using assms by auto

lemma get_bind_ev2:
  assumes "\<And> rv rv'. \<lbrakk>I rv rv'; A rv rv'\<rbrakk> \<Longrightarrow> equiv_valid_2 I A B R (P and (op = rv)) (P' and (op = rv')) (f rv) (f' rv')"
  shows "equiv_valid_2 I A B R P P' (get >>= f) (get >>= f')"
  apply(rule equiv_valid_2_guard_imp)
  apply(rule_tac R'="I And A" in equiv_valid_2_bind_general)
       apply(rule assms, simp+)
      apply(rule get_evrv)
     apply(wp get_sp)+
   by(auto)

lemma return_ev_pre:
  "equiv_valid_inv I A P (return x)"
  apply (simp add: equiv_valid_def2 return_ev2)
  done

lemmas return_ev = return_ev_pre[where P=\<top>]

lemma fail_ev2_l:
  "equiv_valid_2 I A B R P P' fail f'"
  by(simp add: equiv_valid_2_def fail_def)

lemma fail_ev2_r:
  "equiv_valid_2 I A B R P P' f fail"
  by(simp add: equiv_valid_2_def fail_def)

lemma fail_ev_pre:
  "equiv_valid I A B P fail"
  apply (simp add: equiv_valid_def2 fail_ev2_l)
  done

lemmas fail_ev = fail_ev_pre[where P=\<top>]

lemma assert_ev2:
  "R () () \<Longrightarrow> equiv_valid_2 I A A R P P' (assert a) (assert b)"
  apply(simp add: assert_def fail_ev2_l fail_ev2_r)
  apply(blast intro: return_ev2)
  done

lemma liftE_ev:
  "equiv_valid I A B P f \<Longrightarrow> equiv_valid I A B P (liftE f)"
  unfolding liftE_def
  apply (rule bind_ev_general[THEN equiv_valid_guard_imp, OF return_ev _ wp_post_taut])
  apply fastforce+ (* schematic instantiation *)
  done

lemma if_ev:
  assumes "b \<Longrightarrow> equiv_valid I A B P f"
  assumes "\<not> b \<Longrightarrow> equiv_valid I A B Q g"
  shows "equiv_valid I A B (\<lambda>s. (b \<longrightarrow> P s) \<and> (\<not>b \<longrightarrow> Q s)) (if b then f else g)"
  apply (clarsimp split: if_split)
  using assms by blast

lemmas if_ev_pre = equiv_valid_guard_imp[OF if_ev]

lemma assert_ev_pre:
  "equiv_valid_inv I A P (assert b)"
  apply(simp add: equiv_valid_def2 assert_ev2)
  done

lemmas assert_ev = assert_ev_pre[where P=\<top>]

lemma assert_opt_ev:
  "equiv_valid_inv I A \<top> (assert_opt v)"
  apply (simp add: assert_opt_def return_ev fail_ev
            split: option.split)
  done

lemma assert_opt_ev2:
  assumes "\<And> a a'. \<lbrakk>v = Some a; v' = Some a'\<rbrakk> \<Longrightarrow> R a a'"
  shows "equiv_valid_2 I A A R \<top> \<top> (assert_opt v) (assert_opt v')"
  apply (simp add: assert_opt_def return_ev fail_ev2_l fail_ev2_r
            split: option.split)
  apply(intro allI impI)
  apply(rule return_ev2)
  apply(rule assms, assumption+)
  done

lemma select_f_ev:
  "equiv_valid_inv I A (K (det f)) (select_f (f x))"
  apply (rule gen_asm_ev)
  apply (simp add: select_f_def equiv_valid_def2 equiv_valid_2_def det_set_iff)
  done

lemma gets_evrv:
  "equiv_valid_rv_inv I A R (K (\<forall>s t. I s t \<and> A s t \<longrightarrow> R (f s) (f t))) (gets f)"
  apply (auto simp: equiv_valid_2_def in_monad)
  done

lemma gets_evrv':
  "equiv_valid_rv_inv I A R (\<lambda>s. (\<forall>t. I s t \<and> A s t \<longrightarrow> R (f s) (f t))) (gets f)"
  apply (auto simp: equiv_valid_2_def in_monad)
  done

lemma gets_evrv'':
  "\<forall>s t. I s t \<and> A s t \<and> P s \<and> P t \<longrightarrow> R (f s) (f t) \<Longrightarrow> equiv_valid_rv_inv I A R P (gets f)"
  apply (auto simp: equiv_valid_2_def in_monad)
  done

lemma equiv_valid_rv_guard_imp:
  "\<lbrakk>equiv_valid_rv I A B R P f; \<And> s. Q s \<Longrightarrow> P s\<rbrakk> \<Longrightarrow>
   equiv_valid_rv I A B R Q f"
  apply(simp add: equiv_valid_2_def)
  apply fast
  done

lemma gets_ev:
  shows "equiv_valid_inv I A (\<lambda> s. \<forall> s t. I s t \<and> A s t \<longrightarrow> f s = f t) (gets f)"
  apply (simp add: equiv_valid_def2)
  apply (auto intro: equiv_valid_rv_guard_imp[OF gets_evrv])
  done

lemma gets_ev':
  shows "equiv_valid_inv I A (\<lambda> s. \<forall> t. I s t \<and> A s t \<longrightarrow> f s = f t) (gets f)"
  apply (simp add: equiv_valid_def2)
  apply (auto intro: equiv_valid_rv_guard_imp[OF gets_evrv'])
  done

lemma gets_ev'':
  "\<forall>s t. I s t \<and> A s t \<and> P s \<and> P t \<longrightarrow> f s = f t \<Longrightarrow> equiv_valid_inv I A P (gets f)"
  apply (simp add: equiv_valid_def2)
  apply (auto intro: equiv_valid_rv_guard_imp[OF gets_evrv''])
  done

lemma gets_the_evrv:
  "equiv_valid_rv_inv I A R (K (\<forall>s t. I s t \<and> A s t \<longrightarrow> R (the (f s)) (the (f t)))) (gets_the f)"
  unfolding gets_the_def
  apply (rule equiv_valid_rv_bind)
    apply(rule equiv_valid_rv_guard_imp[OF gets_evrv])
    apply simp
   apply(rule assert_opt_ev2)
   apply simp
  apply wp
  done

lemma gets_the_ev:
  "equiv_valid_inv I A (K (\<forall>s t. I s t \<and> A s t \<longrightarrow> f s = f t)) (gets_the f)"
  unfolding equiv_valid_def2
  apply(rule equiv_valid_rv_guard_imp[OF gets_the_evrv])
  by simp

lemma throwError_ev_pre:
  "equiv_valid_inv I A P (throwError e)"
  by (auto simp: throwError_def return_ev_pre)

lemmas throwError_ev = throwError_ev_pre[where P=\<top>]

lemma returnOk_ev_pre:
  "equiv_valid_inv I A P (returnOk v)"
  by (auto simp: returnOk_def return_ev_pre)

lemmas returnOk_ev = returnOk_ev_pre[where P=\<top>]

(* this seems restrictive, to have the same beginning and ending state relation,
   however, one suspects that bindE is used usually only in code that doesn't
   modify the state, so is probably OK.. We'll see *)
lemma bindE_ev:
  assumes reads_res_2: "\<And> rv. equiv_valid_inv I A (Q rv) (g rv)"
  assumes reads_res_1: "equiv_valid_inv I A P' f"
  assumes hoare: "\<lbrace> P'' \<rbrace> f \<lbrace> Q \<rbrace>,-"
  shows "equiv_valid_inv I A (\<lambda>s. P' s \<and> P'' s) (f >>=E g)"
  unfolding bindE_def
  apply (rule bind_ev)
    prefer 3
    apply(rule hoare[unfolded validE_R_def validE_def])
   apply(simp split: sum.split add: lift_def throwError_ev)
   apply(blast intro!: reads_res_2)
  apply(rule reads_res_1)
  done

lemmas bindE_ev_pre = bindE_ev[THEN equiv_valid_guard_imp]

(* Of course, when we know that progress is always made, we can do better *)
lemma liftE_bindE_ev_general:
  assumes r2: "\<And> val. equiv_valid I B C (Q val) (g val)"
  assumes r1: "equiv_valid I A B P f"
  assumes hoare: "\<lbrace> R \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid I A C (\<lambda> s. P s \<and> R s) (liftE f >>=E g)"
  apply(simp add: bindE_def)
  apply(rule_tac Q="\<lambda> rv. K (\<forall> v. rv \<noteq> Inl v) and (\<lambda> s. \<forall> v. rv = Inr v \<longrightarrow> Q v s)" in bind_ev_general)
    prefer 2
    apply(rule liftE_ev)
    apply(rule r1)
   apply(insert r2, fastforce simp: lift_def split: sum.split simp: equiv_valid_def2 equiv_valid_2_def)[1]
  apply(insert hoare, fastforce simp: valid_def liftE_def return_def bind_def)
  done

lemma liftE_bindE_ev:
  assumes r2: "\<And> val. equiv_valid_inv I A (Q val) (g val)"
  assumes r1: "equiv_valid_inv I A P f"
  assumes hoare: "\<lbrace> R \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid_inv I A (\<lambda> s. P s \<and> R s) (liftE f >>=E g)"
  using assms by (blast intro: liftE_bindE_ev_general)

lemmas liftE_bindE_ev_pre = liftE_bindE_ev[THEN equiv_valid_guard_imp]

lemma liftM_ev:
  assumes reads_res: "equiv_valid I A B P g"
  shows "equiv_valid I A B P (liftM f g)"
  apply (simp add: liftM_def)
  apply (rule bind_ev_general[THEN equiv_valid_guard_imp, OF return_ev reads_res wp_post_taut])
  apply simp
  done

lemma liftME_ev:
  assumes reads_res: "equiv_valid_inv I A P g"
  shows "equiv_valid_inv I A P (liftME f g)"
  apply(simp add: liftME_def)
  apply (rule bindE_ev_pre[OF returnOk_ev reads_res])
  apply (rule hoare_True_E_R)
  apply fast
  done

lemma whenE_ev:
  assumes a: "b \<Longrightarrow> equiv_valid_inv I A P m"
  shows "equiv_valid_inv I A (\<lambda>s. b \<longrightarrow> P s) (whenE b m)"
  unfolding whenE_def by (auto intro: a returnOk_ev_pre)

lemma whenE_throwError_bindE_ev:
  assumes "\<And> rv. \<not> b \<Longrightarrow> equiv_valid_inv I A P (g rv)"
  shows "equiv_valid_inv I A P (whenE b (throwError e) >>=E g)"
  apply (rule_tac Q="\<lambda> rv. P and (\<lambda> s. \<not> b)" in bindE_ev_pre)
     apply (rule gen_asm_ev)
     apply (blast intro: assms)
    apply (rule whenE_ev)
    apply (rule throwError_ev)
   apply (wp whenE_throwError_wp)
  apply simp
  done

(* FIXME: trivially generalised *)
lemma K_bind_ev:
  "equiv_valid I A B P f \<Longrightarrow> equiv_valid I A B P (K_bind f x)"
  by simp

subsection{* wp setup *}

lemmas splits_ev[wp_split] =
  bind_ev_pre bindE_ev_pre
  bind_ev bindE_ev
  if_ev_pre
  if_ev

lemmas wp_ev[wp] =
  return_ev_pre
  return_ev
  liftE_ev
  fail_ev_pre
  fail_ev
  assert_opt_ev
  assert_ev
  gets_ev
  gets_the_ev
  returnOk_ev_pre
  returnOk_ev
  throwError_ev_pre
  throwError_ev
  liftM_ev
  liftME_ev
  whenE_ev
  K_bind_ev

subsection{* crunch setup *}

lemmas pre_ev =
  hoare_pre
  equiv_valid_guard_imp

subsection{* Tom instantiates wpc *}

lemma wpc_helper_equiv_valid:
  "equiv_valid D A B Q f \<Longrightarrow> wpc_helper (P, P') (Q, Q') (equiv_valid D A B P f)"
  using equiv_valid_guard_imp
  apply (simp add: wpc_helper_def)
  apply (blast)
  done

wpc_setup "\<lambda>m. equiv_valid D A B Q m" wpc_helper_equiv_valid

subsection{* More hoare-like rules *}

lemma mapM_ev_pre:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>"
  assumes inv_established: "\<And> s. P s \<Longrightarrow> I s"
  shows "equiv_valid_inv D A P (mapM m lst)"
  using assms
  apply(atomize)
  apply(rule_tac Q=I in equiv_valid_guard_imp)
  apply(induct lst)
    apply(simp add: mapM_Nil return_ev_pre)
   apply(subst mapM_Cons)
   apply(rule bind_ev_pre[where P''="I"])
    apply(rule bind_ev[OF return_ev])
    apply fastforce
    apply (rule wp_post_taut)
    apply fastforce+
  done

lemma mapM_x_ev_pre:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>"
  assumes inv_established: "\<And> s. P s \<Longrightarrow> I s"
  shows "equiv_valid_inv D A P (mapM_x m lst)"
  apply(subst mapM_x_mapM)
  apply(rule bind_ev_pre[OF return_ev mapM_ev_pre])
  apply (blast intro: reads_res invariant inv_established wp_post_taut)+
  done

lemma mapM_ev:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>"
  shows "equiv_valid_inv D A I (mapM m lst)"
  using assms by (auto intro: mapM_ev_pre)

lemma mapM_x_ev:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>"
  shows "equiv_valid_inv D A I (mapM_x m lst)"
  using assms by (auto intro: mapM_x_ev_pre)

(* MOVE -- proof clagged from mapM_x_mapM *)
lemma mapME_x_mapME:
  "mapME_x f l = mapME f l >>=E (\<lambda> y. returnOk ())"
  apply (simp add: mapME_x_def sequenceE_x_def mapME_def sequenceE_def)
  apply (induct l, simp_all add: Let_def bindE_assoc)
  done

lemma mapME_ev_pre:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>,-"
  assumes inv_established: "\<And> s. P s \<Longrightarrow> I s"
  shows "equiv_valid_inv D A P (mapME m lst)"
  using assms
  apply(atomize)
  apply(rule_tac Q=I in equiv_valid_guard_imp)
  apply(induct lst)
    apply(simp add: mapME_Nil returnOk_ev_pre)
   apply(subst mapME_Cons)
   apply wp
   apply fastforce
   apply (rule hoare_True_E_R[where P="\<top>"])
   apply fastforce+
  done

lemma mapME_ev:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv I A P (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> P \<rbrace> m x \<lbrace> \<lambda>_. P \<rbrace>, -"
  shows "equiv_valid_inv I A P (mapME m lst)"
  using assms by (auto intro: mapME_ev_pre)

lemma mapME_x_ev_pre:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>,-"
  assumes inv_established: "\<And> s. P s \<Longrightarrow> I s"
  shows "equiv_valid_inv D A P (mapME_x m lst)"
  unfolding mapME_x_mapME
  apply (wp assms mapME_ev_pre | simp)+
  done

lemma mapME_x_ev:
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (m x)"
  assumes invariant: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> I \<rbrace> m x \<lbrace> \<lambda>_. I \<rbrace>, -"
  shows "equiv_valid_inv D A I (mapME_x m lst)"
  using assms by (auto intro: mapME_x_ev_pre)

lemma mapM_ev':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (K (P x)) (m x)"
  shows "equiv_valid_inv D A (K (\<forall>x\<in>set lst. P x)) (mapM m lst)"
  apply(rule mapM_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res], simp+, wp)
  done

lemma mapM_x_ev':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (K (P x)) (m x)"
  shows "equiv_valid_inv D A (K (\<forall>x\<in>set lst. P x)) (mapM_x m lst)"
  apply(rule mapM_x_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res], simp+, wp)
  done

lemma mapME_ev':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (K (P x)) (m x)"
  shows "equiv_valid_inv D A (K (\<forall>x\<in>set lst. P x)) (mapME m lst)"
  apply(rule mapME_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res], simp+, wp)
  done

lemma mapME_x_ev':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (K (P x)) (m x)"
  shows "equiv_valid_inv D A (K (\<forall>x\<in>set lst. P x)) (mapME_x m lst)"
  apply(rule mapME_x_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res], simp+, wp)
  done

subsection{* Rules for the specialised validity *}

lemma use_spec_ev:
  "(\<And>st. spec_equiv_valid st I A B P f) \<Longrightarrow> equiv_valid I A B P f"
  by (simp add: equiv_valid_def)

lemma drop_spec_ev:
  "equiv_valid I A B P f \<Longrightarrow> spec_equiv_valid st I A B P f"
  by (simp add: equiv_valid_def)

lemma spec_equiv_valid_guard_imp:
  assumes reads_res: "spec_equiv_valid_inv s' I A P' f"
  assumes guard_imp: "\<And> s. P s \<Longrightarrow> P' s"
  shows "spec_equiv_valid_inv s' I A P f"
  using assms
  by (fastforce simp: spec_equiv_valid_def equiv_valid_2_def)

lemma bind_spec_ev:
  assumes reads_res_2: "\<And> rv s''. (rv, s'') \<in> fst (f s') \<Longrightarrow> spec_equiv_valid_inv s'' I A (Q rv) (g rv)"
  assumes reads_res_1: "spec_equiv_valid_inv s' I A P' f"
  assumes hoare: "\<lbrace>P''\<rbrace> f \<lbrace>Q\<rbrace>"
  shows "spec_equiv_valid_inv s' I A (\<lambda>s. P' s \<and> P'' s) (f >>= g)"
  using reads_res_1
  apply (clarsimp simp: spec_equiv_valid_def equiv_valid_2_def valid_def bind_def split_def)
  apply (erule_tac x=t in allE)
  apply clarsimp
  apply (erule_tac x="(a, b)" in ballE)
  apply (erule_tac x="(ab, bb)" in ballE)
  apply clarsimp
  apply (cut_tac rv="ab" and s''="b" in reads_res_2)
   apply assumption
  apply (clarsimp simp: spec_equiv_valid_def equiv_valid_2_def)
  apply(erule_tac x=bb in allE)
  using hoare
  apply (fastforce simp: valid_def)+
  done

lemma bindE_spec_ev:
  assumes reads_res_2: "\<And> rv s''. (Inr rv, s'') \<in> fst (f s') \<Longrightarrow> spec_equiv_valid_inv s'' I A (Q rv) (g rv)"
  assumes reads_res_1: "spec_equiv_valid_inv s' I A P' f"
  assumes hoare: "\<lbrace>P''\<rbrace> f \<lbrace>Q\<rbrace>,-"
  shows "spec_equiv_valid_inv s' I A (\<lambda>s. P' s \<and> P'' s) (f >>=E g)"
  unfolding bindE_def
  apply (rule bind_spec_ev)
    prefer 3
    apply(rule hoare[simplified validE_R_def validE_def])
   apply(simp split: sum.split add: lift_def)
   apply(rule conjI)
    apply(fastforce simp: spec_equiv_valid_def throwError_def return_ev2)
   apply(fastforce simp: reads_res_2)
  apply(rule reads_res_1)
  done

lemma if_spec_ev:
  "\<lbrakk> G \<Longrightarrow> spec_equiv_valid_inv s' I A P f;
     \<not> G \<Longrightarrow> spec_equiv_valid_inv s' I A P' f'
   \<rbrakk>  \<Longrightarrow> spec_equiv_valid_inv s' I A (\<lambda>s. (G \<longrightarrow> P s) \<and> (\<not> G \<longrightarrow> P' s)) (if G then f else f')"
  by (cases G, simp+)

lemmas splits_spec_ev[wp_split] =
  drop_spec_ev
  spec_equiv_valid_guard_imp[OF bind_spec_ev] spec_equiv_valid_guard_imp[OF bindE_spec_ev]
  bind_spec_ev bindE_spec_ev
  spec_equiv_valid_guard_imp[OF if_spec_ev] if_spec_ev

(* Miscellaneous rules. *)

lemma assertE_ev[wp]:
  "equiv_valid_inv I A \<top> (assertE b)"
  unfolding assertE_def
  apply wp
  by simp

lemma equiv_valid_2_bindE:
  assumes g: "\<And>rv rv'. R' rv rv' \<Longrightarrow>
      equiv_valid_2 D A A (E \<oplus> R) (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes h1: "\<lbrace>S\<rbrace> f \<lbrace>Q\<rbrace>,-"
  assumes h2: "\<lbrace>S'\<rbrace> f' \<lbrace>Q'\<rbrace>,-"
  assumes f: "equiv_valid_2 D A A (E \<oplus> R') P P' f f'"
  shows "equiv_valid_2 D A A (E \<oplus> R) (P and S) (P' and S') (f >>=E g) (f' >>=E g')"
  apply(unfold bindE_def)
  apply(rule equiv_valid_2_guard_imp)
    apply(rule_tac R'="E \<oplus> R'" and Q="case_sum \<top>\<top> Q" and Q'="case_sum \<top>\<top> Q'" and S=S and S'=S' in equiv_valid_2_bind)
       apply(clarsimp simp: lift_def split: sum.splits)
       apply(intro impI conjI allI)
          apply(simp add: throwError_def)
          apply(rule return_ev2)
          apply simp
         apply(simp)
        apply(simp)
       apply(fastforce intro: g)
      apply(rule f)
     apply(insert h1, fastforce simp: valid_def validE_R_def validE_def split: sum.splits)[1]
    apply(insert h2, fastforce simp: valid_def validE_R_def validE_def split: sum.splits)[1]
   by auto

lemma rel_sum_comb_equals:
  "((op =) \<oplus> (op =)) = (op =)"
  apply(rule ext)
  apply(rule ext)
  apply(rename_tac a b)
  apply(case_tac a, auto)
  done

definition spec_equiv_valid_2_inv where
  "spec_equiv_valid_2_inv s I A R P P' f f' \<equiv>
      equiv_valid_2 I A A R (P and (op = s)) P' f f'"

lemma spec_equiv_valid_def2:
  "spec_equiv_valid s I A A P f =
   spec_equiv_valid_2_inv s I A (op =) P P f f"
  apply(simp add: spec_equiv_valid_def spec_equiv_valid_2_inv_def)
  done

lemma drop_spec_ev2_inv:
  "equiv_valid_2 I A A R P P' f f' \<Longrightarrow>
   spec_equiv_valid_2_inv s I A R P P' f f'"
  apply(simp add: spec_equiv_valid_2_inv_def)
  apply(erule equiv_valid_2_guard_imp, auto)
  done

lemma spec_equiv_valid_2_inv_guard_imp:
  "\<lbrakk>spec_equiv_valid_2_inv s I A R Q Q' f f'; \<And> s. P s \<Longrightarrow> Q s; \<And> s. P' s \<Longrightarrow> Q' s\<rbrakk> \<Longrightarrow>
    spec_equiv_valid_2_inv s I A R P P' f f'"
  by(auto simp: spec_equiv_valid_2_inv_def equiv_valid_2_def)

lemma bind_spec_ev2:
  assumes reads_res_2: "\<And> rv s' rv'. \<lbrakk>(rv, s') \<in> fst (f s); R' rv rv'\<rbrakk> \<Longrightarrow> spec_equiv_valid_2_inv s' I A R (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes reads_res_1: "spec_equiv_valid_2_inv s I A R' P P' f f'"
  assumes hoare: "\<lbrace>S\<rbrace> f \<lbrace>Q\<rbrace>"
  assumes hoare': "\<lbrace>S'\<rbrace> f' \<lbrace>Q'\<rbrace>"
  shows "spec_equiv_valid_2_inv s I A R (P and S) (P' and S') (f >>= g) (f' >>= g')"
  using reads_res_1
  apply (clarsimp simp: spec_equiv_valid_2_inv_def equiv_valid_2_def bind_def split_def)
  apply (erule_tac x=t in allE)
  apply clarsimp
  apply (drule_tac x="(a, b)" in bspec, assumption)
  apply (drule_tac x="(ab, bb)" in bspec, assumption)
  apply clarsimp
  apply (cut_tac rv="a" and s'="b" in reads_res_2)
    apply assumption
   apply assumption
  apply (clarsimp simp: spec_equiv_valid_2_inv_def equiv_valid_2_def)
  apply(drule_tac x=bb in spec)
  apply clarsimp
  using hoare hoare'
  apply (fastforce simp: valid_def)+
  done

lemma spec_equiv_valid_2_inv_bindE:
  assumes g: "\<And>rv s' rv'. \<lbrakk>(Inr rv, s') \<in> fst (f s); R' rv rv'\<rbrakk> \<Longrightarrow>
      spec_equiv_valid_2_inv s' I A (E \<oplus> R) (Q rv) (Q' rv') (g rv) (g' rv')"
  assumes h1: "\<lbrace>S\<rbrace> f \<lbrace>Q\<rbrace>,-"
  assumes h2: "\<lbrace>S'\<rbrace> f' \<lbrace>Q'\<rbrace>,-"
  assumes f: "spec_equiv_valid_2_inv s I A (E \<oplus> R') P P' f f'"
  shows "spec_equiv_valid_2_inv s I A (E \<oplus> R) (P and S) (P' and S') (f >>=E g) (f' >>=E g')"
  apply(unfold bindE_def)
  apply(rule spec_equiv_valid_2_inv_guard_imp)
    apply(rule_tac R'="E \<oplus> R'" and Q="case_sum \<top>\<top> Q" and Q'="case_sum \<top>\<top> Q'" and S=S and S'=S' in bind_spec_ev2)
       apply(clarsimp simp: lift_def split: sum.splits)
       apply(intro impI conjI allI)
          apply(simp add: throwError_def)
          apply(rule drop_spec_ev2_inv[OF return_ev2])
          apply simp
         apply(simp)
        apply(simp)
       apply(fastforce intro: g)
      apply(rule f)
     apply(insert h1, fastforce simp: valid_def validE_R_def validE_def split: sum.splits)[1]
    apply(insert h2, fastforce simp: valid_def validE_R_def validE_def split: sum.splits)[1]
   by auto

lemma trancl_subset_equivalence:
  "\<lbrakk>(a, b) \<in> r'\<^sup>+; \<forall>x. (a, x)\<in>r'\<^sup>+ \<longrightarrow> Q x; \<forall>x y. Q x \<longrightarrow> ((y, x) \<in> r) = ((y, x) \<in> r')\<rbrakk> \<Longrightarrow> (a, b) \<in> r\<^sup>+"
  apply(induct a b rule: trancl.induct)
   apply(blast)
  apply(simp)
  apply(rule_tac b=b in trancl_into_trancl)
   apply(simp)
  apply(erule_tac x=c in allE)
  apply(subgoal_tac "(a, c) \<in> r'\<^sup>+")
   apply(auto)
   done

lemma equiv_valid_rv_gets_compD:
  "equiv_valid_rv_inv I A R P (gets (f \<circ> g)) \<Longrightarrow>
   equiv_valid_rv_inv I A (\<lambda> rv rv'. R (f rv) (f rv')) P (gets g)"
  apply(clarsimp simp: equiv_valid_2_def gets_def bind_def return_def get_def)
  done

lemma liftE_ev2:
  "equiv_valid_2 I A B R P P' f f' \<Longrightarrow>
   equiv_valid_2 I A B (E \<oplus> R) P P' (liftE f) (liftE f')"
  apply(clarsimp simp: liftE_def equiv_valid_2_def bind_def return_def)
  apply fastforce
  done

lemma whenE_spec_ev2_inv:
  assumes a: "b \<Longrightarrow> spec_equiv_valid_2_inv s I A R P P' m m'"
  assumes r: "\<And> x. R x x"
  shows "spec_equiv_valid_2_inv s I A R P P' (whenE b m) (whenE b m')"
  unfolding whenE_def
  apply (auto intro: a simp: returnOk_def intro!: drop_spec_ev2_inv[OF return_ev2] intro: r)
  done

lemma whenE_spec_ev:
  assumes a: "b \<Longrightarrow> spec_equiv_valid_inv s I A P m"
  shows "spec_equiv_valid_inv s I A P  (whenE b m) "
  unfolding whenE_def
  apply (auto intro: a simp: returnOk_def intro!: drop_spec_ev[OF return_ev_pre])
  done

lemma spec_equiv_valid_2_inv_by_spec_equiv_valid:
  "\<lbrakk>spec_equiv_valid s I A A P f; P' = P; f' = f;
    (\<And> a. R a a)\<rbrakk> \<Longrightarrow>
       spec_equiv_valid_2_inv s I A R P P' f f'"
  apply(clarsimp simp: spec_equiv_valid_def spec_equiv_valid_2_inv_def)
  apply(fastforce simp: equiv_valid_2_def)
  done

lemma mapM_ev'':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (P x) (m x)"
  assumes inv: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> \<lambda>s. \<forall>x\<in>set lst. P x s \<rbrace> m x \<lbrace> \<lambda>_ s. \<forall>x\<in>set lst. P x s \<rbrace>"
  shows "equiv_valid_inv D A (\<lambda> s. \<forall>x\<in>set lst. P x s) (mapM m lst)"
  apply(rule mapM_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res]; simp)
  apply(wpsimp wp: inv)
  done

lemma mapM_x_ev'':
  assumes reads_res: "\<And> x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A (P x) (m x)"
  assumes inv: "\<And> x. x \<in> set lst \<Longrightarrow> \<lbrace> \<lambda>s. \<forall>x\<in>set lst. P x s \<rbrace> m x \<lbrace> \<lambda>_ s. \<forall>x\<in>set lst. P x s \<rbrace>"
  shows "equiv_valid_inv D A (\<lambda> s. \<forall>x\<in>set lst. P x s) (mapM_x m lst)"
  apply(rule mapM_x_ev)
  apply(rule equiv_valid_guard_imp[OF reads_res]; simp)
  apply(wpsimp wp: inv)
  done

lemma catch_ev[wp]:
  assumes ok:
    "equiv_valid I A A P f"
  assumes err:
    "\<And> e. equiv_valid I A A (E e) (handler e)"
  assumes hoare:
    "\<lbrace> P \<rbrace> f -, \<lbrace> E \<rbrace>"
  shows
  "equiv_valid I A A P (f <catch> handler)"
  apply(simp add: catch_def)
  apply (wp err ok | wpc | simp)+
   apply(insert hoare[simplified validE_E_def validE_def])[1]
   apply(simp split: sum.splits)
  by simp

lemma equiv_valid_rv_trivial:
  assumes inv: "\<And> P. \<lbrace> P \<rbrace> f \<lbrace> \<lambda>_. P \<rbrace>"
  shows "equiv_valid_rv_inv I A \<top>\<top> \<top> f"
  by(auto simp: equiv_valid_2_def dest: state_unchanged[OF inv])

lemma equiv_valid_2_trivial:
  assumes inv: "\<And> P. \<lbrace> P \<rbrace> f \<lbrace> \<lambda>_. P \<rbrace>"
  assumes inv': "\<And> P. \<lbrace> P \<rbrace> f' \<lbrace> \<lambda>_. P \<rbrace>"
  shows "equiv_valid_2 I A A \<top>\<top> \<top> \<top> f f'"
  by(auto simp: equiv_valid_2_def dest: state_unchanged[OF inv] state_unchanged[OF inv'])

lemma gen_asm_ev2_r:
  "\<lbrakk>P' \<Longrightarrow> equiv_valid_2 I A B R P Q f f'\<rbrakk> \<Longrightarrow>
   equiv_valid_2 I A B R P  (Q and (K P')) f f'"
  apply(fastforce simp: equiv_valid_2_def)
  done

lemma gen_asm_ev2_l:
  "\<lbrakk>P \<Longrightarrow> equiv_valid_2 I A B R Q P' f f'\<rbrakk> \<Longrightarrow>
   equiv_valid_2 I A B R (Q and (K P)) P' f f'"
  apply(fastforce simp: equiv_valid_2_def)
  done

lemma gen_asm_ev2_r':
  "\<lbrakk>P' \<Longrightarrow> equiv_valid_2 I A B R P \<top> f f'\<rbrakk> \<Longrightarrow>
   equiv_valid_2 I A B R P (\<lambda>s. P') f f'"
  apply(fastforce simp: equiv_valid_2_def)
  done

lemma gen_asm_ev2_l':
  "\<lbrakk>P \<Longrightarrow> equiv_valid_2 I A B R \<top> P' f f'\<rbrakk> \<Longrightarrow>
   equiv_valid_2 I A B R (\<lambda>s. P) P' f f'"
  apply(fastforce simp: equiv_valid_2_def)
  done

lemma equiv_valid_rv_liftE_bindE:
  assumes ev1:
  "equiv_valid_rv_inv I A W P f"
  assumes ev2:
  "\<And> rv rv'. W rv rv' \<Longrightarrow> equiv_valid_2 I A A R (Q rv) (Q rv') (g rv) (g rv')"
  assumes hoare:
  "\<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
  shows "equiv_valid_rv_inv I A R P ((liftE f) >>=E g)"
  apply(unfold bindE_def)
  apply(rule_tac Q="\<lambda> rv. K (\<forall> v. rv \<noteq> Inl v) and (\<lambda> s. \<forall> v. rv = Inr v \<longrightarrow> Q v s)" in equiv_valid_rv_bind)
    apply(rule_tac E="dc" in equiv_valid_2_liftE)
    apply(rule ev1)
   apply(clarsimp simp: lift_def split: sum.split)
   apply(insert ev2, fastforce simp: equiv_valid_2_def)[1]
  apply(insert hoare, clarsimp simp: valid_def liftE_def bind_def return_def split_def)
  done

lemma if_evrv:
  assumes "b \<Longrightarrow> equiv_valid_rv_inv I A R P f"
  assumes "\<not> b \<Longrightarrow> equiv_valid_rv_inv I A R Q g"
  shows "equiv_valid_rv_inv I A R (\<lambda>s. (b \<longrightarrow> P s) \<and> (\<not>b \<longrightarrow> Q s)) (if b then f else g)"
  apply (clarsimp split: if_split)
  using assms by blast

end


section \<open>Single-Invocation Corrrectness\<close>

theory single_invocation_correctness
  imports execution_invariants_s fixedpoints execution_invariants invContext_simps
    state_monotonicGrowth_invariants
begin

text \<open>This theory includes techniques to prove that a program is correct in the single-invocId semantics.\<close>

text \<open>
  Start with initial state,

  then steps

  finally return and last check

  somehow automated

\<close>

fun updateHb where
  updateHb_nil: "updateHb hb vis [] = hb"
| updateHb_cons[simp del]: "updateHb hb vis (c#cs) = updateHb (hb \<union> vis \<times> {c}) (insert c vis) cs"

lemma updateHb_single: "updateHb hb vis [c] = hb \<union> vis \<times> {c}"
  by (simp add: updateHb_cons)

lemma updateHb_chain:
  assumes "vis' = set cs \<union> vis"
  shows "updateHb (updateHb hb vis cs) vis' [c] = updateHb hb vis (cs@[c])"
using assms apply (induct cs arbitrary: hb vis vis' c )
  by (fastforce simp add:  updateHb_cons)+

lemma updateHb_simp1:
  assumes "x \<notin> set cs"
  shows "(x,y) \<in> updateHb hb vis cs \<longleftrightarrow> ((x,y) \<in> hb \<or> x\<in>vis \<and> y \<in> set cs)"
  using assms proof (induct cs arbitrary: hb vis)
  case Nil
  then show ?case by simp
next
  case (Cons a cs)
  then show ?case
    by (auto simp add: updateHb_cons)
qed

lemma updateHb_simp2:
  assumes "y \<notin> set cs"
  shows "(x,y) \<in> updateHb hb vis cs \<longleftrightarrow> (x,y) \<in> hb"
  using assms proof (induct cs arbitrary: hb vis)
  case Nil
  then show ?case by simp
next
  case (Cons a cs)
  then show ?case
    by (auto simp add: updateHb_cons)
qed

lemma updateHb_in_vis:
  assumes
    "x\<in>vis"
    and "y\<in>set cs"
   shows "(x,y) \<in> updateHb hb vis cs"
  using assms proof (induct cs arbitrary: hb vis)
  case Nil
  then show ?case by simp
next
  case (Cons a cs)
  then show ?case
    apply (auto simp add: updateHb_cons  )
    by (metis UnI2 insert_is_Un mem_Sigma_iff singletonI updateHb_simp2)
qed

lemma updateHb_simp3:
  assumes
    "cs!i = x"
    and "cs!j = y"
    and "i<j"
    and "j<length cs"
   shows "(x,y) \<in> updateHb hb vis cs"
  using assms proof (induct cs arbitrary: hb vis i j)
  case Nil
  then show ?case by simp
next
  case (Cons a cs)
  then show ?case
    apply (auto simp add: updateHb_cons in_set_conv_nth nth_Cons' )
    by (simp add: updateHb_in_vis)
qed

lemma updateHb_simp_distinct:
  assumes
    "distinct cs"
  shows "(x,y) \<in> updateHb hb vis cs
  \<longleftrightarrow> ((x, y)\<in>hb \<or> x\<in>vis \<and> y\<in>set cs \<or> (\<exists>i j. cs!i=x \<and> cs!j=y \<and> i < j \<and> j < length cs))"
  using assms proof (induct cs arbitrary: hb vis)
  case Nil
  then show ?case by simp
next
  case (Cons a cs)

  have IH:
    "(x,y) \<in> updateHb (hb \<union> vis \<times> {a}) (insert a vis) cs
\<longleftrightarrow> ((x, y)\<in>(hb \<union> vis \<times> {a}) \<or> x\<in>(insert a vis) \<and> y\<in>set cs \<or> (\<exists>i j. cs!i=x \<and> cs!j=y \<and> i < j \<and> j < length cs))"
    apply (rule Cons) using Cons.prems by auto

  show ?case
    apply (auto simp add: updateHb_cons IH )
    apply (metis One_nat_def in_set_conv_nth list.sel(3) not_less_eq nth_Cons_0 nth_Cons_pos nth_tl zero_less_Suc)
    apply (metis One_nat_def Suc_mono diff_Suc_1 nth_Cons_Suc)
    apply (metis One_nat_def Suc_less_eq Suc_pred nat_neq_iff not_less_zero nth_Cons')
    by (metis One_nat_def diff_Suc_1 gr_implies_not0 less_Suc_eq_0_disj nth_Cons')
qed

lemma updateHb_simp_distinct2:
  shows "(x,y) \<in> updateHb hb vis cs
  \<longleftrightarrow> ((x, y)\<in>hb
      \<or> x\<in>vis \<and> y\<in>set cs
      \<or> before_in_list cs x y)"
proof (induct cs arbitrary: hb vis)
  case Nil
  then show ?case by auto
next
case (Cons a cs)
  show ?case
    by (auto simp add: updateHb_cons before_in_list_cons updateHb_simp2 Cons.hyps before_in_list_contains_r)
qed

lemma updateHb_simp_split:
"updateHb hb vis cs = hb \<union> updateHb {} vis cs"
proof (induct cs arbitrary: hb vis)
  case Nil
  then show ?case
    by simp
next
  case (Cons a cs)

  have "updateHb hb vis (a # cs)
      = updateHb (hb \<union> vis \<times> {a}) (insert a vis) cs"
    by (simp add: updateHb_cons)
  also have "... = (hb \<union> vis \<times> {a}) \<union> updateHb {} (insert a vis) cs"
    by (meson Cons.hyps)
  also have "... = hb \<union> updateHb (vis \<times> {a}) (insert a vis) cs"
    using Cons.hyps by blast
  also have "... = hb \<union> updateHb {} vis (a # cs) "
    by (simp add: updateHb_cons)
  finally show ?case .
qed

lemma snd_updateHb:
"snd ` updateHb hb vis cs \<subseteq> snd ` hb \<union> set cs"
  by (smt UnI1 UnI2 image_eqI image_subset_iff prod.collapse updateHb_simp2)

lemma snd_updateHb2:
"snd ` updateHb {} vis cs \<subseteq> set cs"
  using snd_updateHb by fastforce

abbreviation invariant_all' :: "('proc, 'ls, 'op, 'any) state \<Rightarrow> bool" where
"invariant_all' state \<equiv>  invariant (prog state) (invContext' state)"

lemma use_map_le:
  assumes "m x \<triangleq> y" and "m  \<subseteq>\<^sub>m m'"
  shows "m' x \<triangleq> y"
  using assms
  by (metis domI map_le_def)

lemma has_invocOp_forever:
  assumes steps: "S ~~ (i, trace) \<leadsto>\<^sub>S* S'"
    and "invocOp S i \<triangleq> info"
  shows "invocOp S' i \<triangleq> info"

  using assms proof (induct rule: step_s_induct)
  case initial
  then show ?case by auto
next
  case (step tr S' a S'')
  then have i1: "invocOp S i \<triangleq> info" and  i2: "invocOp S' i \<triangleq> info"
    by auto

  from \<open>S' ~~ (i, a) \<leadsto>\<^sub>S S''\<close>
  show ?case
  proof (induct rule: step_s.cases)
    case (local C s ls f ls')
    then show ?case using i2 by (auto simp add: step_s.simps state_monotonicGrowth_def elim: use_map_le )

  next
    case (newId C s ls f ls' uid)
    then show ?case using i2 by (auto simp add: step_s.simps state_monotonicGrowth_def elim: use_map_le )
  next
    case (beginAtomic C s ls f ls' t C' C'' vis vis' )
    then show ?case using i2 state_monotonicGrowth_invocOp[OF \<open>state_monotonicGrowth s C C'\<close>]
      by (auto simp add: step_s.simps state_monotonicGrowth_def elim: use_map_le )
  next
    case (endAtomic C s ls f ls' t C' valid)
    then show ?case using i2 by (auto simp add: step_s.simps state_monotonicGrowth_def elim: use_map_le )
  next
    case (dbop C s ls f Op  ls' t c res vis)
    then show ?case using i2 by (auto simp add: step_s.simps state_monotonicGrowth_def elim: use_map_le )
  next
    case (invocation C s procName  initState impl C' C'' valid)
    then show ?case using i2 by (auto simp add: step_s.simps state_monotonicGrowth_def elim: use_map_le )
  next
    case (return C s ls f res C' valid)
    then show ?case using i2 by (auto simp add: step_s.simps state_monotonicGrowth_def elim: use_map_le )
  qed

qed

lemma has_invocOp_afterOneStep:
  assumes step: "S ~~ (i, a) \<leadsto>\<^sub>S S'"
    and wf: "state_wellFormed_s S i"
  shows "invocOp S' i \<noteq> None"
  using step wf by (auto simp add: step_s.simps wf_s_localState_to_invocOp2,
    meson state_monotonicGrowth_invocOp wf_s_localState_to_invocOp2)

lemma has_invocOp_afterStart:
  assumes steps: "S ~~ (i, trace) \<leadsto>\<^sub>S* S'"
    and notEmpty: "trace \<noteq> []"
    and wf: "state_wellFormed_s S i"
  shows "invocOp S' i \<noteq> None"
  using steps notEmpty wf proof (induct rule: step_s_induct)
  case initial
  then show ?case
    by simp
next
  case (step tr S a S')
  have "state_wellFormed_s S i"
    using local.wf state_wellFormed_s_def step.step steps_s_append by blast

  from \<open>S ~~ (i, a) \<leadsto>\<^sub>S S'\<close> and \<open>state_wellFormed_s S i\<close>
  show ?case
    by (rule has_invocOp_afterOneStep)
qed

lemma invocations_only_in_beginning:
  assumes steps: "S ~~ (i, trace) \<leadsto>\<^sub>S* S'"
    and wf: "state_wellFormed_s S i"
    and notStarted: "invocOp S i = None"
    and traceLen: "j < length trace"
  shows "isAInvoc (fst (trace ! j)) \<longleftrightarrow> j = 0"
proof -

  from steps
  obtain S_mid where "S ~~ (i, take j trace) \<leadsto>\<^sub>S* S_mid" and "S_mid ~~ (i, drop j trace) \<leadsto>\<^sub>S* S'"
    using steps_s_append_simp by force

  obtain Sa where firstStep: "S ~~ (i, hd trace) \<leadsto>\<^sub>S Sa" and afterFirstStep: "Sa ~~ (i, tl trace) \<leadsto>\<^sub>S* S'"
    by (metis Cons_nth_drop_Suc append.assoc append_take_drop_id hd_Cons_tl snoc_eq_iff_butlast steps steps_s_cons_simp traceLen)

  with notStarted
  have startsWithInvoc: "isAInvoc (fst (hd trace))"
    by (auto simp add: step_s.simps isAInvoc_def local.wf wf_s_localState_to_invocOp)

  {
    assume "j = 0"
    then have "isAInvoc (fst (trace ! j))"
      using startsWithInvoc hd_drop_conv_nth traceLen by force
  }
  moreover
  {
    assume "j \<noteq> 0"

    from afterFirstStep
    obtain Sc where steps_until_after_j: "Sa ~~ (i, take j (tl trace)) \<leadsto>\<^sub>S* Sc"
      by (metis append_take_drop_id steps_s_append_simp)

\<comment> \<open>get Sb so that S Sa Sb S\<close>
    from steps_until_after_j
    have "Sa ~~ (i, (take (j-1) (tl trace))@[trace!j]) \<leadsto>\<^sub>S* Sc"
      by (metis \<open>j \<noteq> 0\<close> drop_Nil drop_eq_Nil hd_drop_conv_nth leD take_eq_Nil take_hd_drop take_tl tl_append2 tl_take traceLen)
    from this
    obtain Sb
      where steps1: "Sa ~~ (i, take (j-1) (tl trace)) \<leadsto>\<^sub>S* Sb"
        and step_j: "Sb ~~ (i, trace ! j) \<leadsto>\<^sub>S Sc"
      by (auto simp add: steps_s_append_simp steps_s_single)

    have "invocOp Sa i \<noteq> None"
      using firstStep has_invocOp_afterOneStep local.wf by blast

    then have "invocOp Sb i \<noteq> None"
      using has_invocOp_forever steps1 by blast

    with step_j
    have "\<not>isAInvoc (fst (trace ! j))"
      by (auto simp add: step_s.simps isAInvoc_def)
  }
  ultimately
  show "isAInvoc (fst (trace ! j)) \<longleftrightarrow> j = 0"
    by blast
qed

lemma initialState_noTxns1:
  assumes initS: "S \<in> initialStates program i"
  shows "txStatus S tx \<noteq> Some Uncommitted"
  using initS by (auto simp add: initialStates_def)

lemma initialState_noTxns2:
  assumes initS: "S \<in> initialStates program i"
  shows "currentTx S i' = None"
  using initS by (auto simp add: initialStates_def,
      meson option.exhaust wellFormed_currentTx_unique_h(2))

lemma steps_s_noOtherTx:
  assumes steps: "initS ~~ (i, trace) \<leadsto>\<^sub>S* S_fin"
    and initS: "initS \<in> initialStates program i"
    and "i' \<noteq> i"
  shows "currentTx S_fin i' = None"
  using steps proof (induct rule: step_s_induct)
  case initial
  from initS
  show "currentTx initS i' = None"
    using initialState_noTxns2 by auto

next
  case (step tr S a S')

  from \<open>S ~~ (i, a) \<leadsto>\<^sub>S S'\<close>
  show ?case
    using \<open>i' \<noteq> i\<close> by (auto simp add: step_s.simps \<open>currentTx S i' = None\<close>,
        (meson option.exhaust wellFormed_currentTx_unique_h(2))+)
qed

lemma state_wellFormed_combine1:
  assumes "state_wellFormed S"
  and "S ~~ (i, a) \<leadsto> S'"
  and "a\<noteq>ACrash"
shows "state_wellFormed S'"
  using \<open>state_wellFormed S\<close> proof (rule state_wellFormed_combine)
  from \<open>S ~~ (i, a) \<leadsto> S'\<close>
  show "S ~~ [(i,a)] \<leadsto>* S'"
    by (simp add: steps_single)
  show "\<And>ia. (ia, ACrash) \<notin> set [(i, a)]"
    using \<open>a\<noteq>ACrash\<close> by simp
qed

lemma state_wellFormed_combine_s1:
  assumes "state_wellFormed S"
  and "S ~~ (i, a) \<leadsto>\<^sub>S S'"
shows "state_wellFormed S'"
proof -

from \<open>S ~~ (i, a) \<leadsto>\<^sub>S S'\<close>
  show "state_wellFormed S'"
  proof (induct rule: step_s.cases)
    case (local C s ls f ok ls')
    then have "S ~~ (i, ALocal ok) \<leadsto> S'"
      by (auto simp add: step.simps)
    with \<open>state_wellFormed S\<close> show ?case
      by (rule state_wellFormed_combine1, simp)
  next
    case (newId C s ls f ls' uid uidv ls'')
    then have "S ~~ (i, ANewId uidv) \<leadsto> S'"
      by (auto simp add: step.simps)
    with \<open>state_wellFormed S\<close> show ?case
      by (rule state_wellFormed_combine1, simp)
  next
    case (beginAtomic C s ls f ls' t C' vis vis' newTxns )
    then show ?case
      by blast
  next
    case (endAtomic C s ls f ls' t C' valid)
    then have "S ~~ (i, AEndAtomic) \<leadsto> S'"
      by (auto simp add: step.simps)
    with \<open>state_wellFormed S\<close> show ?case
      by (rule state_wellFormed_combine1, simp)
  next
    case (dbop C s ls f Op ls' t c res vis)
    then have "S ~~ (i, ADbOp c Op res) \<leadsto> S'"
      by (auto simp add: step.simps)
    with \<open>state_wellFormed S\<close> show ?case
      by (rule state_wellFormed_combine1, simp)
  next
    case (invocation C s proc initState impl C' C'' valid)
    then have "C' ~~ (i, AInvoc proc) \<leadsto> C''"
      by (auto simp add: step.simps,
        insert wf_localState_to_invocOp, blast+)

    then show ?case
      using \<open>state_wellFormed C'\<close> \<open>S' = C''\<close> state_wellFormed_combine1 by blast
  next
    case (return C s ls f res C' valid)
    then have "S ~~ (i, AReturn res) \<leadsto> S'"
      by (auto simp add: step.simps)
    with \<open>state_wellFormed S\<close> show ?case
      by (rule state_wellFormed_combine1, simp)
  qed
qed

lemma committedCalls_allCommitted:
  assumes wf: "state_wellFormed S"
    and noUncommitted: "\<And>t. txStatus S t \<noteq> Some Uncommitted"
  shows "committedCalls S = dom (calls S)"
proof (auto simp add: committedCallsH_def isCommittedH_def )

  show "\<exists>y. calls S x \<triangleq> y"
    if c0: "callOrigin S x \<triangleq> tx"
      and c1: "txStatus S tx \<triangleq> Committed"
    for  x tx
    using that  by (simp add: domD domIff local.wf wellFormed_callOrigin_dom3)

  show "\<exists>tx. callOrigin S x \<triangleq> tx \<and> txStatus S tx \<triangleq> Committed"
    if c0: "calls S x \<triangleq> y"
    for  x y
  proof -
    obtain tx where "callOrigin S x \<triangleq> tx"
      using c0 local.wf wellFormed_callOrigin_dom3 by force

    moreover have "txStatus S tx \<triangleq> Committed"
      by (metis (full_types) \<open>callOrigin S x \<triangleq> tx\<close> domD domIff local.wf noUncommitted txStatus.exhaust wf_no_txStatus_origin_for_nothing)

    ultimately show "\<exists>tx. callOrigin S x \<triangleq> tx \<and> txStatus S tx \<triangleq> Committed"
      by blast
  qed
qed

lemma invContextH_same_allCommitted:
  assumes  wf1: "\<And>c. (state_calls c = None) \<longleftrightarrow> (state_callOrigin c = None)"
    and wf2: "\<And>c tx. state_callOrigin c \<triangleq> tx \<Longrightarrow> state_txStatus tx \<noteq> None"
    and wf3: "\<And>a b. (a, b) \<in> state_happensBefore \<Longrightarrow> state_calls a \<noteq> None"
    and wf4: "\<And>a b. (a, b) \<in> state_happensBefore \<Longrightarrow> state_calls b \<noteq> None"
    and wf5: "\<And>c. (state_txOrigin c = None) \<longleftrightarrow> (state_txStatus c = None)"
    and noUncommitted: "\<And>t. state_txStatus t \<noteq> Some Uncommitted"
  shows "invContextH state_callOrigin state_txOrigin state_txStatus state_happensBefore state_calls state_knownIds state_invocOp state_invocRes
       = invContextH2 state_callOrigin state_txOrigin state_txStatus state_happensBefore state_calls state_knownIds state_invocOp state_invocRes"
proof (auto simp add: invContextH_def invContextH2_def
  committedCallsH_def isCommittedH_def restrict_map_def restrict_relation_def
   intro!: ext)
  show "\<And>x. \<forall>tx. state_callOrigin x \<triangleq> tx \<longrightarrow> state_txStatus tx \<noteq> Some Committed \<Longrightarrow> None = state_calls x"
    by (metis (full_types) noUncommitted option.exhaust_sel txStatus.exhaust wf1 wf2)
  show "\<And>a b. (a, b) \<in> state_happensBefore \<Longrightarrow> \<exists>tx. state_callOrigin a \<triangleq> tx \<and> state_txStatus tx \<triangleq> Committed"
    by (metis (full_types) noUncommitted option.exhaust txStatus.exhaust wf1 wf2 wf3)
  show "\<And>a b. (a, b) \<in> state_happensBefore \<Longrightarrow> \<exists>tx. state_callOrigin b \<triangleq> tx \<and> state_txStatus tx \<triangleq> Committed"
    by (metis (full_types) noUncommitted option.exhaust txStatus.exhaust wf1 wf2 wf4)
  show "\<And>x. \<forall>tx. state_callOrigin x \<triangleq> tx \<longrightarrow> state_txStatus tx \<noteq> Some Committed \<Longrightarrow> None = state_callOrigin x"
    by (metis (full_types) noUncommitted option.exhaust_sel txStatus.exhaust wf2)
  show "\<And>x. state_txStatus x \<noteq> Some Committed \<Longrightarrow> None = state_txOrigin x"
    by (metis noUncommitted option.exhaust_sel txStatus.exhaust wf5)
qed

lemmas invContextH_same_allCommitted' = invContextH_same_allCommitted[simplified invContextH2_def]

lemma invContext_same_allCommitted:
  assumes  wf: "state_wellFormed S"
    and noUncommitted: "\<And>t. txStatus S t \<noteq> Some Uncommitted"
  shows "invContext S
       = invContext' S"
proof (rule invContextH_same_allCommitted)
  show "\<And>c. (calls S c = None) = (callOrigin S c = None)"
  using local.wf wellFormed_callOrigin_dom3 by blast
    show "\<And>c tx. callOrigin S c \<triangleq> tx \<Longrightarrow> txStatus S tx \<noteq> None"
      by (simp add: local.wf wellFormed_state_callOrigin_txStatus)
   show "\<And>a b. (a, b) \<in> happensBefore S \<Longrightarrow> calls S a \<noteq> None"
     by (simp add: local.wf wellFormed_happensBefore_calls_l)
   show "\<And>a b. (a, b) \<in> happensBefore S \<Longrightarrow> calls S b \<noteq> None"
     by (simp add: local.wf wellFormed_happensBefore_calls_r)
   show "\<And>c. (txOrigin S c = None) = (txStatus S c = None)"
     by (simp add: local.wf wf_transaction_status_iff_origin)
   show "\<And>t. txStatus S t \<noteq> Some Uncommitted"
     using noUncommitted by blast
 qed

lemmas invContext_same_allCommitted' = invContext_same_allCommitted[simplified invContextH2_def]

lemma wf_localState_currentProc_m:
  assumes "S ~~ tr \<leadsto>* S'"
    and "(localState S i = None \<longleftrightarrow> currentProc S i = None)"
  shows "(localState S' i = None \<longleftrightarrow> currentProc S' i = None)"
  using assms proof (induct rule: steps_induct)
  case initial
  then show ?case by (simp add: initialState_def)
next
  case (step S' tr a S'')
  then show ?case  by (auto simp add: step.simps split: if_splits)
qed

lemma wf_localState_currentProc:
  assumes "state_wellFormed S"
  shows "localState S i = None \<longleftrightarrow> currentProc S i = None"
  using assms proof (induct rule: wellFormed_induct)
  case initial
  then show ?case by (simp add: initialState_def)
next
  case (step t a s)
  then show ?case
    by (auto simp add: step.simps split: if_splits)
qed

lemma show_exists_state:
  fixes P :: "('proc, 'ls, 'op, 'any)state \<Rightarrow> bool"
  assumes "\<exists>calls happensBefore prog callOrigin txOrigin
   generatedIds knownIds invocOp invocRes txStatus
localState currentProc visibleCalls currentTx. P \<lparr>
  calls = calls,
  happensBefore = happensBefore,
  callOrigin  = callOrigin,
  txOrigin  = txOrigin,
  knownIds  = knownIds,
  invocOp  =invocOp,
  invocRes =invocRes,
  prog = prog,
  txStatus  =txStatus,
  generatedIds  = generatedIds,
  localState  =localState,
  currentProc  =currentProc,
  visibleCalls  =visibleCalls,
  currentTx  = currentTx
 \<rparr>"
  shows "\<exists>S. P S"
  using assms by auto

lemma exists_narrowL1: "(\<exists>x. P x \<and> Q) \<longleftrightarrow> (\<exists>x. P x) \<and> Q"
  by auto

lemma exists_narrowL2: "(\<exists>x y. P x y \<and> Q y) \<longleftrightarrow> (\<exists>y. (\<exists>x. P x y) \<and> Q y)"
  by auto

lemma exists_narrowL3: "(\<exists>x y1 y2. P x y1 y2 \<and> Q y1 y2) \<longleftrightarrow> (\<exists>y1 y2. (\<exists>x. P x y1 y2) \<and> Q y1 y2)"
  by auto

lemma exists_narrowL4: "(\<exists>x y1 y2 y3. P x y1 y2 y3 \<and> Q y1 y2 y3) \<longleftrightarrow> (\<exists>y1 y2 y3. (\<exists>x. P x y1 y2 y3) \<and> Q y1 y2 y3)"
  by auto

lemma exists_narrowR1: "(\<exists>x. P \<and> Q x) \<longleftrightarrow> P \<and> (\<exists>x. Q x)"
  by auto

lemma exists_narrowR2: "(\<exists>x y. P y \<and> Q x y) \<longleftrightarrow> (\<exists>y. P  y \<and> (\<exists>x. Q x y))"
  by auto

lemma exists_narrowR3: "(\<exists>x y1 y2. P y1 y2 \<and> Q x y1 y2) \<longleftrightarrow> (\<exists>y1 y2. P y1 y2 \<and> (\<exists>x. Q x y1 y2))"
  by auto

lemma exists_narrowR4: "(\<exists>x y1 y2 y3. P y1 y2 y3 \<and> Q x y1 y2 y3) \<longleftrightarrow> (\<exists>y1 y2 y3. P y1 y2 y3 \<and> (\<exists>x. Q x y1 y2 y3))"
  by auto

lemmas exists_narrow =
exists_narrowL1
exists_narrowL2
exists_narrowL3
exists_narrowL4
exists_narrowR1
exists_narrowR2
exists_narrowR3
exists_narrowR4

lemma prog_initial: "prog (initialState program) = program"
  by (auto simp add: initialState_def)

lemma consistentSnapshot_empty: "consistentSnapshot S {}"
  by (auto simp add: consistentSnapshotH_def causallyConsistent_def transactionConsistent_def  transactionConsistent_committed_def transactionConsistent_atomic_def)

lemma exists_optionI: "x \<noteq> None \<Longrightarrow> \<exists>y. x \<triangleq> y"
  by auto

lemma txStatus_initial: "txStatus (initialState progr) t = None"
  by (simp add: initialState_def)

definition initialStates' :: "('proc::valueType, 'ls, 'op::valueType, 'any::valueType) prog \<Rightarrow> invocId \<Rightarrow> ('proc, 'ls, 'op, 'any) state set"  where
  "initialStates' progr i \<equiv> {
    (S\<lparr>localState := (localState S)(i \<mapsto> initState),
       currentProc := (currentProc S)(i \<mapsto> impl),
       visibleCalls := (visibleCalls S)(i \<mapsto> {}),
       invocOp := (invocOp S)(i \<mapsto> proc)\<rparr>)
 | S proc initState impl.
    prog S = progr
  \<and> procedure progr proc = (initState, impl)
  \<and> uniqueIds proc \<subseteq> knownIds S
  \<and> invariant_all' S
  \<and> state_wellFormed S
  \<and> invocOp S i = None
  \<and> (\<forall>tx. txStatus S tx \<noteq> Some Uncommitted)
  \<and> (\<forall>tx. txOrigin S tx \<noteq> Some i)
}"

lemma initialStates'_same:
  shows "initialStates progr i = initialStates' progr i"
proof(auto simp add: initialStates_def initialStates'_def, fuzzy_goal_cases A B)
  case (A S proc initState impl)
  then show ?case
    by (auto simp add: invContext_same_allCommitted)
next
  case (B S proc initState impl)
  then show ?case
    by (auto simp add: invContext_same_allCommitted intro!: exI)
qed

end


theory Unified_PW
  imports Refine_Imperative_HOL.Sepref Worklist_Common "TA_Library.Subsumption_Graphs"
begin

hide_const wait

subsection \<open>Utilities\<close>

definition take_from_set where
  "take_from_set s = ASSERT (s \<noteq> {}) \<then> SPEC (\<lambda> (x, s'). x \<in> s \<and> s' = s - {x})"

lemma take_from_set_correct:
  assumes "s \<noteq> {}"
  shows "take_from_set s \<le> SPEC (\<lambda> (x, s'). x \<in> s \<and> s' = s - {x})"
using assms unfolding take_from_set_def by simp

lemmas [refine_vcg] = take_from_set_correct[THEN order.trans]

definition take_from_mset where
  "take_from_mset s = ASSERT (s \<noteq> {#}) \<then> SPEC (\<lambda> (x, s'). x \<in># s \<and> s' = s - {#x#})"

lemma take_from_mset_correct:
  assumes "s \<noteq> {#}"
  shows "take_from_mset s \<le> SPEC (\<lambda> (x, s'). x \<in># s \<and> s' = s - {#x#})"
using assms unfolding take_from_mset_def by simp

lemmas [refine_vcg] = take_from_mset_correct[THEN order.trans]

lemma set_mset_mp: "set_mset m \<subseteq> s \<Longrightarrow> n < count m x \<Longrightarrow> x\<in>s"
  by (meson count_greater_zero_iff le_less_trans subsetCE zero_le)

lemma pred_not_lt_is_zero: "(\<not> n - Suc 0 < n) \<longleftrightarrow> n=0" by auto

subsection \<open>Generalized Worklist Algorithm\<close>

context Search_Space_Defs_Empty
begin
  definition "reachable_subsumed S = {x' | x x'. reachable x' \<and> \<not> empty x' \<and> x' \<preceq> x \<and> x \<in> S}"

  definition
    "pw_var =
      inv_image (
      {(b, b'). b \<and> \<not> b'}
        <*lex*>
      {(passed', passed).
        passed' \<subseteq> {a. reachable a \<and> \<not> empty a} \<and> passed \<subseteq> {a. reachable a \<and> \<not> empty a} \<and>
        reachable_subsumed passed \<subset> reachable_subsumed passed'}
        <*lex*>
      measure size
      )
      (\<lambda> (a, b, c). (c, a, b))
      "

  definition "pw_inv_frontier passed wait =
    (\<forall> a \<in> passed. (\<exists> a' \<in> set_mset wait. a \<preceq> a') \<or>
    (\<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 = (\<not> empty a\<^sub>0 \<longrightarrow> (\<exists> a \<in> passed \<union> set_mset wait. a\<^sub>0 \<preceq> a))"

  definition "pw_inv \<equiv> \<lambda> (passed, wait, brk).
    (brk \<longrightarrow> (\<exists> f. reachable f \<and> F f)) \<and>
    (\<not> brk \<longrightarrow>
      passed \<subseteq> {a. reachable a \<and> \<not> empty a}
    \<and> pw_inv_frontier passed wait
    \<and> (\<forall> a \<in> passed \<union> set_mset wait. \<not> F a)
    \<and> start_subsumed passed wait
    \<and> set_mset wait \<subseteq> Collect reachable)
    "

  definition "add_pw_spec passed wait a \<equiv> SPEC (\<lambda>(passed',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. \<exists> s' \<in> set_mset wait'. s \<preceq> s') \<and>
      (\<forall> s \<in> {a' . E a a' \<and> \<not> empty a'}. \<exists> s' \<in> set_mset wait' \<union> passed. s \<preceq> s') \<and>
      (\<forall> s \<in> passed \<union> {a}. \<exists> s' \<in> passed'. s \<preceq> s') \<and>
      (passed' \<subseteq> passed \<union> {a} \<union> {a' . E a a' \<and> \<not> empty a'} \<and>
      ((\<exists> x \<in> passed'. \<not> (\<exists> x' \<in> passed. x \<preceq> x')) \<or> wait' \<subseteq># wait \<and> passed = passed')
      )
  )"

  definition
    "init_pw_spec \<equiv>
      SPEC (\<lambda> (passed, wait).
        if empty a\<^sub>0 then passed = {} \<and> wait \<subseteq># {#a\<^sub>0#} else passed \<subseteq> {a\<^sub>0} \<and> wait = {#a\<^sub>0#})"

  abbreviation subsumed_elem :: "'a \<Rightarrow> 'a set \<Rightarrow> bool"
    where "subsumed_elem a M \<equiv> \<exists> a'. a' \<in> M \<and> a \<preceq> a'"

  notation
    subsumed_elem  ("(_/ \<in>'' _)" [51, 51] 50)

    definition "pw_inv_frontier' passed wait =
      (\<forall> a. a \<in> passed \<longrightarrow>
        (a \<in>' set_mset wait)
      \<or> (\<forall> a'. E a a' \<and> \<not> empty a' \<longrightarrow> (a' \<in>' passed \<union> set_mset wait)))"

  lemma pw_inv_frontier_frontier':
    "pw_inv_frontier' passed wait" if
    "pw_inv_frontier passed wait" "passed \<subseteq> Collect reachable"
    using that unfolding pw_inv_frontier'_def pw_inv_frontier_def by (blast intro: trans)

  lemma
    "pw_inv_frontier passed wait" if "pw_inv_frontier' passed wait"
    using that unfolding pw_inv_frontier_def pw_inv_frontier'_def by blast

  definition pw_algo where
    "pw_algo = do
      {
        if F a\<^sub>0 then RETURN (True, {})
        else if empty a\<^sub>0 then RETURN (False, {})
        else do {
          (passed, wait) \<leftarrow> init_pw_spec;
          (passed, wait, brk) \<leftarrow> WHILEIT pw_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 empty a then RETURN (passed, wait, brk) else add_pw_spec passed wait a
              }
            )
            (passed, wait, False);
            RETURN (brk, passed)
        }
      }
    "

end

subsubsection \<open>Correctness Proof\<close>

instance nat :: preorder ..

context Search_Space_finite begin

  lemma wf_worklist_var_aux:
    "wf {(passed', passed).
      passed' \<subseteq> {a. reachable a \<and> \<not> empty a} \<and> passed \<subseteq> {a. reachable a \<and> \<not> empty a} \<and>
      reachable_subsumed passed \<subset> reachable_subsumed passed'}"
  proof (rule finite_acyclic_wf, goal_cases)
    case 1
    have "{(passed', passed).
        passed' \<subseteq> {a. reachable a \<and> \<not> empty a} \<and> passed \<subseteq> {a. reachable a \<and> \<not> empty a} \<and>
        reachable_subsumed passed \<subset> reachable_subsumed passed'}
   \<subseteq> {(passed', passed).
        passed \<subseteq> {a. reachable a \<and> \<not> empty a} \<and> passed' \<subseteq> {a. reachable a \<and> \<not> empty a}}"
      unfolding reachable_subsumed_def by auto
    moreover have "finite \<dots>" using finite_reachable using [[simproc add: finite_Collect]] by simp
    ultimately show ?case by (rule finite_subset)
  next
    case 2
    term "\<lambda> a. card (reachable_subsumed a)"
    have *: "class.preorder (\<le>) ((<) :: nat \<Rightarrow> nat \<Rightarrow> bool)"
      by (rule preorder_class.axioms)
    show ?case
      thm acyclicI_order
    proof (rule preorder.acyclicI_order[where f = "\<lambda> a. card (reachable_subsumed a)"],
           rule preorder_class.axioms, rule psubset_card_mono)
      fix a
      have "reachable_subsumed a \<subseteq> {a. reachable a \<and> \<not> empty a}"
        unfolding reachable_subsumed_def by blast
      then show "finite (reachable_subsumed a)" using finite_reachable by (rule finite_subset)
    qed auto
  qed

  lemma wf_worklist_var:
    "wf pw_var"
    unfolding pw_var_def
    by (auto 4 3 intro: wf_worklist_var_aux finite_acyclic_wf preorder.acyclicI_order[where f = id]
          preorder_class.axioms)

  context
  begin

  private lemma aux5:
    assumes
      "a' \<in> passed'"
      "a \<in># wait"
      "a \<preceq> a'"
      "start_subsumed passed wait"
      "\<forall>s\<in>passed. \<exists>x\<in>passed'. s \<preceq> x"
      "\<forall>s\<in>#wait - {#a#}. Multiset.Bex wait' ((\<preceq>) s)"
    shows "start_subsumed passed' wait'"
      using assms unfolding start_subsumed_def apply clarsimp
      by (metis Un_iff insert_DiffM2 local.trans mset_right_cancel_elem)

  private lemma aux11:
    assumes
      "empty a"
      "start_subsumed passed wait"
    shows "start_subsumed passed (wait - {#a#})"
      using assms unfolding start_subsumed_def
      by auto (metis UnI2 diff_single_trivial empty_mono insert_DiffM insert_noteq_member)

  lemma aux3_aux:
    assumes "pw_inv_frontier' passed wait"
      "\<not> b \<in>' set_mset wait"
      "E b b'"
      "\<not> empty b" "\<not> empty b'"
      "b \<in>' passed"
      "reachable b" "passed \<subseteq> {a. reachable a \<and> \<not> empty a}"
    shows "b' \<in>' passed \<union> set_mset wait"
  proof -
    from \<open>b \<in>' _\<close> obtain b1 where b1: "b \<preceq> b1" "b1 \<in> passed"
      by blast
    with mono[OF this(1) \<open>E b b'\<close>] \<open>passed \<subseteq> _\<close> \<open>reachable b\<close> \<open>\<not> empty b\<close> obtain b1' where
      "E b1 b1'" "b' \<preceq> b1'"
      by auto
    moreover then have "\<not> empty b1'"
      using assms(5) empty_mono by blast
    moreover from assms b1 have "\<not> b1 \<in>' set_mset wait"
      by (blast intro: trans)
    ultimately show ?thesis
      using assms(1) b1
      unfolding pw_inv_frontier'_def
      by (blast intro: trans)
  qed

  private lemma pw_inv_frontier_empty_elem:
    assumes "pw_inv_frontier passed wait" "passed \<subseteq> {a. reachable a \<and> \<not> empty a}" "empty a"
    shows "pw_inv_frontier passed (wait - {#a#})"
    using assms
    unfolding pw_inv_frontier_def
      apply auto
    by (smt UnCI UnE diff_single_trivial empty_mono insert_DiffM2 mset_cancel_elem(1) subset_Collect_conv)

  private lemma aux3:
    assumes
      "set_mset wait \<subseteq> Collect reachable"
      "a \<in># wait"
      "\<forall> s \<in> set_mset (wait - {#a#}). \<exists> s' \<in> set_mset wait'. s \<preceq> s'"
      "\<forall> s \<in> {a'. E a a' \<and> \<not> empty a'}. \<exists> s' \<in> passed \<union> set_mset wait'. s \<preceq> s'"
      "\<forall> s \<in> passed \<union> {a}. \<exists> s' \<in> passed'. s \<preceq> s'"
      "passed' \<subseteq> passed \<union> {a} \<union> {a' . E a a' \<and> \<not> empty a}"
      "pw_inv_frontier passed wait"
      "passed \<subseteq> {a. reachable a \<and> \<not> empty a}"
    shows "pw_inv_frontier passed' wait'"
  proof -
    from assms(1,2) have "reachable a"
      by (simp add: subset_iff)
    from assms have assms':
      "set_mset wait \<subseteq> Collect reachable"
      "a \<in># wait"
      "\<forall> s. s \<in>' set_mset (wait - {#a#}) \<longrightarrow> s \<in>' set_mset wait'"
      "\<forall> s \<in> {a'. E a a' \<and> \<not> empty a'}. s \<in>' passed \<union> set_mset wait'"
      "\<forall> s. s \<in>' passed \<union> {a} \<longrightarrow> s \<in>' passed'"
      "passed' \<subseteq> passed \<union> {a} \<union> {a' . E a a'}"
      "pw_inv_frontier' passed wait"
      "passed \<subseteq> {a. reachable a \<and> \<not> empty a}"
      by (blast intro: trans pw_inv_frontier_frontier')+

    show ?thesis unfolding pw_inv_frontier_def
      apply safe
      unfolding Bex_def
      subgoal for b b'
      proof (goal_cases)
        case A: 1
        from A(1) assms(6) consider "b \<in> passed" | "a = b" | "E a b"
          by auto
        note cases = this
        from cases \<open>\<not> b \<in>' set_mset wait'\<close> assms'(4) \<open>reachable a\<close> \<open>passed \<subseteq> _\<close> have "reachable b"
          by cases (auto intro: reachable_step)
        with A(3,4) have "\<not> empty b" by (auto simp: empty_E)
        from cases this \<open>reachable b\<close> consider "a = b" | "a \<noteq> b" "b \<in>' passed" "reachable b"
          apply cases
          using \<open>\<not> b \<in>' set_mset wait'\<close> assms'(4)
          by (fastforce intro: reachable_step)+
        then consider "b \<preceq> a" "reachable b" | "\<not> b \<preceq> a" "b \<in>' passed" "reachable b"
          apply cases
          using \<open>\<not> b \<in>' set_mset wait'\<close> assms'(4) \<open>reachable a\<close> by fastforce+
        then show ?case
        proof cases
          case 1
          with A(3,4) have "\<not> empty b"
            by (auto simp: empty_E)
          with mono[OF 1(1) \<open>E b b'\<close> 1(2) \<open>reachable a\<close>] obtain b1' where
            "E a b1'" "b' \<preceq> b1'"
            by auto
          with \<open>\<not> empty b'\<close> have "b1' \<in>' passed \<union> set_mset wait'"
            using assms'(4) by (auto dest: empty_mono)
          with \<open>b' \<preceq> _\<close> assms'(5) show ?thesis
            by (auto intro: trans)
        next
          case 2
          with A(3,4) have "\<not> empty b"
            by (auto simp: empty_E)
          from 2 \<open>\<not> b \<in>' set_mset wait'\<close> assms'(2,3) have "\<not> b \<in>' set_mset wait"
            by (metis insert_DiffM2 mset_right_cancel_elem)
          from
            aux3_aux[OF
              assms'(7) this \<open>E b b'\<close> \<open>\<not> empty b\<close> \<open>\<not> empty b'\<close> \<open>b \<in>' passed\<close> \<open>reachable b\<close> assms'(8)
              ]
          have "b' \<in>' passed \<union> set_mset wait" .
          with assms'(2,3,5) show ?thesis
            by auto (metis insert_DiffM insert_noteq_member)
        qed
      qed
      done
  qed

  private lemma aux6:
    assumes
      "a \<in># wait"
      "start_subsumed passed 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'"
    shows "start_subsumed (insert a passed) wait'"
    using assms unfolding start_subsumed_def
    apply clarsimp
    apply (erule disjE)
     apply blast
    subgoal premises prems for x
    proof (cases "a = x")
      case True
      with prems show ?thesis by simp
    next
      case False
      with \<open>x \<in># wait\<close> have "x \<in> set_mset (wait - {#a#})"
        by (metis insert_DiffM insert_noteq_member prems(1))
      with prems(2,4) \<open>_ \<preceq> x\<close> show ?thesis
        by (auto dest: trans)
    qed
  done

  lemma empty_E_star:
    "empty x'" if "E\<^sup>*\<^sup>* x x'" "reachable x" "empty x"
    using that unfolding reachable_def
    by (induction rule: converse_rtranclp_induct)
       (blast intro: empty_E[unfolded reachable_def] rtranclp.rtrancl_into_rtrancl)+

  lemma aux4:
    assumes "pw_inv_frontier passed {#}" "reachable x" "start_subsumed passed {#}"
            "passed \<subseteq> {a. reachable a \<and> \<not> empty a}" "\<not> empty x"
    shows "\<exists> x' \<in> passed. x \<preceq> x'"
  proof -
    from \<open>reachable x\<close> have "E\<^sup>*\<^sup>* a\<^sub>0 x" by (simp add: reachable_def)
    have "\<not> empty a\<^sub>0" using \<open>E\<^sup>*\<^sup>* a\<^sub>0 x\<close> assms(5) empty_E_star by blast
    with assms(3) obtain b where "a\<^sub>0 \<preceq> b" "b \<in> passed" unfolding start_subsumed_def by auto
    have "\<exists>x'. \<exists> x''. E\<^sup>*\<^sup>* b x' \<and> x \<preceq> x' \<and> x' \<preceq> x'' \<and> x'' \<in> passed" if
                     "E\<^sup>*\<^sup>* a x"  "a \<preceq> b"   "b \<preceq> b'"   "b' \<in> passed"
                     "reachable a" "reachable b" for a b b'
    using that proof (induction arbitrary: b b' rule: converse_rtranclp_induct)
      case base
      then show ?case by auto
    next
      case (step a a1 b b')
      show ?case
      proof (cases "empty a")
        case True
        with step.prems step.hyps have "empty x" by - (rule empty_E_star, auto)
        with step.prems show ?thesis by (auto intro: empty_subsumes)
      next
        case False
        with \<open>E a a1\<close> \<open>a \<preceq> b\<close> \<open>reachable a\<close> \<open>reachable b\<close> obtain b1 where
          "E b b1" "a1 \<preceq> b1"
          using mono by blast
        show ?thesis
        proof (cases "empty b1")
          case True
          with empty_mono \<open>a1 \<preceq> b1\<close> have "empty a1" by blast
          with step.prems step.hyps have "empty x" by - (rule empty_E_star, auto simp: reachable_def)
          with step.prems show ?thesis by (auto intro: empty_subsumes)
        next
          case False
          from \<open>E b b1\<close> \<open>a1 \<preceq> b1\<close> obtain b1' where "E b' b1'" "b1 \<preceq> b1'"
            using \<open>\<not> empty a\<close> empty_mono assms(4) mono step.prems by blast
          from empty_mono[OF \<open>\<not> empty b1\<close> \<open>b1 \<preceq> b1'\<close>] have "\<not> empty b1'"
            by auto
          with \<open>E b' b1'\<close> \<open>b' \<in> passed\<close> assms(1) obtain b1'' where "b1'' \<in> passed" "b1' \<preceq> b1''"
            unfolding pw_inv_frontier_def by auto
          with \<open>b1 \<preceq> _\<close> have "b1 \<preceq> b1''" using trans by blast
          with step.IH[OF \<open>a1 \<preceq> b1\<close> this \<open>b1'' \<in> passed\<close>] \<open>reachable a\<close> \<open>E a a1\<close> \<open>reachable b\<close> \<open>E b b1\<close>
          obtain x' x'' where
            "E\<^sup>*\<^sup>* b1 x'" "x \<preceq> x'" "x' \<preceq> x''" "x'' \<in> passed"
            by (auto intro: reachable_step)
          moreover from \<open>E b b1\<close> \<open>E\<^sup>*\<^sup>* b1 x'\<close> have "E\<^sup>*\<^sup>* b x'" by auto
          ultimately show ?thesis by auto
        qed
      qed
    qed
    from this[OF \<open>E\<^sup>*\<^sup>* a\<^sub>0 x\<close> \<open>a\<^sub>0 \<preceq> b\<close> refl \<open>b \<in> _\<close>] assms(4) \<open>b \<in> passed\<close> show ?thesis
      by (auto intro: trans)
  qed

  lemmas [intro] = reachable_step

  private lemma aux7:
    assumes
      "a \<in># wait"
      "set_mset wait \<subseteq> Collect reachable"
      "set_mset wait' \<subseteq> set_mset (wait - {#a#}) \<union> Collect (E a)"
      "x \<in># wait'"
    shows "reachable x"
    using assms by (auto dest: in_diffD)

  private lemma aux8:
    "x \<in> reachable_subsumed S'"  if "x \<in> reachable_subsumed S" "\<forall>s\<in>S. \<exists>x\<in>S'. s \<preceq> x"
    using that unfolding reachable_subsumed_def by (auto intro: trans)

  private lemma aux9:
    assumes
      "set_mset wait' \<subseteq> set_mset (wait - {#a#}) \<union> Collect (E a)"
      "x \<in># wait'" "\<forall>a'. E a a' \<longrightarrow> \<not> F a'" "F x"
      "\<forall>a\<in>passed \<union> set_mset wait. \<not> F a"
    shows False
  proof -
    from assms(1,2) have "x \<in> set_mset wait \<or> x \<in> Collect (E a)"
      by (meson UnE in_diffD subsetCE)
    with assms(3,4,5) show ?thesis
      by auto
  qed

  private lemma aux10:
    assumes "\<forall>a\<in>passed' \<union> set_mset wait. \<not> F a" "F x" "x \<in># wait - {#a#}"
    shows "False"
    by (meson UnI2 assms in_diffD)

  (* XXX Move and rename *)
  lemma aux12:
    "size wait' < size wait" if "wait' \<subseteq># wait - {#a#}" "a \<in># wait"
    using that
    by (metis
        Diff_eq_empty_iff_mset add_diff_cancel_left' add_mset_add_single add_mset_not_empty
        insert_subset_eq_iff mset_le_add_mset_decr_left1 mset_subset_size subset_mset_def)

  lemma aux13:
    assumes
    "passed \<subseteq> {a. reachable a \<and> \<not> empty a}"
    "passed' \<subseteq> insert a (passed \<union> {a'. E a a' \<and> \<not> empty a'})"
    "\<not> empty a"
    "reachable a"
    "\<forall>s\<in>passed. \<exists>x\<in>passed'. s \<preceq> x"
    "a'' \<in> passed'"
    "\<forall>x\<in>passed. \<not> a'' \<preceq> x"
    shows
    "passed' \<subseteq> {a. reachable a \<and> \<not> empty a} \<and> reachable_subsumed passed \<subset> reachable_subsumed passed'
     \<or> passed' = passed \<and> size wait'' < size wait"
  proof -
    have "passed' \<subseteq> {a. reachable a \<and> \<not> empty a}"
      using \<open>passed \<subseteq> _\<close> \<open>passed' \<subseteq> _\<close> \<open>\<not> empty a\<close> \<open>reachable a\<close> by auto
    moreover have "reachable_subsumed passed \<subset> reachable_subsumed passed'"
      unfolding reachable_subsumed_def apply auto
      subgoal
        using \<open>\<forall>s\<in>passed. \<exists>x\<in>passed'. s \<preceq> x\<close> by (auto intro: trans)
      using assms(5-) \<open>passed' \<subseteq> {a. reachable a \<and> \<not> empty a}\<close> by auto
    ultimately show ?thesis
      using \<open>passed \<subseteq> _\<close> unfolding pw_var_def by auto
  qed

  method solve_vc =
    rule aux3 aux5 aux7 aux10 aux11 pw_inv_frontier_empty_elem; assumption; fail |
    rule aux3; auto; fail | auto intro: aux9; fail | auto dest: in_diffD; fail

  end \<comment> \<open>Context\<close>

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

theorem (in Search_Space'_finite) pw_algo_correct:
  "pw_algo \<le> SPEC (\<lambda> (brk, passed).
    (brk \<longleftrightarrow> F_reachable)
  \<and> (\<not> brk \<longrightarrow>
      (\<forall> a. reachable a \<and> \<not> empty a \<longrightarrow> (\<exists> b \<in> passed. a \<preceq> b))
    \<and> passed \<subseteq> {a. reachable a \<and> \<not> empty a})
    )"
proof -
  note [simp] = size_Diff_submset pred_not_lt_is_zero
  note [dest] = set_mset_mp
  show ?thesis
    unfolding pw_algo_def init_pw_spec_def add_pw_spec_def F_reachable_def
    apply (refine_vcg wf_worklist_var)
      (* F a\<^sub>0*)
             apply (auto; fail)
      (* empty a\<^sub>0 *)
            subgoal
              using empty_E_star final_non_empty unfolding reachable_def by auto
            subgoal
              using empty_E_star final_non_empty unfolding reachable_def by auto
            subgoal
              using empty_E_star final_non_empty unfolding reachable_def by auto
            subgoal
              using empty_E_star final_non_empty unfolding reachable_def by auto
            subgoal
              using empty_E_star final_non_empty unfolding reachable_def by auto
      (* Invar start*)
           apply (fastforce simp: pw_inv_def pw_inv_frontier_def start_subsumed_def
                            split: if_split_asm dest: mset_subset_eqD)
      (* Precondition for take-from-set *)
          apply (simp; fail)
      (* State is subsumed by passed*)
      (* Assertion *)
         apply (auto simp: pw_inv_def; fail)
      (* Invariant for picking an empty wait list element *)
        subgoal for _ passed wait _ passed' _ _ brk _ a wait'
          by (clarsimp simp: pw_inv_def split: if_split_asm; safe; solve_vc)
      (* Termination for picking an empty wait list element *)
       apply (clarsimp simp: pw_var_def nonempty_has_size; fail)
      (* Invariant for picking a non-empty wait list element *)
      subgoal for _ passed wait _ passed' _ _ brk _ a wait'
        by (clarsimp simp: pw_inv_def split: if_split_asm; safe; solve_vc) (* slow *)
      (* Termination for picking a non-empty wait list element *)
      subgoal for  _ _ _ _ passed _ wait brk _ a wait'
        by (clarsimp simp: pw_inv_def split: if_split_asm; safe)
           (simp_all add: aux12 aux13 pw_var_def)
      (* I \<and> \<not> b \<longrightarrow> post *)
      using F_mono by (fastforce simp: pw_inv_def dest!: aux4 dest: final_non_empty)+
qed

lemmas (in Search_Space'_finite) [refine_vcg] = pw_algo_correct[THEN order.trans]

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