Merge.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>

camkes/cdl-refine/Eval_CAMKES_CDL.thy

@@ -211,7 +211,7 @@ lemma Collect_asid_high__eval_helper:
 section \<open>Assorted helpers\<close>
 lemma fun_upds_to_map_of[THEN eq_reflection]:
   "Map.empty = map_of []"
-  "(map_of xs(k \<mapsto> v)) = map_of ((k, v) # xs)"
+  "((map_of xs)(k \<mapsto> v)) = map_of ((k, v) # xs)"
   by auto
 
 lemma subst_eqn_helper:

lib/Corres_UL.thy

@@ -339,6 +339,18 @@ lemma corres_splitEE:
    apply (clarsimp simp: lift_def y)+
   done
 
+lemma corres_splitEE_prod:
+  assumes x: "corres_underlying sr nf nf' (f \<oplus> r') P P' a c"
+  assumes y: "\<And>x y x' y'. r' (x, y) (x', y')
+              \<Longrightarrow> corres_underlying sr nf nf' (f \<oplus> r) (R x y) (R' x' y') (b x y) (d x' y')"
+  assumes z: "\<lbrace>Q\<rbrace> a \<lbrace>\<lambda>(x, y). R x y \<rbrace>,\<lbrace>\<top>\<top>\<rbrace>" "\<lbrace>Q'\<rbrace> c \<lbrace>\<lambda>(x, y). R' x y\<rbrace>,\<lbrace>\<top>\<top>\<rbrace>"
+  shows      "corres_underlying sr nf nf' (f \<oplus> r) (P and Q) (P' and Q') (a >>=E (\<lambda>(x, y). b x y)) (c >>=E (\<lambda>(x, y). d x y))"
+  using assms
+  apply (unfold bindE_def validE_def)
+  apply (rule corres_split[rotated 2], assumption+)
+  apply (fastforce simp: lift_def y split: sum.splits)
+  done
+
 lemma corres_split_handle:
   assumes    "corres_underlying sr nf nf' (f' \<oplus> r) P P' a c"
   assumes y: "\<And>ft ft'. f' ft ft'
@@ -494,6 +506,8 @@ lemma corres_liftE_rel_sum[simp]:
   corres_underlying sr nf nf' r P P' m m'"
   by (simp add: liftE_liftM o_def)
 
+lemmas corres_liftE_lift = corres_liftE_rel_sum[THEN iffD2]
+
 text \<open>Support for proving correspondence to noop with hoare triples\<close>
 
 lemma corres_noop:
@@ -689,6 +703,17 @@ lemma corres_trivial:
  "corres_underlying sr nf nf' r \<top> \<top> f g \<Longrightarrow> corres_underlying sr nf nf' r \<top> \<top> f g"
   by assumption
 
+lemma corres_underlying_trivial[corres]:
+  "\<lbrakk> nf' \<Longrightarrow> no_fail P' f \<rbrakk> \<Longrightarrow> corres_underlying Id nf nf' (=) \<top> P' f f"
+  by (auto simp add: corres_underlying_def Id_def no_fail_def)
+
+(* Instance of corres_underlying_trivial for unit type with dc instead of (=) as return relation,
+   for nicer return relation instantiation. *)
+lemma corres_underlying_trivial_dc[corres]:
+  "(nf' \<Longrightarrow> no_fail P' f) \<Longrightarrow> corres_underlying Id nf nf' dc (\<lambda>_. True) P' f f"
+  for f :: "('s, unit) nondet_monad"
+  by (fastforce intro: corres_underlying_trivial corres_rrel_pre)
+
 lemma corres_assume_pre:
   assumes R: "\<And>s s'. \<lbrakk> P s; Q s'; (s,s') \<in> sr \<rbrakk> \<Longrightarrow> corres_underlying sr nf nf' r P Q f g"
   shows "corres_underlying sr nf nf' r P Q f g"
@@ -855,6 +880,31 @@ lemma corres_assert_opt_assume:
   by (auto simp: bind_def assert_opt_def assert_def fail_def return_def
                  corres_underlying_def split: option.splits)
 
+lemma corres_assert_opt[corres]:
+  "r x x' \<Longrightarrow>
+  corres_underlying sr nf nf' (\<lambda>x x'. r (Some x) x') (\<lambda>s. x \<noteq> None) \<top> (assert_opt x) (return x')"
+  unfolding corres_underlying_def
+  by (clarsimp simp: assert_opt_def return_def split: option.splits)
+
+lemma assert_opt_assert_corres[corres]:
+  "(x = None) = (x' = None) \<Longrightarrow>
+   corres_underlying sr nf nf' (\<lambda>y _. x = Some y) (K (x \<noteq> None)) \<top>
+                     (assert_opt x) (assert (\<exists>y. x' = Some y))"
+  by (simp add: corres_underlying_def assert_opt_def return_def split: option.splits)
+
+lemma corres_assert_opt_l:
+  assumes "\<And>x. P' = Some x \<Longrightarrow> corres_underlying sr nf nf' r (P x) Q (f x) g"
+  shows "corres_underlying sr nf nf' r (\<lambda>s. \<exists>x. P' = Some x \<and> P x s) Q (assert_opt P' >>= f) g"
+  using assms
+  by (auto simp: bind_def assert_opt_def assert_def fail_def return_def corres_underlying_def
+           split: option.splits)
+
+lemma corres_gets_the_gets:
+  "corres_underlying sr False nf' r P P' (gets_the f) f' \<Longrightarrow>
+   corres_underlying sr nf nf' (\<lambda>x x'. x \<noteq> None \<and> r (the x) x') P P' (gets f) f'"
+  apply (simp add: gets_the_def bind_def simpler_gets_def assert_opt_def)
+  apply (fastforce simp: corres_underlying_def in_monad split: option.splits)
+  done
 
 text \<open>Support for proving correspondance by decomposing the state relation\<close>
 

lib/Eisbach_Tools/Apply_Debug.thy

@@ -491,7 +491,7 @@ fun maybe_bind st (_,[tok]) ctxt =
   else
     let
       val SOME (Token.Declaration decl) = Token.get_value tok;
-      val dummy_ctxt = (Morphism.form decl) (Context.Proof ctxt);
+      val dummy_ctxt = Morphism.form decl (Context.Proof ctxt);
       val SOME (phi,static_ctxt,{private_dyn_facts, local_facts}) = Data.get dummy_ctxt;
 
       val old_facts = Proof_Context.facts_of static_ctxt;

lib/ExtraCorres.thy

@@ -93,6 +93,8 @@ lemma corres_mapM_x:
            apply (simp | wp)+
   done
 
+lemmas corres_mapM_x' = corres_mapM_x[OF _ _ _ _ order_refl]
+
 (* FIXME: see comment for mapM rule. Same applies for lemma strength *)
 lemma corres_mapME:
   assumes x: "r [] []"
@@ -252,17 +254,20 @@ lemma hoare_from_abs_inv:
 lemma in_whileLoop_corres:
   assumes body_corres:
     "\<And>r r'. rrel r r' \<Longrightarrow>
-             corres_underlying srel False nf' rrel (P and C r) (P' and C' r') (B r) (B' r')"
-  and body_inv: "\<And>r. \<lbrace>P and C r\<rbrace> B r \<lbrace>\<lambda>_. P\<rbrace>"
-                "\<And>r'. \<lbrace>P' and C' r'\<rbrace> B' r' \<lbrace>\<lambda>_. P'\<rbrace>"
-  and cond: "\<And>r r' s s'. \<lbrakk>rrel r r'; (s, s') \<in> srel; P s; P' s'\<rbrakk> \<Longrightarrow> C r s = C' r' s'"
-  and result: "(rv', t') \<in> fst (whileLoop C' B' r' s')"
-  shows "\<forall>s r. (s, s') \<in> srel \<and> rrel r r' \<and> P s \<and> P' s'
+             corres_underlying srel nf nf' rrel (P r and C r) (P' r' and C' r') (B r) (B' r')"
+  assumes body_inv:
+    "\<And>r. \<lbrace>P r and C r\<rbrace> B r \<lbrace>P\<rbrace>"
+    "\<And>r'. \<lbrace>P' r' and C' r'\<rbrace> B' r' \<lbrace>P'\<rbrace>"
+  assumes cond: "\<And>r r' s s'. \<lbrakk>rrel r r'; (s, s') \<in> srel; P r s; P' r' s'\<rbrakk> \<Longrightarrow> C r s = C' r' s'"
+  assumes result: "(rv', t') \<in> fst (whileLoop C' B' r' s')"
+  assumes nf: "\<And>r. nf \<Longrightarrow> no_fail (P r and C r) (B r)"
+  shows "\<forall>s r. (s, s') \<in> srel \<and> rrel r r' \<and> P r s \<and> P' r' s'
                 \<longrightarrow> (\<exists>rv t. (rv, t) \<in> fst (whileLoop C B r s) \<and> (t, t') \<in> srel \<and> rrel rv rv')"
   apply (rule in_whileLoop_induct[OF result])
    apply (force simp: cond whileLoop_def)
   apply clarsimp
-  apply (frule (1) corres_underlyingD2[OF body_corres]; (fastforce simp: cond)?)
+  apply (frule (1) corres_underlyingD2[OF body_corres];
+         (fastforce dest: nf simp: cond no_fail_def)?)
   apply clarsimp
   apply (frule use_valid[OF _ body_inv(1)])
    apply (fastforce dest: cond)
@@ -271,21 +276,22 @@ lemma in_whileLoop_corres:
   apply (fastforce simp: whileLoop_def intro: whileLoop_results.intros(3) dest: cond)
   done
 
-lemma corres_whileLoop:
-  assumes cond: "\<And>r r' s s'. \<lbrakk>rrel r r'; (s, s') \<in> srel; P s; P' s'\<rbrakk> \<Longrightarrow> C r s = C' r' s'"
-  and body_corres:
+lemma corres_whileLoop_ret:
+  assumes cond: "\<And>r r' s s'. \<lbrakk>rrel r r'; (s, s') \<in> srel; P r s; P' r' s'\<rbrakk> \<Longrightarrow> C r s = C' r' s'"
+  assumes body_corres:
     "\<And>r r'. rrel r r' \<Longrightarrow>
-             corres_underlying srel False nf' rrel (P and C r) (P' and C' r') (B r) (B' r')"
-  and body_inv: "\<And>r. \<lbrace>P and C r\<rbrace> B r \<lbrace>\<lambda>_. P\<rbrace>"
-                "\<And>r'. \<lbrace>P' and C' r'\<rbrace> B' r' \<lbrace>\<lambda>_. P'\<rbrace>"
-  and rel: "rrel r r'"
-  and nf': "\<And>r'. no_fail (P' and C' r') (B' r')"
-  and termin: "\<And>r' s'. \<lbrakk>P' s'; C' r' s'\<rbrakk> \<Longrightarrow> whileLoop_terminates C' B' r' s'"
-  shows "corres_underlying srel False nf' rrel P P' (whileLoop C B r) (whileLoop C' B' r')"
+             corres_underlying srel False nf' rrel (P r and C r) (P' r' and C' r') (B r) (B' r')"
+  assumes body_inv:
+    "\<And>r. \<lbrace>P r and C r\<rbrace> B r \<lbrace>P\<rbrace>"
+    "\<And>r'. \<lbrace>P' r' and C' r'\<rbrace> B' r' \<lbrace>P'\<rbrace>"
+  assumes rel: "rrel r r'"
+  assumes nf': "\<And>r'. no_fail (P' r' and C' r') (B' r')"
+  assumes termin: "\<And>r' s'. \<lbrakk>P' r' s'; C' r' s'\<rbrakk> \<Longrightarrow> whileLoop_terminates C' B' r' s'"
+  shows "corres_underlying srel False nf' rrel (P r) (P' r') (whileLoop C B r) (whileLoop C' B' r')"
   apply (rule corres_no_failI)
    apply (simp add: no_fail_def)
    apply (intro impI allI)
-   apply (erule_tac I="\<lambda>_ s. P' s"
+   apply (erule_tac I="\<lambda>r' s'. P' r' s'"
                     and R="{((r', s'), r, s). C' r s \<and> (r', s') \<in> fst (B' r s)
                                               \<and> whileLoop_terminates C' B' r s}"
                     in not_snd_whileLoop)
@@ -304,82 +310,98 @@ lemma corres_whileLoop:
   apply (fastforce intro: assms)
   done
 
+lemmas corres_whileLoop =
+  corres_whileLoop_ret[where P="\<lambda>_. P" for P, where P'="\<lambda>_. P'" for P', simplified]
+
 lemma whileLoop_terminates_cross:
   assumes body_corres:
     "\<And>r r'. rrel r r' \<Longrightarrow>
-             corres_underlying srel False nf' rrel (P and C r) (P' and C' r') (B r) (B' r')"
-  and cond: "\<And>r r' s s'. \<lbrakk>rrel r r'; (s, s') \<in> srel; P s; P' s'\<rbrakk> \<Longrightarrow> C r s = C' r' s'"
-  and body_inv: "\<And>r. \<lbrace>P and C r\<rbrace> B r \<lbrace>\<lambda>_. P\<rbrace>"
-                "\<And>r'. \<lbrace>P' and C' r'\<rbrace> B' r' \<lbrace>\<lambda>_. P'\<rbrace>"
-  and abs_termination: "\<And>r s. P s \<Longrightarrow> whileLoop_terminates C B r s"
-  and ex_abs: "ex_abs_underlying srel P s'"
-  and rrel: "rrel r r'"
-  and P': "P' s'"
+             corres_underlying srel nf nf' rrel (P r and C r) (P' r' and C' r') (B r) (B' r')"
+  assumes cond: "\<And>r r' s s'. \<lbrakk>rrel r r'; (s, s') \<in> srel; P r s; P' r' s'\<rbrakk> \<Longrightarrow> C r s = C' r' s'"
+  assumes body_inv:
+    "\<And>r. \<lbrace>P r and C r\<rbrace> B r \<lbrace>P\<rbrace>"
+    "\<And>r'. \<lbrace>P' r' and C' r'\<rbrace> B' r' \<lbrace>P'\<rbrace>"
+  assumes abs_termination: "\<And>r s. \<lbrakk>P r s; C r s\<rbrakk> \<Longrightarrow> whileLoop_terminates C B r s"
+  assumes ex_abs: "ex_abs_underlying srel (P r) s'"
+  assumes rrel: "rrel r r'"
+  assumes P': "P' r' s'"
+  assumes nf: "\<And>r. nf \<Longrightarrow> no_fail (P r and C r) (B r)"
   shows "whileLoop_terminates C' B' r' s'"
 proof -
-  have helper: "\<And>s. P s \<Longrightarrow> \<forall>r' s'. rrel r r' \<and> (s, s') \<in> srel \<and> P s \<and> P' s'
-                                     \<longrightarrow> whileLoop_terminates C' B' r' s'"
+  have helper: "\<And>s. P r s \<and> C r s \<Longrightarrow> \<forall>r' s'. rrel r r' \<and> (s, s') \<in> srel \<and> P r s \<and> P' r' s'
+                                               \<longrightarrow> whileLoop_terminates C' B' r' s'"
        (is "\<And>s. _ \<Longrightarrow> ?I r s")
     apply (rule_tac P="?I" in whileLoop_terminates.induct)
       apply (fastforce intro: abs_termination)
      apply (fastforce simp: whileLoop_terminates.intros dest: cond)
     apply (subst whileLoop_terminates.simps)
     apply clarsimp
-    apply (frule (1) corres_underlyingD2[OF body_corres], fastforce+)
+    apply (frule (1) corres_underlyingD2[OF body_corres], (fastforce dest: nf simp: no_fail_def)+)
     apply (fastforce dest: use_valid intro: body_inv)
     done
 
   show ?thesis
     apply (insert assms helper)
-    apply (clarsimp simp: ex_abs_underlying_def)
+    apply (cases "C' r' s'")
+     apply (fastforce simp: ex_abs_underlying_def)
+    apply (simp add: whileLoop_terminates.intros(1))
     done
 qed
 
-lemma corres_whileLoop_abs:
-  assumes cond: "\<And>r r' s s'. \<lbrakk>rrel r r'; (s, s') \<in> srel; P s; P' s'\<rbrakk> \<Longrightarrow> C r s = C' r' s'"
-  and body_corres:
+lemma corres_whileLoop_abs_ret:
+  assumes cond: "\<And>r r' s s'. \<lbrakk>rrel r r'; (s, s') \<in> srel; P r s; P' r' s'\<rbrakk> \<Longrightarrow> C r s = C' r' s'"
+  assumes body_corres:
     "\<And>r r'. rrel r r' \<Longrightarrow>
-             corres_underlying srel False nf' rrel (P and C r) (P' and C' r') (B r) (B' r')"
-  and nf: "\<And>r. no_fail (P and C r) (B r)"
-  and rrel: "rrel r r'"
-  and rrel2: "\<forall>r'. \<exists>r. rrel r r'"
-  and body_inv: "\<And>r. \<lbrace>P and C r\<rbrace> B r \<lbrace>\<lambda>_. P\<rbrace>"
-                "\<And>r'. \<lbrace>P' and C' r'\<rbrace> B' r' \<lbrace>\<lambda>_. P'\<rbrace>"
-  and abs_termination: "\<And>r s. P s \<Longrightarrow> whileLoop_terminates C B r s"
-  shows "corres_underlying srel False nf' rrel P P' (whileLoop C B r) (whileLoop C' B' r')"
+             corres_underlying srel nf nf' rrel (P r and C r) (P' r' and C' r') (B r) (B' r')"
+  assumes rrel: "rrel r r'"
+  assumes body_inv:
+    "\<And>r. \<lbrace>P r and C r\<rbrace> B r \<lbrace>P\<rbrace>"
+    "\<And>r'. \<lbrace>P' r' and C' r'\<rbrace> B' r' \<lbrace>P'\<rbrace>"
+  assumes abs_termination: "\<And>r s. \<lbrakk>P r s; C r s\<rbrakk> \<Longrightarrow> whileLoop_terminates C B r s"
+  assumes nf: "\<And>r. nf \<Longrightarrow> no_fail (P r and C r) (B r)"
+  shows "corres_underlying srel nf nf' rrel (P r) (P' r') (whileLoop C B r) (whileLoop C' B' r')"
   apply (rule corres_underlyingI)
    apply (frule in_whileLoop_corres[OF body_corres body_inv];
-          (fastforce intro: body_corres body_inv rrel dest: cond))
-  apply (rule_tac I="\<lambda>rv' s'. \<exists>rv s. (s, s') \<in> srel \<and> rrel rv rv' \<and> P s \<and> P' s'"
-                  and R="{((r', s'), r, s). C' r s \<and> (r', s') \<in> fst (B' r s)
-                                            \<and> whileLoop_terminates C' B' r s}"
-                  in not_snd_whileLoop)
+          (fastforce intro: body_corres body_inv rrel dest: nf cond))
+  apply (rule_tac I="\<lambda>rv' s'. \<exists>rv s. (s, s') \<in> srel \<and> rrel rv rv' \<and> P rv s \<and> P' rv' s'"
+              and R="{((r', s'), r, s). C' r s \<and> (r', s') \<in> fst (B' r s)
+                                        \<and> whileLoop_terminates C' B' r s}"
+               in not_snd_whileLoop)
     apply (fastforce intro: rrel)
-   apply (rename_tac conc_r s)
+   apply (rename_tac s s' conc_r new_s)
    apply (clarsimp simp: validNF_def)
    apply (rule conjI)
     apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?)
-      apply (prop_tac "\<exists>abs_r. rrel abs_r conc_r")
-       apply (fastforce simp: rrel2)
-      apply clarsimp
+      apply (rule_tac Q="\<lambda>s'. \<exists>rv s. (s, s') \<in> srel \<and> rrel rv conc_r
+                                     \<and> P rv s \<and> (P' conc_r s' \<and> C' conc_r s') \<and> s' = new_s"
+                   in hoare_weaken_pre[rotated])
+       apply clarsimp
+      apply (rule hoare_ex_pre)
+      apply (rename_tac abs_r)
       apply (rule hoare_weaken_pre)
-       apply (fastforce intro!: wp_from_corres_u body_inv body_corres)
+       apply (rule_tac G="rrel abs_r conc_r" in hoare_grab_asm)
+       apply (wpsimp wp: wp_from_corres_u[OF body_corres] body_inv)
+       apply (fastforce dest: nf)
       apply (fastforce dest: cond)
      apply (fastforce simp: valid_def)
     apply wpsimp
     apply (rule whileLoop_terminates_cross[OF body_corres];
-           (fastforce dest: cond intro: body_inv abs_termination))
-   apply (prop_tac "\<exists>abs_r. rrel abs_r conc_r")
-    apply (fastforce simp: rrel2)
-   apply clarsimp
-   apply (rule_tac P="\<lambda>s'. \<exists>s. (s, s') \<in> srel \<and> (P and C abs_r) s \<and> P' s' \<and> C' conc_r s'"
-                   in no_fail_pre)
-    apply (insert cond body_corres)
-    apply (fastforce intro: corres_u_nofail simp: pred_conj_def)
-   apply fastforce
+           (fastforce dest: nf cond intro: body_inv abs_termination))
+   apply (rule_tac P="\<lambda>s'. \<exists>rv s. (s, s') \<in> srel \<and> rrel rv conc_r
+                                  \<and> P rv s \<and> (P' conc_r s' \<and> C' conc_r s') \<and> s' = new_s"
+                in no_fail_pre[rotated])
+    apply fastforce
+   apply (rule no_fail_ex_lift)
+   apply (rename_tac abs_r)
+   apply (rule no_fail_pre)
+    apply (rule_tac G="rrel abs_r conc_r" in no_fail_grab_asm)
+    apply (fastforce intro: corres_u_nofail dest: body_corres nf)
+   apply (fastforce simp: cond)
   apply (fastforce intro: wf_subset[OF whileLoop_terminates_wf[where C=C']])
   done
 
+lemmas corres_whileLoop_abs =
+  corres_whileLoop_abs_ret[where P="\<lambda>_. P" for P, where P'="\<lambda>_. P'" for P', simplified]
 
 text \<open>Some corres_underlying rules for monadic combinators\<close>
 

lib/LemmaBucket.thy

@@ -11,10 +11,6 @@ imports
   SubMonadLib
 begin
 
-lemma corres_underlying_trivial:
-  "\<lbrakk> nf' \<Longrightarrow> no_fail P' f \<rbrakk> \<Longrightarrow> corres_underlying Id nf nf' (=) \<top> P' f f"
-  by (auto simp add: corres_underlying_def Id_def no_fail_def)
-
 lemma hoare_spec_gen_asm:
   "\<lbrakk> F \<Longrightarrow> s \<turnstile> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> s \<turnstile> \<lbrace>P and K F\<rbrace> f \<lbrace>Q\<rbrace>"
   "\<lbrakk> F \<Longrightarrow> s \<turnstile> \<lbrace>P\<rbrace> f' \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow> s \<turnstile> \<lbrace>P and K F\<rbrace> f' \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"

lib/Lib.thy

@@ -2237,7 +2237,7 @@ lemma map_of_zip_is_index:
 
 lemma map_of_zip_take_update:
   "\<lbrakk>i < length xs; length xs \<le> length ys; distinct xs\<rbrakk>
-  \<Longrightarrow> map_of (zip (take i xs) ys)(xs ! i \<mapsto> (ys ! i)) = map_of (zip (take (Suc i) xs) ys)"
+  \<Longrightarrow> (map_of (zip (take i xs) ys)) (xs ! i \<mapsto> ys ! i) = map_of (zip (take (Suc i) xs) ys)"
   apply (rule ext, rename_tac x)
   apply (case_tac "x=xs ! i"; clarsimp)
    apply (rule map_of_is_SomeI[symmetric])
@@ -2522,6 +2522,14 @@ lemma if_option_None_eq:
   "((if P then Some x else None) = None) = (\<not>P)"
   by simp+
 
+lemma option_case_all_conv:
+  "(case x of None \<Rightarrow> True | Some v \<Rightarrow> P v) = (\<forall>v. x = Some v \<longrightarrow> P v)"
+  by (auto split: option.split)
+
+lemma prod_o_comp:
+  "(case x of (a, b) \<Rightarrow> f a b) \<circ> g = (case x of (a, b) \<Rightarrow> f a b \<circ> g)"
+  by (auto simp: split_def)
+
 lemma lhs_sym_eq:
   "(a = b) = x \<longleftrightarrow> (b = a) = x"
   by auto

lib/ML_Goal.thy

@@ -109,7 +109,7 @@ fun begin_proof ((name, attrs): Attrib.binding, ml_block: Input.source) ctxt =
             val ((res_name, res), ctxt') =
                 Local_Theory.note (binding, thms) ctxt;
             val _ =
-                Proof_Display.print_results true start_pos ctxt'
+                Proof_Display.print_results { interactive = true, pos = start_pos, proof_state = true } ctxt'
                   (("theorem", res_name), [("", res)])
           in ctxt' end
     in

lib/MonadicRewrite.thy

@@ -653,6 +653,13 @@ lemma monadic_rewrite_gets_the_gets:
   apply (auto simp: simpler_gets_def return_def)
   done
 
+lemma gets_oapply_liftM_rewrite:
+  "monadic_rewrite False True (\<lambda>s. f s p \<noteq> None)
+                   (gets (oapply p \<circ> f)) (liftM Some (gets_map f p))"
+  unfolding monadic_rewrite_def
+  by (simp add: liftM_def simpler_gets_def bind_def gets_map_def assert_opt_def return_def
+           split: option.splits)
+
 text \<open>Option cases\<close>
 
 lemma monadic_rewrite_case_option:

lib/Monads/Fun_Pred_Syntax.thy

@@ -173,6 +173,17 @@ lemmas pred_neg_bot_eq[simp] =
    entirely in the future *)
 
 
+subsection "Simplification Rules for Lifted And/Or"
+
+lemma bipred_disj_op_eq[simp]:
+  "reflp R \<Longrightarrow> ((=) or R) = R"
+  "reflp R \<Longrightarrow> (R or (=)) = R"
+  by (auto simp: reflp_def)
+
+lemma bipred_le_true[simp]: "R \<le> \<top>\<top>"
+  by clarsimp
+
+
 section \<open>Examples\<close>
 
 experiment

lib/Monads/Monad_Lib.thy

@@ -69,4 +69,8 @@ lemma sum_all_ex[simp]:
   "(\<forall>a. x \<noteq> Inr a) = (\<exists>a. x = Inl a)"
   by (metis Inr_not_Inl sum.exhaust)+
 
+lemma context_disjE:
+  "\<lbrakk>P \<or> Q; P \<Longrightarrow> R; \<lbrakk>\<not>P; Q\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
+  by auto
+
 end

lib/Monads/nondet/Nondet_Det.thy

@@ -51,13 +51,13 @@ lemma det_UN:
 lemma bind_detI[simp, intro!]:
   "\<lbrakk> det f; \<forall>x. det (g x) \<rbrakk> \<Longrightarrow> det (f >>= g)"
   unfolding bind_def det_def
+  apply (erule all_reg[rotated])
   apply clarsimp
-  apply (erule_tac x=s in allE)
-  apply clarsimp
-  apply (erule_tac x="a" in allE)
-  apply (erule_tac x="b" in allE)
-  apply clarsimp
-  done
+  by (metis fst_conv snd_conv)
+
+lemma det_modify[iff]:
+  "det (modify f)"
+  by (simp add: modify_def)
 
 lemma the_run_stateI:
   "fst (M s) = {s'} \<Longrightarrow> the_run_state M s = s'"

lib/Monads/nondet/Nondet_Empty_Fail.thy

@@ -63,7 +63,7 @@ subsection \<open>Wellformed monads\<close>
 
 (*
   Collect generic empty_fail lemmas here:
-   - naming convention is emtpy_fail_NAME.
+   - naming convention is empty_fail_NAME.
    - add lemmas with assumptions to [empty_fail_cond] set
    - add lemmas without assumption to [empty_fail_term] set
 *)

lib/Monads/nondet/Nondet_In_Monad.thy

@@ -38,9 +38,13 @@ lemma in_bindE_L:
   by (simp add: bindE_def bind_def)
      (force simp: return_def throwError_def lift_def split_def split: sum.splits if_split_asm)
 
+lemma in_return:
+  "(r, s') \<in> fst (return v s) = (r = v \<and> s' = s)"
+  by (simp add: return_def)
+
 lemma in_liftE:
   "((v, s') \<in> fst (liftE f s)) = (\<exists>v'. v = Inr v' \<and> (v', s') \<in> fst (f s))"
-  by (force simp add: liftE_def bind_def return_def split_def)
+  by (force simp: liftE_def in_bind in_return)
 
 lemma in_whenE:
   "((v, s') \<in> fst (whenE P f s)) = ((P \<longrightarrow> (v, s') \<in> fst (f s)) \<and> (\<not>P \<longrightarrow> v = Inr () \<and> s' = s))"
@@ -58,10 +62,6 @@ lemma in_fail:
   "r \<in> fst (fail s) = False"
   by (simp add: fail_def)
 
-lemma in_return:
-  "(r, s') \<in> fst (return v s) = (r = v \<and> s' = s)"
-  by (simp add: return_def)
-
 lemma in_assert:
   "(r, s') \<in> fst (assert P s) = (P \<and> s' = s)"
   by (simp add: assert_def return_def fail_def)
@@ -90,6 +90,18 @@ lemma in_when:
   "(v, s') \<in> fst (when P f s) = ((P \<longrightarrow> (v, s') \<in> fst (f s)) \<and> (\<not>P \<longrightarrow> v = () \<and> s' = s))"
   by (simp add: when_def in_return)
 
+lemma in_unless:
+  "(v, s') \<in> fst (unless P f s) = ((\<not> P \<longrightarrow> (v, s') \<in> fst (f s)) \<and> (P \<longrightarrow> v = () \<and> s' = s))"
+  by (simp add: unless_def in_when)
+
+lemma in_unlessE:
+  "(v, s') \<in> fst (unlessE P f s) = ((\<not> P \<longrightarrow> (v, s') \<in> fst (f s)) \<and> (P \<longrightarrow> v = Inr () \<and> s' = s))"
+  by (simp add: unlessE_def in_returnOk)
+
+lemma inl_unlessE:
+  "((Inl x, s') \<in> fst (unlessE P f s)) = (\<not> P \<and> (Inl x, s') \<in> fst (f s))"
+  by (auto simp add: in_unlessE)
+
 lemma in_modify:
   "(v, s') \<in> fst (modify f s) = (s'=f s \<and> v = ())"
   by (simp add: modify_def bind_def get_def put_def)
@@ -112,12 +124,11 @@ lemma in_bindE:
     (\<exists>rv' s''. (rv, s') \<in> fst (g rv' s'') \<and> (Inr rv', s'') \<in> fst (f s)))"
   by (force simp: bindE_def bind_def lift_def throwError_def return_def  split: sum.splits)
 
-(* FIXME lib: remove unlessE_whenE + unless_when here and replace with in_unless lemmas *)
 lemmas in_monad = inl_whenE in_whenE in_liftE in_bind in_bindE_L
                   in_bindE_R in_returnOk in_throwError in_fail
                   in_assertE in_assert in_return in_assert_opt
-                  in_get in_gets in_put in_when unlessE_whenE
-                  unless_when in_modify gets_the_in_monad
+                  in_get in_gets in_put in_when inl_unlessE in_unlessE
+                  in_unless in_modify gets_the_in_monad
                   in_alternative in_liftM
 
 lemma bind_det_exec:

lib/Monads/nondet/Nondet_Lemmas.thy

@@ -6,7 +6,7 @@
  *)
 
 theory Nondet_Lemmas
-imports Nondet_Monad
+  imports Nondet_Monad
 begin
 
 section \<open>General Lemmas Regarding the Nondeterministic State Monad\<close>
@@ -15,12 +15,12 @@ subsection \<open>Congruence Rules for the Function Package\<close>
 
 lemma bind_cong[fundef_cong]:
   "\<lbrakk> f = f'; \<And>v s s'. (v, s') \<in> fst (f' s) \<Longrightarrow> g v s' = g' v s' \<rbrakk> \<Longrightarrow> f >>= g = f' >>= g'"
-  by (auto simp: bind_def Let_def split_def intro: rev_image_eqI)
+  by (auto simp: bind_def split_def)
 
 lemma bind_apply_cong [fundef_cong]:
   "\<lbrakk> f s = f' s'; \<And>rv st. (rv, st) \<in> fst (f' s') \<Longrightarrow> g rv st = g' rv st \<rbrakk>
    \<Longrightarrow> (f >>= g) s = (f' >>= g') s'"
-  by (auto simp: bind_def split_def intro: SUP_cong [OF refl] intro: rev_image_eqI)
+  by (auto simp: bind_def split_def)
 
 lemma bindE_cong[fundef_cong]:
   "\<lbrakk> M = M' ; \<And>v s s'. (Inr v, s') \<in> fst (M' s) \<Longrightarrow> N v s' = N' v s' \<rbrakk> \<Longrightarrow> bindE M N = bindE M' N'"
@@ -192,8 +192,8 @@ lemma liftE_liftM:
 lemma liftME_liftM:
   "liftME f = liftM (case_sum Inl (Inr \<circ> f))"
   unfolding liftME_def liftM_def bindE_def returnOk_def lift_def
-  apply (rule ext, rename_tac x)
-  apply (rule_tac f="bind x" in arg_cong)
+  apply (rule ext)
+  apply (rule arg_cong[where f="bind m" for m])
   apply (fastforce simp: throwError_def split: sum.splits)
   done
 
@@ -277,7 +277,8 @@ lemma monad_state_eqI [intro]:
 subsection \<open>General @{const whileLoop} reasoning\<close>
 
 definition whileLoop_terminatesE ::
-  "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('s, 'e + 'a) nondet_monad) \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool" where
+  "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('s, 'e + 'a) nondet_monad) \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool"
+  where
   "whileLoop_terminatesE C B \<equiv>
      \<lambda>r. whileLoop_terminates (\<lambda>r s. case r of Inr v \<Rightarrow> C v s | _ \<Rightarrow> False) (lift B) (Inr r)"
 
@@ -340,10 +341,10 @@ lemma whileLoop_unroll':
 lemma whileLoopE_unroll:
   "whileLoopE C B r = condition (C r) (B r >>=E whileLoopE C B) (returnOk r)"
   unfolding whileLoopE_def
-  apply (rule ext, rename_tac x)
+  apply (rule ext)
   apply (subst whileLoop_unroll)
   apply (clarsimp simp: bindE_def returnOk_def lift_def split: condition_splits)
-  apply (rule_tac f="\<lambda>a. (B r >>= a) x" in arg_cong)
+  apply (rule arg_cong[where f="\<lambda>a. (B r >>= a) x" for x])
   apply (rule ext)+
   apply (clarsimp simp: lift_def split: sum.splits)
   apply (subst whileLoop_unroll)

lib/Monads/nondet/Nondet_Monad.thy

@@ -71,16 +71,15 @@ text \<open>
   operation may have failed, if @{text f} may have failed or @{text g} may
   have failed on any of the results of @{text f}.\<close>
 definition bind ::
-  "('s, 'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) nondet_monad) \<Rightarrow> ('s, 'b) nondet_monad"
-  (infixl ">>=" 60) where
+  "('s, 'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) nondet_monad) \<Rightarrow> ('s, 'b) nondet_monad" (infixl ">>=" 60)
+  where
   "bind f g \<equiv> \<lambda>s. (\<Union>(fst ` case_prod g ` fst (f s)),
                    True \<in> snd ` case_prod g ` fst (f s) \<or> snd (f s))"
 
-text \<open>
-  Sometimes it is convenient to write @{text bind} in reverse order.\<close>
+text \<open>Sometimes it is convenient to write @{text bind} in reverse order.\<close>
 abbreviation (input) bind_rev ::
-  "('c \<Rightarrow> ('a, 'b) nondet_monad) \<Rightarrow> ('a, 'c) nondet_monad \<Rightarrow> ('a, 'b) nondet_monad"
-  (infixl "=<<" 60) where
+  "('c \<Rightarrow> ('a, 'b) nondet_monad) \<Rightarrow> ('a, 'c) nondet_monad \<Rightarrow> ('a, 'b) nondet_monad" (infixl "=<<" 60)
+  where
   "g =<< f \<equiv> f >>= g"
 
 text \<open>
@@ -107,36 +106,40 @@ definition select :: "'a set \<Rightarrow> ('s,'a) nondet_monad" where
   "select A \<equiv> \<lambda>s. (A \<times> {s}, False)"
 
 definition alternative ::
-  "('s, 'a) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad" (infixl "\<sqinter>" 20) where
+  "('s, 'a) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad" (infixl "\<sqinter>" 20)
+  where
   "f \<sqinter> g \<equiv> \<lambda>s. (fst (f s) \<union> fst (g s), snd (f s) \<or> snd (g s))"
 
-text \<open>A variant of @{text select} that takes a pair. The first component
-  is a set as in normal @{text select}, the second component indicates
-  whether the execution failed. This is useful to lift monads between
-  different state spaces.\<close>
+text \<open>
+  A variant of @{text select} that takes a pair. The first component is a set
+  as in normal @{text select}, the second component indicates whether the
+  execution failed. This is useful to lift monads between different state
+  spaces.\<close>
 definition select_f :: "'a set \<times> bool  \<Rightarrow> ('s,'a) nondet_monad" where
   "select_f S \<equiv> \<lambda>s. (fst S \<times> {s}, snd S)"
 
-text \<open>@{text select_state} takes a relationship between
-  states, and outputs nondeterministically a state
-  related to the input state.\<close>
+text \<open>
+  @{text state_select} takes a relationship between states, and outputs
+  nondeterministically a state related to the input state. Fails if no such
+  state exists.\<close>
 definition state_select :: "('s \<times> 's) set \<Rightarrow> ('s, unit) nondet_monad" where
   "state_select r \<equiv> \<lambda>s. ((\<lambda>x. ((), x)) ` {s'. (s, s') \<in> r}, \<not> (\<exists>s'. (s, s') \<in> r))"
 
+
 subsection "Failure"
 
 text \<open>
   The monad function that always fails. Returns an empty set of results and sets the failure flag.\<close>
 definition fail :: "('s, 'a) nondet_monad" where
- "fail \<equiv> \<lambda>s. ({}, True)"
+  "fail \<equiv> \<lambda>s. ({}, True)"
 
 text \<open>Assertions: fail if the property @{text P} is not true\<close>
 definition assert :: "bool \<Rightarrow> ('a, unit) nondet_monad" where
- "assert P \<equiv> if P then return () else fail"
+  "assert P \<equiv> if P then return () else fail"
 
 text \<open>Fail if the value is @{const None}, return result @{text v} for @{term "Some v"}\<close>
 definition assert_opt :: "'a option \<Rightarrow> ('b, 'a) nondet_monad" where
- "assert_opt v \<equiv> case v of None \<Rightarrow> fail | Some v \<Rightarrow> return v"
+  "assert_opt v \<equiv> case v of None \<Rightarrow> fail | Some v \<Rightarrow> return v"
 
 text \<open>An assertion that also can introspect the current state.\<close>
 definition state_assert :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, unit) nondet_monad" where
@@ -146,11 +149,11 @@ subsection "Generic functions on top of the state monad"
 
 text \<open>Apply a function to the current state and return the result without changing the state.\<close>
 definition gets :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s, 'a) nondet_monad" where
- "gets f \<equiv> get >>= (\<lambda>s. return (f s))"
+  "gets f \<equiv> get >>= (\<lambda>s. return (f s))"
 
 text \<open>Modify the current state using the function passed in.\<close>
 definition modify :: "('s \<Rightarrow> 's) \<Rightarrow> ('s, unit) nondet_monad" where
- "modify f \<equiv> get >>= (\<lambda>s. put (f s))"
+  "modify f \<equiv> get >>= (\<lambda>s. put (f s))"
 
 lemma simpler_gets_def:
   "gets f = (\<lambda>s. ({(f s, s)}, False))"
@@ -172,7 +175,8 @@ text \<open>
   Perform a test on the current state, performing the left monad if
   the result is true or the right monad if the result is false. \<close>
 definition condition ::
-  "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'r) nondet_monad \<Rightarrow> ('s, 'r) nondet_monad \<Rightarrow> ('s, 'r) nondet_monad" where
+  "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'r) nondet_monad \<Rightarrow> ('s, 'r) nondet_monad \<Rightarrow> ('s, 'r) nondet_monad"
+  where
   "condition P L R \<equiv> \<lambda>s. if (P s) then (L s) else (R s)"
 
 notation (output)
@@ -184,18 +188,16 @@ text \<open>
 definition gets_the :: "('s \<Rightarrow> 'a option) \<Rightarrow> ('s, 'a) nondet_monad" where
   "gets_the f \<equiv> gets f >>= assert_opt"
 
-
 text \<open>
   Get a map (such as a heap) from the current state and apply an argument to the map.
   Fail if the map returns @{const None}, otherwise return the value.\<close>
-definition
-  gets_map :: "('s \<Rightarrow> 'a \<Rightarrow> 'b option) \<Rightarrow> 'a \<Rightarrow> ('s, 'b) nondet_monad" where
+definition gets_map :: "('s \<Rightarrow> 'a \<Rightarrow> 'b option) \<Rightarrow> 'a \<Rightarrow> ('s, 'b) nondet_monad" where
   "gets_map f p \<equiv> gets f >>= (\<lambda>m. assert_opt (m p))"
 
 
 subsection \<open>The Monad Laws\<close>
 
-text \<open>A more expanded definition of @{text bind}\<close>
+text \<open>An alternative definition of @{term bind}, sometimes more convenient.\<close>
 lemma bind_def':
   "(f >>= g) \<equiv>
        \<lambda>s. ({(r'', s''). \<exists>(r', s') \<in> fst (f s). (r'', s'') \<in> fst (g r' s') },
@@ -211,7 +213,8 @@ lemma return_bind[simp]:
   by (simp add: return_def bind_def)
 
 text \<open>@{term return} is absorbed on the right of a @{term bind}\<close>
-lemma bind_return[simp]: "(m >>= return) = m"
+lemma bind_return[simp]:
+  "(m >>= return) = m"
   by (simp add: bind_def return_def split_def)
 
 text \<open>@{term bind} is associative\<close>
@@ -263,7 +266,6 @@ definition bindE ::
   (infixl ">>=E" 60) where
   "f >>=E g \<equiv> f >>= lift g"
 
-
 text \<open>
   Lifting a normal nondeterministic monad into the
   exception monad is achieved by always returning its
@@ -271,7 +273,6 @@ text \<open>
 definition liftE :: "('s,'a) nondet_monad \<Rightarrow> ('s, 'e+'a) nondet_monad" where
   "liftE f \<equiv> f >>= (\<lambda>r. return (Inr r))"
 
-
 text \<open>
   Since the underlying type and @{text return} function changed,
   we need new definitions for when and unless:\<close>
@@ -281,13 +282,11 @@ definition whenE :: "bool \<Rightarrow> ('s, 'e + unit) nondet_monad \<Rightarro
 definition unlessE :: "bool \<Rightarrow> ('s, 'e + unit) nondet_monad \<Rightarrow> ('s, 'e + unit) nondet_monad" where
   "unlessE P f \<equiv> if P then returnOk () else f"
 
-
 text \<open>
   Throwing an exception when the parameter is @{term None}, otherwise
   returning @{term "v"} for @{term "Some v"}.\<close>
 definition throw_opt :: "'e \<Rightarrow> 'a option \<Rightarrow> ('s, 'e + 'a) nondet_monad" where
-  "throw_opt ex x \<equiv>  case x of None \<Rightarrow> throwError ex | Some v \<Rightarrow> returnOk v"
-
+  "throw_opt ex x \<equiv> case x of None \<Rightarrow> throwError ex | Some v \<Rightarrow> returnOk v"
 
 text \<open>
   Failure in the exception monad is redefined in the same way
@@ -296,6 +295,7 @@ text \<open>
 definition assertE :: "bool \<Rightarrow> ('a, 'e + unit) nondet_monad" where
   "assertE P \<equiv> if P then returnOk () else fail"
 
+
 subsection "Monad Laws for the Exception Monad"
 
 text \<open>More direct definition of @{const liftE}:\<close>
@@ -414,9 +414,7 @@ lemma "doE x \<leftarrow> returnOk 1;
   by simp
 
 
-
-section "Library of Monadic Functions and Combinators"
-
+section "Library of additional Monadic Functions and Combinators"
 
 text \<open>Lifting a normal function into the monad type:\<close>
 definition liftM :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('s, 'b) nondet_monad" where
@@ -426,12 +424,11 @@ text \<open>The same for the exception monad:\<close>
 definition liftME :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'e+'a) nondet_monad \<Rightarrow> ('s,'e+'b) nondet_monad" where
   "liftME f m \<equiv> doE x \<leftarrow> m; returnOk (f x) odE"
 
-text \<open> Execute @{term f} for @{term "Some x"}, otherwise do nothing. \<close>
+text \<open>Execute @{term f} for @{term "Some x"}, otherwise do nothing.\<close>
 definition maybeM :: "('a \<Rightarrow> ('s, unit) nondet_monad) \<Rightarrow> 'a option \<Rightarrow> ('s, unit) nondet_monad" where
   "maybeM f y \<equiv> case y of Some x \<Rightarrow> f x | None \<Rightarrow> return ()"
 
-text \<open>
-  Run a sequence of monads from left to right, ignoring return values.\<close>
+text \<open>Run a sequence of monads from left to right, ignoring return values.\<close>
 definition sequence_x :: "('s, 'a) nondet_monad list \<Rightarrow> ('s, unit) nondet_monad" where
   "sequence_x xs \<equiv> foldr (\<lambda>x y. x >>= (\<lambda>_. y)) xs (return ())"
 
@@ -446,10 +443,10 @@ text \<open>
   going through both lists simultaneously, left to right, ignoring
   return values.\<close>
 definition zipWithM_x ::
-  "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, unit) nondet_monad" where
+  "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, unit) nondet_monad"
+  where
   "zipWithM_x f xs ys \<equiv> sequence_x (zipWith f xs ys)"
 
-
 text \<open>
   The same three functions as above, but returning a list of
   return values instead of @{text unit}\<close>
@@ -461,15 +458,18 @@ definition mapM :: "('a \<Rightarrow> ('s,'b) nondet_monad) \<Rightarrow> 'a lis
   "mapM f xs \<equiv> sequence (map f xs)"
 
 definition zipWithM ::
-  "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, 'c list) nondet_monad" where
+  "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, 'c list) nondet_monad"
+  where
   "zipWithM f xs ys \<equiv> sequence (zipWith f xs ys)"
 
-definition foldM :: "('b \<Rightarrow> 'a \<Rightarrow> ('s, 'a) nondet_monad) \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> ('s, 'a) nondet_monad"
+definition foldM ::
+  "('b \<Rightarrow> 'a \<Rightarrow> ('s, 'a) nondet_monad) \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> ('s, 'a) nondet_monad"
   where
   "foldM m xs a \<equiv> foldr (\<lambda>p q. q >>= m p) xs (return a) "
 
 definition foldME ::
-  "('b \<Rightarrow> 'a \<Rightarrow> ('s,('e + 'b)) nondet_monad) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> ('s, ('e + 'b)) nondet_monad" where
+  "('b \<Rightarrow> 'a \<Rightarrow> ('s,('e + 'b)) nondet_monad) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> ('s, ('e + 'b)) nondet_monad"
+  where
   "foldME m a xs \<equiv> foldr (\<lambda>p q. q >>=E swp m p) xs (returnOk a)"
 
 text \<open>
@@ -485,11 +485,11 @@ definition sequenceE :: "('s, 'e+'a) nondet_monad list \<Rightarrow> ('s, 'e+'a
   "sequenceE xs \<equiv> let mcons = (\<lambda>p q. p >>=E (\<lambda>x. q >>=E (\<lambda>y. returnOk (x#y))))
                    in foldr mcons xs (returnOk [])"
 
-definition mapME :: "('a \<Rightarrow> ('s,'e+'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s,'e+'b list) nondet_monad"
+definition mapME ::
+  "('a \<Rightarrow> ('s,'e+'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s,'e+'b list) nondet_monad"
   where
   "mapME f xs \<equiv> sequenceE (map f xs)"
 
-
 text \<open>Filtering a list using a monadic function as predicate:\<close>
 primrec filterM :: "('a \<Rightarrow> ('s, bool) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'a list) nondet_monad" where
   "filterM P []       = return []"
@@ -499,6 +499,21 @@ primrec filterM :: "('a \<Rightarrow> ('s, bool) nondet_monad) \<Rightarrow> 'a
      return (if b then (x # ys) else ys)
    od"
 
+text \<open>An alternative definition of @{term state_select}\<close>
+lemma state_select_def2:
+  "state_select r \<equiv> (do
+    s \<leftarrow> get;
+    S \<leftarrow> return {s'. (s, s') \<in> r};
+    assert (S \<noteq> {});
+    s' \<leftarrow> select S;
+    put s'
+  od)"
+  apply (clarsimp simp add: state_select_def get_def return_def assert_def fail_def select_def
+                            put_def bind_def fun_eq_iff
+                    intro!: eq_reflection)
+  apply fastforce
+  done
+
 
 section "Catching and Handling Exceptions"
 
@@ -520,8 +535,7 @@ text \<open>
   The handler may throw a type of exceptions different from
   the left side.\<close>
 definition handleE' ::
-  "('s, 'e1 + 'a) nondet_monad \<Rightarrow> ('e1 \<Rightarrow> ('s, 'e2 + 'a) nondet_monad) \<Rightarrow>
-   ('s, 'e2 + 'a) nondet_monad"
+  "('s, 'e1 + 'a) nondet_monad \<Rightarrow> ('e1 \<Rightarrow> ('s, 'e2 + 'a) nondet_monad) \<Rightarrow> ('s, 'e2 + 'a) nondet_monad"
   (infix "<handle2>" 10) where
   "f <handle2> handler \<equiv>
    do
@@ -540,15 +554,13 @@ definition handleE ::
   (infix "<handle>" 10) where
   "handleE \<equiv> handleE'"
 
-
 text \<open>
   Handling exceptions, and additionally providing a continuation
   if the left-hand side throws no exception:\<close>
-definition
-  handle_elseE ::
+definition handle_elseE ::
   "('s, 'e + 'a) nondet_monad \<Rightarrow> ('e \<Rightarrow> ('s, 'ee + 'b) nondet_monad) \<Rightarrow>
-   ('a \<Rightarrow> ('s, 'ee + 'b) nondet_monad) \<Rightarrow> ('s, 'ee + 'b) nondet_monad"
-  ("_ <handle> _ <else> _" 10) where
+   ('a \<Rightarrow> ('s, 'ee + 'b) nondet_monad) \<Rightarrow> ('s, 'ee + 'b) nondet_monad" ("_ <handle> _ <else> _" 10)
+  where
   "f <handle> handler <else> continue \<equiv>
    do v \<leftarrow> f;
       case v of Inl e  \<Rightarrow> handler e
@@ -577,7 +589,8 @@ inductive_simps whileLoop_results_simps_valid: "(Some x, Some y) \<in> whileLoop
 inductive_simps whileLoop_results_simps_start_fail[simp]: "(None, x) \<in> whileLoop_results C B"
 
 inductive whileLoop_terminates ::
-  "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) nondet_monad) \<Rightarrow> 'r \<Rightarrow> 's \<Rightarrow> bool" for C B where
+  "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) nondet_monad) \<Rightarrow> 'r \<Rightarrow> 's \<Rightarrow> bool"
+  for C B where
     "\<not> C r s \<Longrightarrow> whileLoop_terminates C B r s"
   | "\<lbrakk> C r s; \<forall>(r', s') \<in> fst (B r s). whileLoop_terminates C B r' s' \<rbrakk>
         \<Longrightarrow> whileLoop_terminates C B r s"
@@ -586,7 +599,8 @@ inductive_cases whileLoop_terminates_cases: "whileLoop_terminates C B r s"
 inductive_simps whileLoop_terminates_simps: "whileLoop_terminates C B r s"
 
 definition whileLoop ::
-  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b, 'a) nondet_monad) \<Rightarrow> 'a \<Rightarrow> ('b, 'a) nondet_monad" where
+  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b, 'a) nondet_monad) \<Rightarrow> 'a \<Rightarrow> ('b, 'a) nondet_monad"
+  where
   "whileLoop C B \<equiv> \<lambda>r s.
      ({(r',s'). (Some (r, s), Some (r', s')) \<in> whileLoop_results C B},
       (Some (r, s), None) \<in> whileLoop_results C B \<or> \<not>whileLoop_terminates C B r s)"
@@ -609,17 +623,18 @@ section "Combinators that have conditions with side effects"
 definition notM :: "('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad" where
   "notM m = do c \<leftarrow> m; return (\<not> c) od"
 
-definition
-  whileM :: "('s, bool) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow> ('s, unit) nondet_monad" where
+definition whileM ::
+  "('s, bool) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow> ('s, unit) nondet_monad"
+  where
   "whileM C B \<equiv> do
     c \<leftarrow> C;
     whileLoop (\<lambda>c s. c) (\<lambda>_. do B; C od) c;
     return ()
   od"
 
-definition
-  ifM :: "('s, bool) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow>
-          ('s, 'a) nondet_monad" where
+definition ifM ::
+  "('s, bool) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad \<Rightarrow> ('s, 'a) nondet_monad"
+  where
   "ifM test t f = do
     c \<leftarrow> test;
     if c then t else f
@@ -627,22 +642,26 @@ definition
 
 definition ifME ::
   "('a, 'b + bool) nondet_monad \<Rightarrow> ('a, 'b + 'c) nondet_monad \<Rightarrow> ('a, 'b + 'c) nondet_monad
-   \<Rightarrow> ('a, 'b + 'c) nondet_monad" where
+   \<Rightarrow> ('a, 'b + 'c) nondet_monad"
+  where
   "ifME test t f = doE
     c \<leftarrow> test;
     if c then t else f
    odE"
 
-definition
-  whenM :: "('s, bool) nondet_monad \<Rightarrow> ('s, unit) nondet_monad \<Rightarrow> ('s, unit) nondet_monad" where
+definition whenM ::
+  "('s, bool) nondet_monad \<Rightarrow> ('s, unit) nondet_monad \<Rightarrow> ('s, unit) nondet_monad"
+  where
   "whenM t m = ifM t m (return ())"
 
-definition
-  orM :: "('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad" where
+definition orM ::
+  "('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad"
+  where
   "orM a b = ifM a (return True) b"
 
-definition
-  andM :: "('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad" where
+definition andM ::
+  "('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad \<Rightarrow> ('s, bool) nondet_monad"
+  where
   "andM a b = ifM a b (return False)"
 
 end

lib/Monads/nondet/Nondet_Monad_Equations.thy

@@ -31,11 +31,9 @@ lemma exec_modify:
 
 lemma bind_return_eq:
   "(a >>= return) = (b >>= return) \<Longrightarrow> a = b"
-  apply (clarsimp simp:bind_def)
-  apply (rule ext)
-  apply (drule_tac x= x in fun_cong)
-  apply (auto simp:return_def split_def)
-  done
+  by clarsimp
+
+lemmas bind_then_eq = arg_cong2[where f=bind, OF _ refl]
 
 lemma bindE_bind_linearise:
   "((f >>=E g) >>= h) =
@@ -51,7 +49,7 @@ lemma throwError_bind:
 
 lemma bind_bindE_assoc:
   "((f >>= g) >>=E h)
-    = f >>= (\<lambda>rv. g rv >>=E h)"
+   = f >>= (\<lambda>rv. g rv >>=E h)"
   by (simp add: bindE_def bind_assoc)
 
 lemma returnOk_bind:
@@ -118,7 +116,7 @@ lemma select_f_asserts:
 
 lemma liftE_bindE_handle:
   "((liftE f >>=E (\<lambda>x. g x)) <handle> h)
-      = f >>= (\<lambda>x. g x <handle> h)"
+   = f >>= (\<lambda>x. g x <handle> h)"
   by (simp add: liftE_bindE handleE_def handleE'_def
                 bind_assoc)
 
@@ -140,21 +138,21 @@ lemma liftE_bindE_assoc:
 
 lemma unlessE_throw_catch_If:
   "catch (unlessE P (throwError e) >>=E f) g
-      = (if P then catch (f ()) g else g e)"
+   = (if P then catch (f ()) g else g e)"
   by (simp add: unlessE_def catch_throwError split: if_split)
 
 lemma whenE_bindE_throwError_to_if:
   "whenE P (throwError e) >>=E (\<lambda>_. b) = (if P then (throwError e) else b)"
   unfolding whenE_def bindE_def
-  by (auto simp: Nondet_Monad.lift_def throwError_def returnOk_def)
+  by (auto simp: lift_def throwError_def returnOk_def)
 
 lemma alternative_liftE_returnOk:
   "(liftE m \<sqinter> returnOk v) = liftE (m \<sqinter> return v)"
   by (simp add: liftE_def alternative_def returnOk_def bind_def return_def)
 
 lemma alternative_left_readonly_bind:
-  "\<lbrakk> \<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>rv. (=) s\<rbrace>; fst (f s) \<noteq> {} \<rbrakk> \<Longrightarrow>
-     alternative (f >>= (\<lambda>x. g x)) h s
+  "\<lbrakk> \<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>rv. (=) s\<rbrace>; fst (f s) \<noteq> {} \<rbrakk>
+   \<Longrightarrow> alternative (f >>= (\<lambda>x. g x)) h s
        = (f >>= (\<lambda>x. alternative (g x) h)) s"
   apply (subgoal_tac "\<forall>x \<in> fst (f s). snd x = s")
    apply (clarsimp simp: alternative_def bind_def split_def)
@@ -179,35 +177,22 @@ lemma gets_the_returns:
   by (simp_all add: returnOk_def throwError_def
                     gets_the_return)
 
-lemma all_rv_choice_fn_eq_pred:
-  "\<lbrakk> \<And>rv. P rv \<Longrightarrow> \<exists>fn. f rv = g fn \<rbrakk> \<Longrightarrow> \<exists>fn. \<forall>rv. P rv \<longrightarrow> f rv = g (fn rv)"
-  apply (rule_tac x="\<lambda>rv. SOME h. f rv = g h" in exI)
-  apply (clarsimp split: if_split)
-  by (meson someI_ex)
-
-lemma all_rv_choice_fn_eq:
-  "\<lbrakk> \<And>rv. \<exists>fn. f rv = g fn \<rbrakk>
-    \<Longrightarrow> \<exists>fn. f = (\<lambda>rv. g (fn rv))"
-  using all_rv_choice_fn_eq_pred[where f=f and g=g and P=\<top>]
-  by (simp add: fun_eq_iff)
-
 lemma gets_the_eq_bind:
-  "\<lbrakk> \<exists>fn. f = gets_the (fn o fn'); \<And>rv. \<exists>fn. g rv = gets_the (fn o fn') \<rbrakk>
-     \<Longrightarrow> \<exists>fn. (f >>= g) = gets_the (fn o fn')"
-  apply (clarsimp dest!: all_rv_choice_fn_eq)
-  apply (rule_tac x="\<lambda>s. case (fn s) of None \<Rightarrow> None | Some v \<Rightarrow> fna v s" in exI)
+  "\<lbrakk> f = gets_the (fn_f o fn'); \<And>rv. g rv = gets_the (fn_g rv o fn') \<rbrakk>
+   \<Longrightarrow> \<exists>fn. (f >>= g) = gets_the (fn o fn')"
+  apply clarsimp
+  apply (rule exI[where x="\<lambda>s. case (fn_f s) of None \<Rightarrow> None | Some v \<Rightarrow> fn_g v s"])
   apply (simp add: gets_the_def bind_assoc exec_gets
                    assert_opt_def fun_eq_iff
             split: option.split)
   done
 
 lemma gets_the_eq_bindE:
-  "\<lbrakk> \<exists>fn. f = gets_the (fn o fn'); \<And>rv. \<exists>fn. g rv = gets_the (fn o fn') \<rbrakk>
-     \<Longrightarrow> \<exists>fn. (f >>=E g) = gets_the (fn o fn')"
-  apply (simp add: bindE_def)
-  apply (erule gets_the_eq_bind)
+  "\<lbrakk> f = gets_the (fn_f o fn'); \<And>rv. g rv = gets_the (fn_g rv o fn') \<rbrakk>
+   \<Longrightarrow> \<exists>fn. (f >>=E g) = gets_the (fn o fn')"
+  unfolding bindE_def
+  apply (erule gets_the_eq_bind[where fn_g="\<lambda>rv s. case rv of Inl e \<Rightarrow> Some (Inl e) | Inr v \<Rightarrow> fn_g v s"])
   apply (simp add: lift_def gets_the_returns split: sum.split)
-  apply fastforce
   done
 
 lemma gets_the_fail:
@@ -229,9 +214,9 @@ lemma ex_const_function:
 
 lemma gets_the_condsE:
   "(\<exists>fn. whenE P f = gets_the (fn o fn'))
-            = (P \<longrightarrow> (\<exists>fn. f = gets_the (fn o fn')))"
+   = (P \<longrightarrow> (\<exists>fn. f = gets_the (fn o fn')))"
   "(\<exists>fn. unlessE P g = gets_the (fn o fn'))
-            = (\<not> P \<longrightarrow> (\<exists>fn. g = gets_the (fn o fn')))"
+   = (\<not> P \<longrightarrow> (\<exists>fn. g = gets_the (fn o fn')))"
   by (simp add: whenE_def unlessE_def gets_the_returns ex_const_function
          split: if_split)+
 
@@ -245,7 +230,7 @@ lemma liftME_return:
 
 lemma fold_bindE_into_list_case:
   "(doE v \<leftarrow> f; case_list (g v) (h v) x odE)
-      = (case_list (doE v \<leftarrow> f; g v odE) (\<lambda>x xs. doE v \<leftarrow> f; h v x xs odE) x)"
+   = (case_list (doE v \<leftarrow> f; g v odE) (\<lambda>x xs. doE v \<leftarrow> f; h v x xs odE) x)"
   by (simp split: list.split)
 
 lemma whenE_liftE:
@@ -278,7 +263,7 @@ lemma maybe_fail_bind_fail:
 
 lemma select_singleton[simp]:
   "select {x} = return x"
-  by (fastforce simp add: fun_eq_iff select_def return_def)
+  by (simp add: select_def return_def)
 
 lemma return_modify:
   "return () = modify id"
@@ -296,10 +281,9 @@ lemma modify_id_return:
  "modify id = return ()"
   by (simp add: simpler_modify_def return_def)
 
-
 lemma liftE_bind_return_bindE_returnOk:
   "liftE (v >>= (\<lambda>rv. return (f rv)))
-     = (liftE v >>=E (\<lambda>rv. returnOk (f rv)))"
+   = (liftE v >>=E (\<lambda>rv. returnOk (f rv)))"
   by (simp add: liftE_bindE, simp add: liftE_def returnOk_def)
 
 lemma bind_eqI:
@@ -307,12 +291,12 @@ lemma bind_eqI:
 
 lemma unlessE_throwError_returnOk:
   "(if P then returnOk v else throwError x)
-    = (unlessE P (throwError x) >>=E (\<lambda>_. returnOk v))"
+   = (unlessE P (throwError x) >>=E (\<lambda>_. returnOk v))"
   by (cases P, simp_all add: unlessE_def)
 
 lemma gets_the_bind_eq:
   "\<lbrakk> f s = Some x; g x s = h s \<rbrakk>
-    \<Longrightarrow> (gets_the f >>= g) s = h s"
+   \<Longrightarrow> (gets_the f >>= g) s = h s"
   by (simp add: gets_the_def bind_assoc exec_gets assert_opt_def)
 
 lemma zipWithM_x_modify:
@@ -358,7 +342,7 @@ qed
 
 lemma assert2:
   "(do v1 \<leftarrow> assert P; v2 \<leftarrow> assert Q; c od)
-     = (do v \<leftarrow> assert (P \<and> Q); c od)"
+   = (do v \<leftarrow> assert (P \<and> Q); c od)"
   by (simp add: assert_def split: if_split)
 
 lemma assert_opt_def2:
@@ -367,23 +351,31 @@ lemma assert_opt_def2:
 
 lemma gets_assert:
   "(do v1 \<leftarrow> assert v; v2 \<leftarrow> gets f; c v1 v2 od)
-     = (do v2 \<leftarrow> gets f; v1 \<leftarrow> assert v; c v1 v2 od)"
+   = (do v2 \<leftarrow> gets f; v1 \<leftarrow> assert v; c v1 v2 od)"
   by (simp add: simpler_gets_def return_def assert_def fail_def bind_def
          split: if_split)
 
 lemma modify_assert:
   "(do v2 \<leftarrow> modify f; v1 \<leftarrow> assert v; c v1 od)
-    = (do v1 \<leftarrow> assert v; v2 \<leftarrow> modify f; c v1 od)"
+   = (do v1 \<leftarrow> assert v; v2 \<leftarrow> modify f; c v1 od)"
   by (simp add: simpler_modify_def return_def assert_def fail_def bind_def
          split: if_split)
 
 lemma gets_fold_into_modify:
   "do x \<leftarrow> gets f; modify (g x) od = modify (\<lambda>s. g (f s) s)"
   "do x \<leftarrow> gets f; _ \<leftarrow> modify (g x); h od
-     = do modify (\<lambda>s. g (f s) s); h od"
+   = do modify (\<lambda>s. g (f s) s); h od"
   by (simp_all add: fun_eq_iff modify_def bind_assoc exec_gets
                     exec_get exec_put)
 
+lemma gets_return_gets_eq:
+  "gets f >>= (\<lambda>g. return (h g)) = gets (\<lambda>s. h (f s))"
+  by (simp add: simpler_gets_def bind_def return_def)
+
+lemma gets_prod_comp:
+  "gets (case x of (a, b) \<Rightarrow> f a b) = (case x of (a, b) \<Rightarrow> gets (f a b))"
+  by (auto simp: split_def)
+
 lemma bind_assoc2:
   "(do x \<leftarrow> a; _ \<leftarrow> b; c x od) = (do x \<leftarrow> (do x' \<leftarrow> a; _ \<leftarrow> b; return x' od); c x od)"
   by (simp add: bind_assoc)
@@ -431,7 +423,7 @@ lemma liftE_fail[simp]: "liftE fail = fail"
 
 lemma catch_bind_distrib:
   "do _ <- m <catch> h; f od = (doE m; liftE f odE <catch> (\<lambda>x. do h x; f od))"
-  by (force simp: catch_def bindE_def bind_assoc liftE_def Nondet_Monad.lift_def bind_def
+  by (force simp: catch_def bindE_def bind_assoc liftE_def lift_def bind_def
                   split_def return_def throwError_def
             split: sum.splits)
 
@@ -451,7 +443,7 @@ lemma catch_is_if:
    od"
   apply (simp add: bindE_def catch_def bind_assoc cong: if_cong)
   apply (rule bind_cong, rule refl)
-  apply (clarsimp simp: Nondet_Monad.lift_def throwError_def split: sum.splits)
+  apply (clarsimp simp: lift_def throwError_def split: sum.splits)
   done
 
 lemma liftE_K_bind: "liftE ((K_bind (\<lambda>s. A s)) x) = K_bind (liftE (\<lambda>s. A s)) x"
@@ -464,8 +456,8 @@ lemma monad_eq_split:
   shows "(g >>= f) s = (g >>= f') s"
 proof -
   have pre: "\<And>rv s'. \<lbrakk>(rv, s') \<in> fst (g s)\<rbrakk> \<Longrightarrow> f rv s' = f' rv s'"
-    using assms unfolding valid_def
-    by (erule_tac x=s in allE) auto
+    using assms unfolding valid_def apply -
+    by (erule allE[where x=s]) auto
   show ?thesis
     by (simp add: bind_def image_def case_prod_unfold pre)
 qed
@@ -536,16 +528,15 @@ lemma bind_inv_inv_comm:
      empty_fail f; empty_fail g \<rbrakk> \<Longrightarrow>
    do x \<leftarrow> f; y \<leftarrow> g; n x y od = do y \<leftarrow> g; x \<leftarrow> f; n x y od"
   apply (rule ext)
-  apply (rename_tac s)
-  apply (rule_tac s="(do (x, y) \<leftarrow> do x \<leftarrow> f; y \<leftarrow> (\<lambda>_. g s) ; (\<lambda>_. return (x, y) s) od;
-                         n x y od) s" in trans)
+  apply (rule trans[where s="(do (x, y) \<leftarrow> do x \<leftarrow> f; y \<leftarrow> (\<lambda>_. g s) ; (\<lambda>_. return (x, y) s) od;
+                                 n x y od) s" for s])
    apply (simp add: bind_assoc)
    apply (intro bind_apply_cong, simp_all)[1]
     apply (metis in_inv_by_hoareD)
    apply (simp add: return_def bind_def)
    apply (metis in_inv_by_hoareD)
-  apply (rule_tac s="(do (x, y) \<leftarrow> do y \<leftarrow> g; x \<leftarrow> (\<lambda>_. f s) ; (\<lambda>_. return (x, y) s) od;
-                      n x y od) s" in trans[rotated])
+  apply (rule trans[where s="(do (x, y) \<leftarrow> do y \<leftarrow> g; x \<leftarrow> (\<lambda>_. f s) ; (\<lambda>_. return (x, y) s) od;
+                                 n x y od) s" for s, rotated])
    apply (simp add: bind_assoc)
    apply (intro bind_apply_cong, simp_all)[1]
     apply (metis in_inv_by_hoareD)
@@ -577,4 +568,22 @@ lemma if_to_top_of_bindE:
   "(bindE (If P x y) z) = If P (bindE x z) (bindE y z)"
   by (simp split: if_split)
 
+lemma modify_modify:
+  "(do x \<leftarrow> modify f; modify (g x) od) = modify (g () o f)"
+  by (simp add: bind_def simpler_modify_def)
+
+lemmas modify_modify_bind =
+  arg_cong2[where f=bind, OF modify_modify refl, simplified bind_assoc]
+
+lemma put_then_get[unfolded K_bind_def]:
+  "do put s; get od = do put s; return s od"
+  by (simp add: put_def bind_def get_def return_def)
+
+lemmas put_then_get_then =
+    put_then_get[THEN bind_then_eq, simplified bind_assoc return_bind]
+
+lemma select_empty_bind[simp]:
+  "select {} >>= f = select {}"
+  by (simp add: select_def bind_def)
+
 end

lib/Monads/nondet/Nondet_More_VCG.thy

@@ -11,11 +11,12 @@
 theory Nondet_More_VCG
   imports
     Nondet_VCG
+    Nondet_In_Monad
 begin
 
 lemma hoare_take_disjunct:
   "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. P' rv s \<and> (False \<or> P'' rv s)\<rbrace>
-    \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>P''\<rbrace>"
+   \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>P''\<rbrace>"
   by (erule hoare_strengthen_post, simp)
 
 lemma hoare_post_add:
@@ -44,18 +45,6 @@ lemma hoare_name_pre_stateE:
   "\<lbrakk>\<And>s. P s \<Longrightarrow> \<lbrace>(=) s\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>"
   by (clarsimp simp: validE_def2)
 
-lemma valid_prove_more: (* FIXME: duplicate *)
-  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>"
-  by (rule hoare_post_add)
-
-lemma hoare_vcg_if_lift:
-  "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P \<longrightarrow> X rv s) \<and> (\<not>P \<longrightarrow> Y rv s)\<rbrace> \<Longrightarrow>
-   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. if P then X rv s else Y rv s\<rbrace>"
-
-  "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P \<longrightarrow> X rv s) \<and> (\<not>P \<longrightarrow> Y rv s)\<rbrace> \<Longrightarrow>
-   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv. if P then X rv else Y rv\<rbrace>"
-  by (auto simp: valid_def split_def)
-
 lemma hoare_vcg_if_lift_strong:
   "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>P\<rbrace>; \<lbrace>\<lambda>s. \<not> P' s\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>R'\<rbrace> f \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow>
    \<lbrace>\<lambda>s. if P' s then Q' s else R' s\<rbrace> f \<lbrace>\<lambda>rv s. if P rv s then Q rv s else R rv s\<rbrace>"
@@ -97,12 +86,12 @@ lemmas hoare_lift_Pf_pre_conj' = hoare_lift_Pf2_pre_conj[where Q=P and P=P for P
 
 lemma hoare_if_r_and:
   "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>r. if R r then Q r else Q' r\<rbrace>
-  = \<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. (R r \<longrightarrow> Q r s) \<and> (\<not>R r \<longrightarrow> Q' r s)\<rbrace>"
+   = \<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. (R r \<longrightarrow> Q r s) \<and> (\<not>R r \<longrightarrow> Q' r s)\<rbrace>"
   by (fastforce simp: valid_def)
 
 lemma hoare_convert_imp:
-  "\<lbrakk> \<lbrace>\<lambda>s. \<not> P s\<rbrace> f \<lbrace>\<lambda>rv s. \<not> Q s\<rbrace>; \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace> \<rbrakk> \<Longrightarrow>
-    \<lbrace>\<lambda>s. P s \<longrightarrow> R s\<rbrace> f \<lbrace>\<lambda>rv s. Q s \<longrightarrow> S rv s\<rbrace>"
+  "\<lbrakk> \<lbrace>\<lambda>s. \<not> P s\<rbrace> f \<lbrace>\<lambda>rv s. \<not> Q s\<rbrace>; \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace> \<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. P s \<longrightarrow> R s\<rbrace> f \<lbrace>\<lambda>rv s. Q s \<longrightarrow> S rv s\<rbrace>"
   apply (simp only: imp_conv_disj)
   apply (erule(1) hoare_vcg_disj_lift)
   done
@@ -115,8 +104,8 @@ lemma hoare_vcg_ex_lift_R:
   done
 
 lemma hoare_case_option_wpR:
-  "\<lbrakk>\<lbrace>P\<rbrace> f None \<lbrace>Q\<rbrace>,-; \<And>x. \<lbrace>P' x\<rbrace> f (Some x) \<lbrace>Q' x\<rbrace>,-\<rbrakk> \<Longrightarrow>
-  \<lbrace>case_option P P' v\<rbrace> f v \<lbrace>\<lambda>rv. case v of None \<Rightarrow> Q rv | Some x \<Rightarrow> Q' x rv\<rbrace>,-"
+  "\<lbrakk>\<lbrace>P\<rbrace> f None \<lbrace>Q\<rbrace>,-; \<And>x. \<lbrace>P' x\<rbrace> f (Some x) \<lbrace>Q' x\<rbrace>,-\<rbrakk>
+   \<Longrightarrow> \<lbrace>case_option P P' v\<rbrace> f v \<lbrace>\<lambda>rv. case v of None \<Rightarrow> Q rv | Some x \<Rightarrow> Q' x rv\<rbrace>,-"
   by (cases v) auto
 
 lemma hoare_vcg_conj_liftE_R:
@@ -129,12 +118,6 @@ lemma K_valid[wp]:
   "\<lbrace>K P\<rbrace> f \<lbrace>\<lambda>_. K P\<rbrace>"
   by (simp add: valid_def)
 
-lemma hoare_vcg_exI:
-  "\<lbrace>P\<rbrace> f \<lbrace>Q x\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. \<exists>x. Q x rv s\<rbrace>"
-  apply (simp add: valid_def split_def)
-  apply blast
-  done
-
 lemma hoare_exI_tuple:
   "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>(rv,rv') s. Q x rv rv' s\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>(rv,rv') s. \<exists>x. Q x rv rv' s\<rbrace>"
   by (fastforce simp: valid_def)
@@ -154,8 +137,8 @@ lemma hoare_split_bind_case_sum:
              "\<And>rv. \<lbrace>S rv\<rbrace> h rv \<lbrace>Q\<rbrace>"
   assumes y: "\<lbrace>P\<rbrace> f \<lbrace>S\<rbrace>,\<lbrace>R\<rbrace>"
   shows      "\<lbrace>P\<rbrace> f >>= case_sum g h \<lbrace>Q\<rbrace>"
-  apply (rule hoare_seq_ext [OF _ y[unfolded validE_def]])
-  apply (case_tac x, simp_all add: x)
+  apply (rule hoare_seq_ext[OF _ y[unfolded validE_def]])
+  apply (wpsimp wp: x split: sum.splits)
   done
 
 lemma hoare_split_bind_case_sumE:
@@ -164,8 +147,8 @@ lemma hoare_split_bind_case_sumE:
   assumes y: "\<lbrace>P\<rbrace> f \<lbrace>S\<rbrace>,\<lbrace>R\<rbrace>"
   shows      "\<lbrace>P\<rbrace> f >>= case_sum g h \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
   apply (unfold validE_def)
-  apply (rule hoare_seq_ext [OF _ y[unfolded validE_def]])
-  apply (case_tac x, simp_all add: x [unfolded validE_def])
+  apply (rule hoare_seq_ext[OF _ y[unfolded validE_def]])
+  apply (wpsimp wp: x[unfolded validE_def] split: sum.splits)
   done
 
 lemma assertE_sp:
@@ -182,7 +165,7 @@ lemma gets_inv [simp]:
 
 lemma select_inv:
   "\<lbrace> P \<rbrace> select S \<lbrace> \<lambda>r. P \<rbrace>"
-  by (simp add: select_def valid_def)
+  by wpsimp
 
 lemmas return_inv = hoare_return_drop_var
 
@@ -223,9 +206,10 @@ lemma list_cases_weak_wp:
   assumes "\<And>x xs. \<lbrace>P_B\<rbrace> b x xs \<lbrace>Q\<rbrace>"
   shows
   "\<lbrace>P_A and P_B\<rbrace>
-    case ts of
-      [] \<Rightarrow> a
-    | x#xs \<Rightarrow> b x xs \<lbrace>Q\<rbrace>"
+   case ts of
+       [] \<Rightarrow> a
+     | x#xs \<Rightarrow> b x xs
+   \<lbrace>Q\<rbrace>"
   apply (cases ts)
   apply (simp, rule hoare_weaken_pre, rule assms, simp)+
   done
@@ -234,27 +218,20 @@ lemmas hoare_FalseE_R = hoare_FalseE[where E="\<top>\<top>", folded validE_R_def
 
 lemma hoare_vcg_if_lift2:
   "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P rv s \<longrightarrow> X rv s) \<and> (\<not> P rv s \<longrightarrow> Y rv s)\<rbrace> \<Longrightarrow>
-  \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. if P rv s then X rv s else Y rv s\<rbrace>"
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. if P rv s then X rv s else Y rv s\<rbrace>"
 
   "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P' rv \<longrightarrow> X rv s) \<and> (\<not> P' rv \<longrightarrow> Y rv s)\<rbrace> \<Longrightarrow>
-  \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv. if P' rv then X rv else Y rv\<rbrace>"
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv. if P' rv then X rv else Y rv\<rbrace>"
   by (auto simp: valid_def split_def)
 
 lemma hoare_vcg_if_lift_ER: (* Required because of lack of rv in lifting rules *)
   "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P rv s \<longrightarrow> X rv s) \<and> (\<not> P rv s \<longrightarrow> Y rv s)\<rbrace>, - \<Longrightarrow>
-  \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. if P rv s then X rv s else Y rv s\<rbrace>, -"
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. if P rv s then X rv s else Y rv s\<rbrace>, -"
 
   "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P' rv \<longrightarrow> X rv s) \<and> (\<not> P' rv \<longrightarrow> Y rv s)\<rbrace>, - \<Longrightarrow>
-  \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv. if P' rv then X rv else Y rv\<rbrace>, -"
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv. if P' rv then X rv else Y rv\<rbrace>, -"
   by (auto simp: valid_def validE_R_def validE_def split_def)
 
-lemma hoare_vcg_imp_liftE:
-  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>, \<lbrace>A\<rbrace>; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>A\<rbrace> \<rbrakk>
-   \<Longrightarrow> \<lbrace>\<lambda>s. \<not> P' s \<longrightarrow> Q' s\<rbrace> f \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>, \<lbrace>A\<rbrace>"
-  apply (simp only: imp_conv_disj)
-  apply (clarsimp simp: validE_def valid_def split_def sum.case_eq_if)
-  done
-
 lemma hoare_list_all_lift:
   "(\<And>r. r \<in> set xs \<Longrightarrow> \<lbrace>Q r\<rbrace> f \<lbrace>\<lambda>rv. Q r\<rbrace>)
    \<Longrightarrow> \<lbrace>\<lambda>s. list_all (\<lambda>r. Q r s) xs\<rbrace> f \<lbrace>\<lambda>rv s. list_all (\<lambda>r. Q r s) xs\<rbrace>"
@@ -279,12 +256,11 @@ lemma doesn't_grow_proof:
   assumes x: "\<And>x. \<lbrace>\<lambda>s. x \<notin> S s \<and> P s\<rbrace> f \<lbrace>\<lambda>rv s. x \<notin> S s\<rbrace>"
   shows      "\<lbrace>\<lambda>s. card (S s) < n \<and> P s\<rbrace> f \<lbrace>\<lambda>rv s. card (S s) < n\<rbrace>"
   apply (clarsimp simp: valid_def)
-  apply (subgoal_tac "S b \<subseteq> S s")
-   apply (drule card_mono [OF y], simp)
+  apply (erule le_less_trans[rotated])
+  apply (rule card_mono[OF y])
   apply clarsimp
   apply (rule ccontr)
-  apply (subgoal_tac "x \<notin> S b", simp)
-  apply (erule use_valid [OF _ x])
+  apply (drule (2) use_valid[OF _ x, OF _ conjI])
   apply simp
   done
 
@@ -303,7 +279,7 @@ lemma set_shrink_proof:
   assumes x: "\<And>x. \<lbrace>\<lambda>s. x \<notin> S s\<rbrace> f \<lbrace>\<lambda>rv s. x \<notin> S s\<rbrace>"
   shows
   "\<lbrace>\<lambda>s. \<forall>S'. S' \<subseteq> S s \<longrightarrow> P S'\<rbrace>
-     f
+   f
    \<lbrace>\<lambda>rv s. P (S s)\<rbrace>"
   apply (clarsimp simp: valid_def)
   apply (drule spec, erule mp)
@@ -320,13 +296,12 @@ lemma shrinks_proof:
   assumes w: "\<And>s. P s \<Longrightarrow> x \<in> S s"
   shows      "\<lbrace>\<lambda>s. card (S s) \<le> n \<and> P s\<rbrace> f \<lbrace>\<lambda>rv s. card (S s) < n\<rbrace>"
   apply (clarsimp simp: valid_def)
-  apply (subgoal_tac "S b \<subset> S s")
-   apply (drule psubset_card_mono [OF y], simp)
+  apply (erule less_le_trans[rotated])
+  apply (rule psubset_card_mono[OF y])
   apply (rule psubsetI)
    apply clarsimp
    apply (rule ccontr)
-   apply (subgoal_tac "x \<notin> S b", simp)
-   apply (erule use_valid [OF _ x])
+   apply (drule (2) use_valid[OF _ x, OF _ conjI])
    apply simp
   by (metis use_valid w z)
 
@@ -345,8 +320,6 @@ lemma valid_preservation_ex:
   apply simp
   done
 
-lemmas valid_prove_more' = valid_prove_more[where Q="\<lambda>rv. Q" for Q]
-
 lemma whenE_inv:
   assumes a: "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"
   shows "\<lbrace>P\<rbrace> whenE Q f \<lbrace>\<lambda>_. P\<rbrace>"
@@ -358,9 +331,12 @@ lemma whenE_throwError_wp:
 
 lemma ifM_throwError_returnOk:
   "\<lbrace>Q\<rbrace> test \<lbrace>\<lambda>c s. \<not> c \<longrightarrow> P s\<rbrace> \<Longrightarrow> \<lbrace>Q\<rbrace> ifM test (throwError e) (returnOk ()) \<lbrace>\<lambda>_. P\<rbrace>, -"
-  by (fastforce simp: ifM_def returnOk_def throwError_def return_def validE_R_def valid_def
-                      validE_def bind_def
-               split: if_splits)
+  unfolding ifM_def
+  apply (fold liftE_bindE)
+  apply wpsimp
+   apply assumption
+  apply simp
+  done
 
 lemma ifME_liftE:
   "ifME (liftE test) a b = ifM test a b"
@@ -386,23 +362,13 @@ lemma opt_return_pres_lift:
 
 lemma valid_return_unit:
   "\<lbrace>P\<rbrace> f >>= (\<lambda>_. return ()) \<lbrace>\<lambda>r. Q\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>r. Q\<rbrace>"
-  apply (rule validI)
-  apply (fastforce simp: valid_def return_def bind_def split_def)
-  done
+  by (auto simp: valid_def in_bind in_return Ball_def)
 
-lemma static_imp_wp:
-  "\<lbrace>Q\<rbrace> m \<lbrace>R\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> m \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>"
-  by (cases P, simp_all add: valid_def)
-
-lemma static_imp_wpE :
-  "\<lbrace>Q\<rbrace> m \<lbrace>R\<rbrace>,- \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> m \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>,-"
-  by (cases P, simp_all)
-
-lemma static_imp_conj_wp:
+lemma hoare_weak_lift_imp_conj:
   "\<lbrakk> \<lbrace>Q\<rbrace> m \<lbrace>Q'\<rbrace>; \<lbrace>R\<rbrace> m \<lbrace>R'\<rbrace> \<rbrakk>
-    \<Longrightarrow> \<lbrace>\<lambda>s. (P \<longrightarrow> Q s) \<and> R s\<rbrace> m \<lbrace>\<lambda>rv s. (P \<longrightarrow> Q' rv s) \<and> R' rv s\<rbrace>"
+   \<Longrightarrow> \<lbrace>\<lambda>s. (P \<longrightarrow> Q s) \<and> R s\<rbrace> m \<lbrace>\<lambda>rv s. (P \<longrightarrow> Q' rv s) \<and> R' rv s\<rbrace>"
   apply (rule hoare_vcg_conj_lift)
-   apply (rule static_imp_wp)
+   apply (rule hoare_weak_lift_imp)
    apply assumption+
   done
 
@@ -415,23 +381,13 @@ lemma hoare_validE_R_conj:
   "\<lbrakk>\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, -; \<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>, -\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q and R\<rbrace>, -"
   by (simp add: valid_def validE_def validE_R_def Let_def split_def split: sum.splits)
 
-lemma hoare_vcg_const_imp_lift_R:
-  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,- \<Longrightarrow> \<lbrace>\<lambda>s. F \<longrightarrow> P s\<rbrace> f \<lbrace>\<lambda>rv s. F \<longrightarrow> Q rv s\<rbrace>,-"
-  by (cases F, simp_all)
-
-lemma hoare_vcg_disj_lift_R:
-  assumes x: "\<lbrace>P\<rbrace>  f \<lbrace>Q\<rbrace>,-"
-  assumes y: "\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>,-"
-  shows      "\<lbrace>\<lambda>s. P s \<or> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<or> Q' rv s\<rbrace>,-"
-  using assms
-  by (fastforce simp: validE_R_def validE_def valid_def split: sum.splits)
-
 lemmas throwError_validE_R = throwError_wp [where E="\<top>\<top>", folded validE_R_def]
 
 lemma valid_case_option_post_wp:
-  "(\<And>x. \<lbrace>P x\<rbrace> f \<lbrace>\<lambda>rv. Q x\<rbrace>) \<Longrightarrow>
-    \<lbrace>\<lambda>s. case ep of Some x \<Rightarrow> P x s | _ \<Rightarrow> True\<rbrace>
-       f \<lbrace>\<lambda>rv s. case ep of Some x \<Rightarrow> Q x s | _ \<Rightarrow> True\<rbrace>"
+  "\<lbrakk>\<And>x. \<lbrace>P x\<rbrace> f \<lbrace>\<lambda>rv. Q x\<rbrace>\<rbrakk> \<Longrightarrow>
+   \<lbrace>\<lambda>s. case ep of Some x \<Rightarrow> P x s | _ \<Rightarrow> True\<rbrace>
+   f
+   \<lbrace>\<lambda>rv s. case ep of Some x \<Rightarrow> Q x s | _ \<Rightarrow> True\<rbrace>"
   by (cases ep, simp_all add: hoare_vcg_prop)
 
 lemma P_bool_lift:
@@ -439,13 +395,12 @@ lemma P_bool_lift:
   assumes f: "\<lbrace>\<lambda>s. \<not>Q s\<rbrace> f \<lbrace>\<lambda>r s. \<not>Q s\<rbrace>"
   shows "\<lbrace>\<lambda>s. P (Q s)\<rbrace> f \<lbrace>\<lambda>r s. P (Q s)\<rbrace>"
   apply (clarsimp simp: valid_def)
-  apply (subgoal_tac "Q b = Q s")
-   apply simp
+  apply (rule back_subst[where P=P], assumption)
   apply (rule iffI)
-   apply (rule classical)
-   apply (drule (1) use_valid [OF _ f])
-   apply simp
-  apply (erule (1) use_valid [OF _ t])
+   apply (erule (1) use_valid [OF _ t])
+  apply (rule classical)
+  apply (drule (1) use_valid [OF _ f])
+  apply simp
   done
 
 lemmas fail_inv = hoare_fail_any[where Q="\<lambda>_. P" and P=P for P]
@@ -453,20 +408,15 @@ lemmas fail_inv = hoare_fail_any[where Q="\<lambda>_. P" and P=P for P]
 lemma gets_sp: "\<lbrace>P\<rbrace> gets f \<lbrace>\<lambda>rv. P and (\<lambda>s. f s = rv)\<rbrace>"
   by (wp, simp)
 
-lemma post_by_hoare2:
-  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; (r, s') \<in> fst (f s); P s \<rbrakk> \<Longrightarrow> Q r s'"
-  by (rule post_by_hoare, assumption+)
-
 lemma hoare_Ball_helper:
   assumes x: "\<And>x. \<lbrace>P x\<rbrace> f \<lbrace>Q x\<rbrace>"
   assumes y: "\<And>P. \<lbrace>\<lambda>s. P (S s)\<rbrace> f \<lbrace>\<lambda>rv s. P (S s)\<rbrace>"
   shows "\<lbrace>\<lambda>s. \<forall>x \<in> S s. P x s\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x \<in> S s. Q x rv s\<rbrace>"
   apply (clarsimp simp: valid_def)
-  apply (subgoal_tac "S b = S s")
-   apply (erule post_by_hoare2 [OF x])
-   apply (clarsimp simp: Ball_def)
-  apply (erule_tac P1="\<lambda>x. x = S s" in post_by_hoare2 [OF y])
-  apply (rule refl)
+  apply (drule bspec, erule back_subst[where P="\<lambda>A. x\<in>A" for x])
+   apply (erule post_by_hoare[OF y, rotated])
+   apply (rule refl)
+  apply (erule (1) post_by_hoare[OF x])
   done
 
 lemma handy_prop_divs:
@@ -511,28 +461,28 @@ lemma hoare_ex_pre: (* safe, unlike hoare_vcg_ex_lift *)
   by (fastforce simp: valid_def)
 
 lemma hoare_ex_pre_conj:
-  "(\<And>x. \<lbrace>\<lambda>s. P x s \<and> P' s\<rbrace> f \<lbrace>Q\<rbrace>)
-  \<Longrightarrow> \<lbrace>\<lambda>s. (\<exists>x. P x s) \<and> P' s\<rbrace> f \<lbrace>Q\<rbrace>"
+  "\<lbrakk>\<And>x. \<lbrace>\<lambda>s. P x s \<and> P' s\<rbrace> f \<lbrace>Q\<rbrace>\<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. (\<exists>x. P x s) \<and> P' s\<rbrace> f \<lbrace>Q\<rbrace>"
   by (fastforce simp: valid_def)
 
 lemma hoare_conj_lift_inv:
   "\<lbrakk>\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>\<lambda>s. P' s \<and> I s\<rbrace> f \<lbrace>\<lambda>rv. I\<rbrace>;
-   \<And>s. P s \<Longrightarrow> P' s\<rbrakk>
+    \<And>s. P s \<Longrightarrow> P' s\<rbrakk>
    \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> I s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> I s\<rbrace>"
    by (fastforce simp: valid_def)
 
-lemma hoare_in_monad_post :
+lemma hoare_in_monad_post:
   assumes x: "\<And>P. \<lbrace>P\<rbrace> f \<lbrace>\<lambda>x. P\<rbrace>"
   shows      "\<lbrace>\<top>\<rbrace> f \<lbrace>\<lambda>rv s. (rv, s) \<in> fst (f s)\<rbrace>"
   apply (clarsimp simp: valid_def)
-  apply (subgoal_tac "s = b", simp)
-  apply (simp add: state_unchanged [OF x])
+  apply (rule back_subst[where P="\<lambda>s. x\<in>fst (f s)" for x], assumption)
+  apply (simp add: state_unchanged[OF x])
   done
 
 lemma list_case_throw_validE_R:
   "\<lbrakk> \<And>y ys. xs = y # ys \<Longrightarrow> \<lbrace>P\<rbrace> f y ys \<lbrace>Q\<rbrace>,- \<rbrakk> \<Longrightarrow>
    \<lbrace>P\<rbrace> case xs of [] \<Rightarrow> throwError e | x # xs \<Rightarrow> f x xs \<lbrace>Q\<rbrace>,-"
-  apply (case_tac xs, simp_all)
+  apply (cases xs, simp_all)
   apply wp
   done
 
@@ -544,7 +494,7 @@ lemma validE_R_sp:
 
 lemma valid_set_take_helper:
   "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x \<in> set (xs rv s). Q x rv s\<rbrace>
-    \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x \<in> set (take (n rv s) (xs rv s)). Q x rv s\<rbrace>"
+   \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x \<in> set (take (n rv s) (xs rv s)). Q x rv s\<rbrace>"
   apply (erule hoare_strengthen_post)
   apply (clarsimp dest!: in_set_takeD)
   done
@@ -568,37 +518,17 @@ lemma wp_split_const_if:
   assumes x: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
   assumes y: "\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>"
   shows "\<lbrace>\<lambda>s. (G \<longrightarrow> P s) \<and> (\<not> G \<longrightarrow> P' s)\<rbrace> f \<lbrace>\<lambda>rv s. (G \<longrightarrow> Q rv s) \<and> (\<not> G \<longrightarrow> Q' rv s)\<rbrace>"
-  by (case_tac G, simp_all add: x y)
+  by (cases G; simp add: x y)
 
 lemma wp_split_const_if_R:
   assumes x: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-"
   assumes y: "\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>,-"
   shows "\<lbrace>\<lambda>s. (G \<longrightarrow> P s) \<and> (\<not> G \<longrightarrow> P' s)\<rbrace> f \<lbrace>\<lambda>rv s. (G \<longrightarrow> Q rv s) \<and> (\<not> G \<longrightarrow> Q' rv s)\<rbrace>,-"
-  by (case_tac G, simp_all add: x y)
-
-lemma wp_throw_const_imp:
-  assumes x: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
-  shows      "\<lbrace>\<lambda>s. G \<longrightarrow> P s\<rbrace> f \<lbrace>\<lambda>rv s. G \<longrightarrow> Q rv s\<rbrace>"
-  by (case_tac G, simp_all add: x hoare_vcg_prop)
-
-lemma wp_throw_const_impE:
-  assumes x: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
-  shows      "\<lbrace>\<lambda>s. G \<longrightarrow> P s\<rbrace> f \<lbrace>\<lambda>rv s. G \<longrightarrow> Q rv s\<rbrace>,\<lbrace>\<lambda>rv s. G \<longrightarrow> E rv s\<rbrace>"
-  apply (case_tac G, simp_all add: x)
-  apply wp
-  done
-
-lemma hoare_const_imp_R:
-  "\<lbrace>Q\<rbrace> f \<lbrace>R\<rbrace>,- \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> f \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>,-"
-  by (cases P, simp_all)
-
-lemma hoare_vcg_imp_lift_R:
-  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>, -; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace>, - \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P' s \<or> Q' s\<rbrace> f \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>, -"
-  by (auto simp add: valid_def validE_R_def validE_def split_def split: sum.splits)
+  by (cases G; simp add: x y)
 
 lemma hoare_disj_division:
   "\<lbrakk> P \<or> Q; P \<Longrightarrow> \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace>; Q \<Longrightarrow> \<lbrace>T\<rbrace> f \<lbrace>S\<rbrace> \<rbrakk>
-     \<Longrightarrow> \<lbrace>\<lambda>s. (P \<longrightarrow> R s) \<and> (Q \<longrightarrow> T s)\<rbrace> f \<lbrace>S\<rbrace>"
+   \<Longrightarrow> \<lbrace>\<lambda>s. (P \<longrightarrow> R s) \<and> (Q \<longrightarrow> T s)\<rbrace> f \<lbrace>S\<rbrace>"
   apply safe
    apply (rule hoare_pre_imp)
     prefer 2
@@ -615,8 +545,8 @@ lemma hoare_grab_asm:
   by (cases G, simp+)
 
 lemma hoare_grab_asm2:
-  "(P' \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> R s\<rbrace> f \<lbrace>Q\<rbrace>)
-  \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> P' \<and> R s\<rbrace> f \<lbrace>Q\<rbrace>"
+  "\<lbrakk>P' \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> R s\<rbrace> f \<lbrace>Q\<rbrace>\<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> P' \<and> R s\<rbrace> f \<lbrace>Q\<rbrace>"
   by (fastforce simp: valid_def)
 
 lemma hoare_grab_exs:
@@ -631,8 +561,8 @@ lemma hoare_prop_E: "\<lbrace>\<lambda>rv. P\<rbrace> f -,\<lbrace>\<lambda>rv s
   by (rule hoare_pre, wp, simp)
 
 lemma hoare_vcg_conj_lift_R:
-  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-; \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace>,- \<rbrakk> \<Longrightarrow>
-     \<lbrace>\<lambda>s. P s \<and> R s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> S rv s\<rbrace>,-"
+  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-; \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace>,- \<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> R s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> S rv s\<rbrace>,-"
   apply (simp add: validE_R_def validE_def)
   apply (drule(1) hoare_vcg_conj_lift)
   apply (erule hoare_strengthen_post)
@@ -655,19 +585,15 @@ lemma univ_wp:
 lemma univ_get_wp:
   assumes x: "\<And>P. \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv. P\<rbrace>"
   shows "\<lbrace>\<lambda>s. \<forall>(rv, s') \<in> fst (f s). s = s' \<longrightarrow> Q rv s'\<rbrace> f \<lbrace>Q\<rbrace>"
-  apply (rule hoare_pre_imp [OF _ univ_wp])
+  apply (rule hoare_pre_imp[OF _ univ_wp])
   apply clarsimp
   apply (drule bspec, assumption, simp)
-  apply (subgoal_tac "s = b", simp)
-  apply (simp add: state_unchanged [OF x])
+  apply (drule mp)
+   apply (simp add: state_unchanged[OF x])
+  apply simp
   done
 
-lemma result_in_set_wp :
-  assumes x: "\<And>P. \<lbrace>P\<rbrace> fn \<lbrace>\<lambda>rv. P\<rbrace>"
-  shows      "\<lbrace>\<lambda>s. True\<rbrace> fn \<lbrace>\<lambda>v s'. (v, s') \<in> fst (fn s')\<rbrace>"
-  by (rule hoare_pre_imp [OF _ univ_get_wp], simp_all add: x split_def) clarsimp
-
-lemma other_result_in_set_wp:
+lemma other_hoare_in_monad_post:
   assumes x: "\<And>P. \<lbrace>P\<rbrace> fn \<lbrace>\<lambda>rv. P\<rbrace>"
   shows "\<lbrace>\<lambda>s. \<forall>(v, s) \<in> fst (fn s). F v = v\<rbrace> fn \<lbrace>\<lambda>v s'. (F v, s') \<in> fst (fn s')\<rbrace>"
   proof -
@@ -679,7 +605,7 @@ lemma other_result_in_set_wp:
   defer
    apply (rule hoare_vcg_conj_lift)
     apply (rule univ_get_wp [OF x])
-   apply (rule result_in_set_wp [OF x])
+   apply (rule hoare_in_monad_post [OF x])
   apply clarsimp
   apply (drule bspec, assumption, simp)
   done
@@ -687,7 +613,7 @@ lemma other_result_in_set_wp:
 
 lemma weak_if_wp:
   "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace> \<rbrakk> \<Longrightarrow>
-  \<lbrace>P and P'\<rbrace> f \<lbrace>\<lambda>r. if C r then Q r else Q' r\<rbrace>"
+   \<lbrace>P and P'\<rbrace> f \<lbrace>\<lambda>r. if C r then Q r else Q' r\<rbrace>"
   by (auto simp add: valid_def split_def)
 
 lemma weak_if_wp':
@@ -698,13 +624,13 @@ lemma weak_if_wp':
 lemma bindE_split_recursive_asm:
   assumes x: "\<And>x s'. \<lbrakk> (Inr x, s') \<in> fst (f s) \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. B x s \<and> s = s'\<rbrace> g x \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>"
   shows      "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>, \<lbrace>E\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>st. A st \<and> st = s\<rbrace> f >>=E g \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>"
-  apply (clarsimp simp: validE_def valid_def bindE_def bind_def lift_def)
+  apply (clarsimp simp: validE_def valid_def bindE_def in_bind lift_def)
   apply (erule allE, erule(1) impE)
   apply (drule(1) bspec, simp)
-  apply (case_tac a, simp_all add: throwError_def return_def)
+  apply (clarsimp simp: in_throwError split: sum.splits)
   apply (drule x)
   apply (clarsimp simp: validE_def valid_def)
-  apply (drule(1) bspec, simp)
+  apply (drule(1) bspec, simp split: sum.splits)
   done
 
 lemma validE_R_abstract_rv:
@@ -713,7 +639,7 @@ lemma validE_R_abstract_rv:
 
 lemma validE_cases_valid:
   "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q (Inr rv) s\<rbrace>,\<lbrace>\<lambda>rv s. Q (Inl rv) s\<rbrace>
-      \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
+   \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
   apply (simp add: validE_def)
   apply (erule hoare_strengthen_post)
   apply (simp split: sum.split_asm)
@@ -738,12 +664,10 @@ lemma hoare_gen_asm_conj:
   "(P \<Longrightarrow> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>\<lambda>s. P' s \<and> P\<rbrace> f \<lbrace>Q\<rbrace>"
   by (fastforce simp: valid_def)
 
-
 lemma hoare_add_K:
   "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> I\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> I\<rbrace>"
   by (fastforce simp: valid_def)
 
-
 lemma valid_rv_lift:
   "\<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. rv \<longrightarrow> Q rv s\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>s. P \<and> P' s\<rbrace> f \<lbrace>\<lambda>rv s. rv \<longrightarrow> P \<and> Q rv s\<rbrace>"
   by (fastforce simp: valid_def)
@@ -754,20 +678,18 @@ lemma valid_imp_ex:
 
 lemma valid_rv_split:
   "\<lbrakk>\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. rv \<longrightarrow> Q s\<rbrace>; \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. \<not>rv \<longrightarrow> Q' s\<rbrace>\<rbrakk>
-  \<Longrightarrow>
-  \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. if rv then Q s else Q' s\<rbrace>"
+   \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. if rv then Q s else Q' s\<rbrace>"
   by (fastforce simp: valid_def)
 
 lemma hoare_rv_split:
   "\<lbrakk>\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. rv \<longrightarrow> (Q rv s)\<rbrace>; \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. (\<not>rv) \<longrightarrow> (Q rv s)\<rbrace>\<rbrakk>
-  \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
-  apply (clarsimp simp: valid_def)
-  apply (case_tac a, fastforce+)
-  done
+   \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
+  apply (clarsimp simp: valid_def split_def)
+  by (metis (full_types) fst_eqD snd_conv)
 
-lemma combine_validE: "\<lbrakk> \<lbrace> P \<rbrace> x \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>;
-         \<lbrace> P' \<rbrace> x \<lbrace> Q' \<rbrace>,\<lbrace> E' \<rbrace> \<rbrakk> \<Longrightarrow>
-         \<lbrace> P and P' \<rbrace> x \<lbrace> \<lambda>r. (Q r) and (Q' r) \<rbrace>,\<lbrace>\<lambda>r. (E r) and (E' r) \<rbrace>"
+lemma combine_validE:
+  "\<lbrakk> \<lbrace> P \<rbrace> x \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>; \<lbrace> P' \<rbrace> x \<lbrace> Q' \<rbrace>,\<lbrace> E' \<rbrace> \<rbrakk>
+   \<Longrightarrow> \<lbrace> P and P' \<rbrace> x \<lbrace> \<lambda>r. (Q r) and (Q' r) \<rbrace>,\<lbrace>\<lambda>r. (E r) and (E' r) \<rbrace>"
   apply (clarsimp simp: validE_def valid_def split: sum.splits)
   apply (erule allE, erule (1) impE)+
   apply (drule (1) bspec)+
@@ -792,23 +714,19 @@ lemma validE_pre_satisfies_post:
 
 lemma hoare_validE_R_conjI:
   "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, - ; \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>, - \<rbrakk>  \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>, -"
-  apply (clarsimp simp: Ball_def validE_R_def validE_def valid_def)
-  by (case_tac a; fastforce)
+  by (clarsimp simp: Ball_def validE_R_def validE_def valid_def split: sum.splits)
 
 lemma hoare_validE_E_conjI:
   "\<lbrakk> \<lbrace>P\<rbrace> f -, \<lbrace>Q\<rbrace> ; \<lbrace>P\<rbrace> f -, \<lbrace>Q'\<rbrace> \<rbrakk>  \<Longrightarrow> \<lbrace>P\<rbrace> f -, \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>"
-  apply (clarsimp simp: Ball_def validE_E_def validE_def valid_def)
-  by (case_tac a; fastforce)
+  by (clarsimp simp: Ball_def validE_E_def validE_def valid_def split: sum.splits)
 
 lemma validE_R_post_conjD1:
   "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. Q r s \<and> R r s\<rbrace>,- \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-"
-  apply (clarsimp simp: validE_R_def validE_def valid_def)
-  by (case_tac a; fastforce)
+  by (fastforce simp: validE_R_def validE_def valid_def split: sum.splits)
 
 lemma validE_R_post_conjD2:
   "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. Q r s \<and> R r s\<rbrace>,- \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>,-"
-  apply (clarsimp simp: validE_R_def validE_def valid_def)
-  by (case_tac a; fastforce)
+  by (fastforce simp: validE_R_def validE_def valid_def split: sum.splits)
 
 lemma throw_opt_wp[wp]:
   "\<lbrace>if v = None then E ex else Q (the v)\<rbrace> throw_opt ex v \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
@@ -819,9 +737,9 @@ lemma hoare_name_pre_state2:
   by (auto simp: valid_def intro: hoare_name_pre_state)
 
 lemma returnOk_E': "\<lbrace>P\<rbrace> returnOk r -,\<lbrace>E\<rbrace>"
-  by (clarsimp simp: returnOk_def validE_E_def validE_def valid_def return_def)
+  by wpsimp
 
 lemma throwError_R': "\<lbrace>P\<rbrace> throwError e \<lbrace>Q\<rbrace>,-"
-  by (clarsimp simp:throwError_def validE_R_def validE_def valid_def return_def)
+  by wpsimp
 
 end

lib/Monads/nondet/Nondet_No_Fail.thy

@@ -160,7 +160,7 @@ lemma no_fail_spec:
 
 lemma no_fail_assertE[wp]:
   "no_fail (\<lambda>_. P) (assertE P)"
-  by (simp add: assertE_def split: if_split)
+  by (simp add: assertE_def)
 
 lemma no_fail_spec_pre:
   "\<lbrakk> no_fail (((=) s) and P') f; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> no_fail (((=) s) and P) f"
@@ -168,7 +168,7 @@ lemma no_fail_spec_pre:
 
 lemma no_fail_whenE[wp]:
   "\<lbrakk> G \<Longrightarrow> no_fail P f \<rbrakk> \<Longrightarrow> no_fail (\<lambda>s. G \<longrightarrow> P s) (whenE G f)"
-  by (simp add: whenE_def split: if_split)
+  by (simp add: whenE_def)
 
 lemma no_fail_unlessE[wp]:
   "\<lbrakk> \<not> G \<Longrightarrow> no_fail P f \<rbrakk> \<Longrightarrow> no_fail (\<lambda>s. \<not> G \<longrightarrow> P s) (unlessE G f)"
@@ -225,4 +225,12 @@ lemma no_fail_condition:
   unfolding condition_def no_fail_def
   by clarsimp
 
+lemma no_fail_ex_lift:
+  "(\<And>x. no_fail (P x) f) \<Longrightarrow> no_fail (\<lambda>s. \<exists>x. P x s) f"
+  by (clarsimp simp: no_fail_def)
+
+lemma no_fail_grab_asm:
+  "(G \<Longrightarrow> no_fail P f) \<Longrightarrow> no_fail (\<lambda>s. G \<and> P s) f"
+  by (cases G, simp+)
+
 end

lib/Monads/nondet/Nondet_No_Throw.thy

@@ -32,6 +32,8 @@ lemma no_throw_def':
   by (clarsimp simp: no_throw_def validE_def2 split_def split: sum.splits)
 
 
+subsection \<open>no_throw rules\<close>
+
 lemma no_throw_returnOk[simp]:
   "no_throw P (returnOk a)"
   unfolding no_throw_def

lib/Monads/nondet/Nondet_Sat.thy

@@ -17,7 +17,8 @@ text \<open>
   The dual to validity: an existential instead of a universal quantifier for the post condition.
   In refinement, it is often sufficient to know that there is one state that satisfies a condition.\<close>
 definition exs_valid ::
-  "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) nondet_monad \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<exists>\<lbrace>_\<rbrace>") where
+  "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) nondet_monad \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
+  ("\<lbrace>_\<rbrace> _ \<exists>\<lbrace>_\<rbrace>") where
   "\<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (\<exists>(rv, s') \<in> fst (f s). Q rv s')"
 
 text \<open>The above for the exception monad\<close>
@@ -139,7 +140,7 @@ lemma gets_exs_valid:
 
 lemma exs_valid_assert_opt[wp]:
   "\<lbrace>\<lambda>s. \<exists>x. G = Some x \<and> Q x s\<rbrace> assert_opt G \<exists>\<lbrace>Q\<rbrace>"
-  by (clarsimp simp: assert_opt_def exs_valid_def get_def assert_def bind_def' return_def)
+  by (clarsimp simp: assert_opt_def exs_valid_def return_def)
 
 lemma gets_the_exs_valid[wp]:
   "\<lbrace>\<lambda>s. \<exists>x. h s = Some x \<and> Q x s\<rbrace> gets_the h \<exists>\<lbrace>Q\<rbrace>"

lib/Monads/nondet/Nondet_Strengthen_Setup.thy

@@ -17,54 +17,49 @@ section \<open>Strengthen setup.\<close>
 context strengthen_implementation begin
 
 lemma strengthen_hoare [strg]:
-  "(\<And>r s. st F (\<longrightarrow>) (Q r s) (R r s))
-    \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>) (\<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>)"
+  "\<lbrakk>\<And>r s. st F (\<longrightarrow>) (Q r s) (R r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>) (\<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>)"
   by (cases F, auto elim: hoare_strengthen_post)
 
 lemma strengthen_validE_R_cong[strg]:
-  "(\<And>r s. st F (\<longrightarrow>) (Q r s) (R r s))
-    \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, -) (\<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>, -)"
+  "\<lbrakk>\<And>r s. st F (\<longrightarrow>) (Q r s) (R r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, -) (\<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>, -)"
   by (cases F, auto intro: hoare_post_imp_R)
 
 lemma strengthen_validE_cong[strg]:
-  "(\<And>r s. st F (\<longrightarrow>) (Q r s) (R r s))
-    \<Longrightarrow> (\<And>r s. st F (\<longrightarrow>) (S r s) (T r s))
-    \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>S\<rbrace>) (\<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>, \<lbrace>T\<rbrace>)"
+  "\<lbrakk>\<And>r s. st F (\<longrightarrow>) (Q r s) (R r s); \<And>r s. st F (\<longrightarrow>) (S r s) (T r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>S\<rbrace>) (\<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>, \<lbrace>T\<rbrace>)"
   by (cases F, auto elim: hoare_post_impErr)
 
 lemma strengthen_validE_E_cong[strg]:
-  "(\<And>r s. st F (\<longrightarrow>) (S r s) (T r s))
-    \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f -, \<lbrace>S\<rbrace>) (\<lbrace>P\<rbrace> f -, \<lbrace>T\<rbrace>)"
+  "\<lbrakk>\<And>r s. st F (\<longrightarrow>) (S r s) (T r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f -, \<lbrace>S\<rbrace>) (\<lbrace>P\<rbrace> f -, \<lbrace>T\<rbrace>)"
   by (cases F, auto elim: hoare_post_impErr simp: validE_E_def)
 
 lemma wpfix_strengthen_hoare:
-  "(\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s))
-    \<Longrightarrow> (\<And>r s. st F (\<longrightarrow>) (Q r s) (Q' r s))
-    \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>) (\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>)"
+  "\<lbrakk>\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s); \<And>r s. st F (\<longrightarrow>) (Q r s) (Q' r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>) (\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>)"
   by (cases F, auto elim: hoare_chain)
 
 lemma wpfix_strengthen_validE_R_cong:
-  "(\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s))
-    \<Longrightarrow> (\<And>r s. st F (\<longrightarrow>) (Q r s) (Q' r s))
-    \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, -) (\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>, -)"
+  "\<lbrakk>\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s); \<And>r s. st F (\<longrightarrow>) (Q r s) (Q' r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, -) (\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>, -)"
   by (cases F, auto elim: hoare_chainE simp: validE_R_def)
 
 lemma wpfix_strengthen_validE_cong:
-  "(\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s))
-    \<Longrightarrow> (\<And>r s. st F (\<longrightarrow>) (Q r s) (R r s))
-    \<Longrightarrow> (\<And>r s. st F (\<longrightarrow>) (S r s) (T r s))
-    \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>S\<rbrace>) (\<lbrace>P'\<rbrace> f \<lbrace>R\<rbrace>, \<lbrace>T\<rbrace>)"
+  "\<lbrakk>\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s); \<And>r s. st F (\<longrightarrow>) (Q r s) (R r s);
+    \<And>r s. st F (\<longrightarrow>) (S r s) (T r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>S\<rbrace>) (\<lbrace>P'\<rbrace> f \<lbrace>R\<rbrace>, \<lbrace>T\<rbrace>)"
   by (cases F, auto elim: hoare_chainE)
 
 lemma wpfix_strengthen_validE_E_cong:
-  "(\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s))
-    \<Longrightarrow> (\<And>r s. st F (\<longrightarrow>) (S r s) (T r s))
-    \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f -, \<lbrace>S\<rbrace>) (\<lbrace>P'\<rbrace> f -, \<lbrace>T\<rbrace>)"
+  "\<lbrakk>\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s); \<And>r s. st F (\<longrightarrow>) (S r s) (T r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f -, \<lbrace>S\<rbrace>) (\<lbrace>P'\<rbrace> f -, \<lbrace>T\<rbrace>)"
   by (cases F, auto elim: hoare_chainE simp: validE_E_def)
 
 lemma wpfix_no_fail_cong:
-  "(\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s))
-    \<Longrightarrow> st F (\<longrightarrow>) (no_fail P f) (no_fail P' f)"
+  "\<lbrakk>\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (no_fail P f) (no_fail P' f)"
   by (cases F, auto elim: no_fail_pre)
 
 lemmas nondet_wpfix_strgs =
@@ -79,5 +74,4 @@ end
 lemmas nondet_wpfix_strgs[wp_fix_strgs]
     = strengthen_implementation.nondet_wpfix_strgs
 
-
 end

lib/Monads/nondet/Nondet_Total.thy

@@ -20,7 +20,8 @@ text \<open>
   is often similar. The following definitions allow such reasoning to take place.\<close>
 
 definition validNF ::
-  "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!") where
+  "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
+  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!") where
   "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>! \<equiv> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<and> no_fail P f"
 
 lemma validNF_alt_def:
@@ -52,13 +53,15 @@ subsection \<open>Basic @{const validNF} theorems\<close>
 lemma validNF_make_schematic_post:
   "(\<forall>s0. \<lbrace> \<lambda>s. P s0 s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 rv s \<rbrace>!) \<Longrightarrow>
    \<lbrace> \<lambda>s. \<exists>s0. P s0 s \<and> (\<forall>rv s'. Q s0 rv s' \<longrightarrow> Q' rv s') \<rbrace> f \<lbrace> Q' \<rbrace>!"
-  by (auto simp add: valid_def validNF_def no_fail_def split: prod.splits)
+  by (auto simp: valid_def validNF_def no_fail_def
+          split: prod.splits)
 
 lemma validE_NF_make_schematic_post:
   "(\<forall>s0. \<lbrace> \<lambda>s. P s0 s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 rv s \<rbrace>, \<lbrace> \<lambda>rv s. E s0 rv s \<rbrace>!) \<Longrightarrow>
    \<lbrace> \<lambda>s. \<exists>s0. P s0 s \<and> (\<forall>rv s'. Q s0 rv s' \<longrightarrow> Q' rv s')
         \<and> (\<forall>rv s'. E s0 rv s' \<longrightarrow> E' rv s') \<rbrace> f \<lbrace> Q' \<rbrace>, \<lbrace> E' \<rbrace>!"
-  by (auto simp add: validE_NF_def validE_def valid_def no_fail_def split: prod.splits sum.splits)
+  by (auto simp: validE_NF_def validE_def valid_def no_fail_def
+          split: prod.splits sum.splits)
 
 lemma validNF_conjD1:
   "\<lbrace> P \<rbrace> f \<lbrace> \<lambda>rv s. Q rv s \<and> Q' rv s \<rbrace>! \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>!"
@@ -84,7 +87,7 @@ lemma validNF_no_fail:
   "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>! \<rbrakk> \<Longrightarrow> no_fail P f"
   by (erule validNFE)
 
-lemma snd_validNF:
+lemma validNF_not_failed:
   "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>!; P s \<rbrakk> \<Longrightarrow> \<not> snd (f s)"
   by (clarsimp simp: validNF_def no_fail_def)
 
@@ -214,7 +217,7 @@ lemma validNF_chain:
   by (fastforce simp: validNF_def valid_def no_fail_def Ball_def)
 
 lemma validNF_case_prod[wp]:
-  "(\<And>x y. \<lbrace>P x y\<rbrace> B x y \<lbrace>Q\<rbrace>!) \<Longrightarrow> \<lbrace>case v of (x, y) \<Rightarrow> P x y\<rbrace> case v of (x, y) \<Rightarrow> B x y \<lbrace>Q\<rbrace>!"
+  "\<lbrakk>\<And>x y. \<lbrace>P x y\<rbrace> B x y \<lbrace>Q\<rbrace>!\<rbrakk> \<Longrightarrow> \<lbrace>case v of (x, y) \<Rightarrow> P x y\<rbrace> case v of (x, y) \<Rightarrow> B x y \<lbrace>Q\<rbrace>!"
   by (metis prod.exhaust split_conv)
 
 lemma validE_NF_case_prod[wp]:
@@ -302,7 +305,8 @@ lemma validNF_nobindE[wp]:
 text \<open>
   Set up triple rules for @{term validE_NF} so that we can use @{method wp} combinator rules.\<close>
 definition validE_NF_property ::
-  "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> ('s, 'c+'a) nondet_monad \<Rightarrow> bool" where
+  "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> ('s, 'c+'a) nondet_monad \<Rightarrow> bool"
+  where
   "validE_NF_property Q E s b \<equiv>
    \<not> snd (b s) \<and> (\<forall>(r', s') \<in> fst (b s). case r' of Inl x \<Rightarrow> E x s' | Inr x \<Rightarrow> Q x s')"
 
@@ -344,6 +348,6 @@ lemma validE_NF_condition[wp]:
 
 lemma hoare_assume_preNF:
   "(\<And>s. P s \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>!) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>!"
-  by (metis validNF_alt_def)
+  by (simp add: validNF_alt_def)
 
 end

lib/Monads/nondet/Nondet_VCG.thy

@@ -6,16 +6,17 @@
  *)
 
 theory Nondet_VCG
-imports
-  Nondet_Lemmas
-  WPSimp
+  imports
+    Nondet_Lemmas
+    WPSimp
 begin
 
 section \<open>Hoare Logic\<close>
 
 subsection \<open>Validity\<close>
 
-text \<open>This section defines a Hoare logic for partial correctness for
+text \<open>
+  This section defines a Hoare logic for partial correctness for
   the nondeterministic state monad as well as the exception monad.
   The logic talks only about the behaviour part of the monad and ignores
   the failure flag.
@@ -34,14 +35,16 @@ text \<open>This section defines a Hoare logic for partial correctness for
   to assume @{term P}! Proving non-failure is done via a separate predicate and
   calculus (see Nondet_No_Fail).\<close>
 definition valid ::
-  "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>") where
+  "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
+  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>") where
   "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (\<forall>(r,s') \<in> fst (f s). Q r s')"
 
 text \<open>
   We often reason about invariant predicates. The following provides shorthand syntax
   that avoids repeating potentially long predicates.\<close>
 abbreviation (input) invariant ::
-  "('s,'a) nondet_monad \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool" ("_ \<lbrace>_\<rbrace>" [59,0] 60) where
+  "('s,'a) nondet_monad \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool"
+  ("_ \<lbrace>_\<rbrace>" [59,0] 60) where
   "invariant f P \<equiv> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"
 
 text \<open>
@@ -72,7 +75,6 @@ definition validE_E :: (* FIXME lib: this should be an abbreviation *)
   where
   "\<lbrace>P\<rbrace> f -,\<lbrace>E\<rbrace> \<equiv> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. \<top>\<rbrace>,\<lbrace>E\<rbrace>"
 
-
 (* These lemmas are useful to apply to rules to convert valid rules into a format suitable for wp. *)
 lemma valid_make_schematic_post:
   "(\<forall>s0. \<lbrace> \<lambda>s. P s0 s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 rv s \<rbrace>) \<Longrightarrow>
@@ -143,13 +145,17 @@ wpc_setup "\<lambda>m. \<lbrace>P\<rbrace> m -,\<lbrace>E\<rbrace>" wpc_helper_v
 
 subsection \<open>Hoare Logic Rules\<close>
 
+lemma bind_wp[wp_split]:
+  "\<lbrakk> \<And>r. \<lbrace>Q' r\<rbrace> g r \<lbrace>Q\<rbrace>; \<lbrace>P\<rbrace>f \<lbrace>Q'\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f >>= (\<lambda>rv. g rv) \<lbrace>Q\<rbrace>"
+  by (fastforce simp: valid_def bind_def' intro: image_eqI[rotated])
+
 lemma seq:
   "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>; \<And>x. P x \<Longrightarrow> \<lbrace>C\<rbrace> g x \<lbrace>D\<rbrace>; \<And>x s. B x s \<Longrightarrow> P x \<and> C s \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
   by (fastforce simp: valid_def bind_def)
 
 lemma seq_ext:
   "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>; \<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>C\<rbrace>"
-  by (fastforce simp: valid_def bind_def)
+  by (rule bind_wp)
 
 lemma seqE:
   "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>,\<lbrace>E\<rbrace>; \<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> doE x \<leftarrow> f; g x odE \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
@@ -483,12 +489,11 @@ lemmas hoare_vcg_seqE = seqE[rotated]
 
 lemma hoare_seq_ext_nobind:
   "\<lbrakk> \<lbrace>B\<rbrace> g \<lbrace>C\<rbrace>; \<lbrace>A\<rbrace> f \<lbrace>\<lambda>_. B\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> do f; g od \<lbrace>C\<rbrace>"
-  by (fastforce simp: valid_def bind_def Let_def split_def)
+  by (erule seq_ext) (clarsimp simp: valid_def)
 
 lemma hoare_seq_ext_nobindE:
   "\<lbrakk> \<lbrace>B\<rbrace> g \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>; \<lbrace>A\<rbrace> f \<lbrace>\<lambda>_. B\<rbrace>, \<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> doE f; g odE \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>"
-  by (fastforce simp: validE_def valid_def bindE_def bind_def throwError_def return_def lift_def
-                split: sum.splits)
+  by (erule seqE) (clarsimp simp: validE_def)
 
 lemmas hoare_seq_ext_skip' = hoare_seq_ext[where B=C and C=C for C]
 
@@ -516,6 +521,15 @@ lemma hoare_vcg_conj_liftE1:
   unfolding valid_def validE_R_def validE_def
   by (fastforce simp: split_def split: sum.splits)
 
+lemma hoare_vcg_conj_liftE_weaker:
+  assumes "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>"
+  assumes "\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>, \<lbrace>E\<rbrace>"
+  shows "\<lbrace>\<lambda>s. P s \<and> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>, \<lbrace>E\<rbrace>"
+  apply (rule hoare_pre)
+   apply (fastforce intro: assms hoare_vcg_conj_liftE1 validE_validE_R hoare_post_impErr)
+  apply simp
+  done
+
 lemma hoare_vcg_disj_lift:
   "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P s \<or> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<or> Q' rv s\<rbrace>"
   unfolding valid_def
@@ -547,6 +561,19 @@ lemma hoare_vcg_imp_lift':
   "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<not> P' s \<longrightarrow> Q' s\<rbrace> f \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>"
   by (wpsimp wp: hoare_vcg_imp_lift)
 
+lemma hoare_vcg_imp_liftE:
+  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>, \<lbrace>A\<rbrace>; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>A\<rbrace> \<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. \<not> P' s \<longrightarrow> Q' s\<rbrace> f \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>, \<lbrace>A\<rbrace>"
+  by (fastforce simp: validE_def valid_def split: sum.splits)
+
+lemma hoare_vcg_imp_lift_R:
+  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>, -; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace>, - \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P' s \<or> Q' s\<rbrace> f \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>, -"
+  by (auto simp add: valid_def validE_R_def validE_def split_def split: sum.splits)
+
+lemma hoare_vcg_imp_lift_R':
+  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>, -; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace>, - \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<not>P' s \<longrightarrow> Q' s\<rbrace> f \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>, -"
+  by (auto simp add: valid_def validE_R_def validE_def split_def split: sum.splits)
+
 lemma hoare_vcg_imp_conj_lift[wp_comb]:
   "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<longrightarrow> Q' rv s\<rbrace>; \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. (Q rv s \<longrightarrow> Q'' rv s) \<and> Q''' rv s\<rbrace> \<rbrakk> \<Longrightarrow>
    \<lbrace>P and P'\<rbrace> f \<lbrace>\<lambda>rv s. (Q rv s \<longrightarrow> Q' rv s \<and> Q'' rv s) \<and> Q''' rv s\<rbrace>"
@@ -567,6 +594,10 @@ lemma hoare_vcg_const_imp_lift:
   "\<lbrakk> P \<Longrightarrow> \<lbrace>Q\<rbrace> m \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> m \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>"
   by (cases P, simp_all add: hoare_vcg_prop)
 
+lemma hoare_vcg_const_imp_lift_E:
+  "(P \<Longrightarrow> \<lbrace>Q\<rbrace> f -, \<lbrace>R\<rbrace>) \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> f -, \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>"
+  by (fastforce simp: validE_E_def validE_def valid_def split_def split: sum.splits)
+
 lemma hoare_vcg_const_imp_lift_R:
   "(P \<Longrightarrow> \<lbrace>Q\<rbrace> m \<lbrace>R\<rbrace>,-) \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> m \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>,-"
   by (fastforce simp: validE_R_def validE_def valid_def split_def split: sum.splits)
@@ -575,6 +606,14 @@ lemma hoare_weak_lift_imp:
   "\<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> P' s\<rbrace> f \<lbrace>\<lambda>rv s. P \<longrightarrow> Q rv s\<rbrace>"
   by (auto simp add: valid_def split_def)
 
+lemma hoare_weak_lift_impE:
+  "\<lbrace>Q\<rbrace> m \<lbrace>R\<rbrace>,\<lbrace>E\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> m \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>,\<lbrace>\<lambda>rv s. P \<longrightarrow> E rv s\<rbrace>"
+  by (cases P; simp add: validE_def hoare_vcg_prop)
+
+lemma hoare_weak_lift_imp_R:
+  "\<lbrace>Q\<rbrace> m \<lbrace>R\<rbrace>,- \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> m \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>,-"
+  by (cases P, simp_all)
+
 lemmas hoare_vcg_weaken_imp = hoare_weaken_imp  (* FIXME lib: eliminate *)
 
 lemma hoare_vcg_ex_lift:
@@ -662,6 +701,58 @@ lemma hoare_post_comb_imp_conj:
   "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>"
   by (wpsimp wp: hoare_vcg_conj_lift)
 
+lemma hoare_vcg_if_lift:
+  "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P \<longrightarrow> X rv s) \<and> (\<not>P \<longrightarrow> Y rv s)\<rbrace> \<Longrightarrow>
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. if P then X rv s else Y rv s\<rbrace>"
+
+  "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P \<longrightarrow> X rv s) \<and> (\<not>P \<longrightarrow> Y rv s)\<rbrace> \<Longrightarrow>
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv. if P then X rv else Y rv\<rbrace>"
+  by (auto simp: valid_def split_def)
+
+lemma hoare_vcg_disj_lift_R:
+  assumes x: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-"
+  assumes y: "\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>,-"
+  shows      "\<lbrace>\<lambda>s. P s \<or> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<or> Q' rv s\<rbrace>,-"
+  using assms
+  by (fastforce simp: validE_R_def validE_def valid_def split: sum.splits)
+
+lemma hoare_vcg_all_liftE:
+  "\<lbrakk> \<And>x. \<lbrace>P x\<rbrace> f \<lbrace>Q x\<rbrace>,\<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<forall>x. P x s\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x. Q x rv s\<rbrace>,\<lbrace>E\<rbrace>"
+  by (fastforce simp: validE_def valid_def split: sum.splits)
+
+lemma hoare_vcg_const_Ball_liftE:
+  "\<lbrakk> \<And>x. x \<in> S \<Longrightarrow> \<lbrace>P x\<rbrace> f \<lbrace>Q x\<rbrace>,\<lbrace>E\<rbrace>; \<lbrace>\<lambda>s. True\<rbrace> f \<lbrace>\<lambda>r s. True\<rbrace>, \<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<forall>x\<in>S. P x s\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x\<in>S. Q x rv s\<rbrace>,\<lbrace>E\<rbrace>"
+  by (fastforce simp: validE_def valid_def split: sum.splits)
+
+lemma hoare_vcg_split_lift[wp]:
+  "\<lbrace>P\<rbrace> f x y \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> case (x, y) of (a, b) \<Rightarrow> f a b \<lbrace>Q\<rbrace>"
+  by simp
+
+named_theorems hoare_vcg_op_lift
+lemmas [hoare_vcg_op_lift] =
+  hoare_vcg_const_imp_lift
+  hoare_vcg_const_imp_lift_E
+  hoare_vcg_const_imp_lift_R
+  (* leaving out hoare_vcg_conj_lift*, because that is built into wp *)
+  hoare_vcg_disj_lift
+  hoare_vcg_disj_lift_R
+  hoare_vcg_ex_lift
+  hoare_vcg_ex_liftE
+  hoare_vcg_ex_liftE_E
+  hoare_vcg_all_lift
+  hoare_vcg_all_liftE
+  hoare_vcg_all_liftE_E
+  hoare_vcg_all_lift_R
+  hoare_vcg_const_Ball_lift
+  hoare_vcg_const_Ball_lift_R
+  hoare_vcg_const_Ball_lift_E_E
+  hoare_vcg_split_lift
+  hoare_vcg_if_lift
+  hoare_vcg_imp_lift'
+  hoare_vcg_imp_liftE
+  hoare_vcg_imp_lift_R
+  hoare_vcg_imp_liftE_E
+
 
 subsection \<open>Weakest Precondition Rules\<close>
 
@@ -675,19 +766,20 @@ lemma return_wp:
 
 lemma get_wp:
   "\<lbrace>\<lambda>s. P s s\<rbrace> get \<lbrace>P\<rbrace>"
-  by(simp add: valid_def split_def get_def)
+  by (simp add: valid_def get_def)
 
 lemma gets_wp:
   "\<lbrace>\<lambda>s. P (f s) s\<rbrace> gets f \<lbrace>P\<rbrace>"
   by(simp add: valid_def split_def gets_def return_def get_def bind_def)
 
-lemma modify_wp:
-  "\<lbrace>\<lambda>s. P () (f s)\<rbrace> modify f \<lbrace>P\<rbrace>"
-  by(simp add: valid_def split_def modify_def get_def put_def bind_def)
-
 lemma put_wp:
-  "\<lbrace>\<lambda>s. P () x\<rbrace> put x \<lbrace>P\<rbrace>"
-  by(simp add: valid_def put_def)
+  "\<lbrace>\<lambda>_. Q () s\<rbrace> put s \<lbrace>Q\<rbrace>"
+  by (simp add: put_def valid_def)
+
+lemma modify_wp:
+  "\<lbrace>\<lambda>s. Q () (f s)\<rbrace> modify f \<lbrace>Q\<rbrace>"
+  unfolding modify_def
+  by (wp put_wp get_wp)
 
 lemma failE_wp:
   "\<lbrace>\<top>\<rbrace> fail \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>"
@@ -785,7 +877,8 @@ lemma select_f_wp:
 
 lemma state_select_wp:
   "\<lbrace>\<lambda>s. \<forall>t. (s, t) \<in> f \<longrightarrow> P () t\<rbrace> state_select f \<lbrace>P\<rbrace>"
-  by (clarsimp simp: state_select_def valid_def)
+  unfolding state_select_def2
+  by (wpsimp wp: put_wp select_wp return_wp get_wp assert_wp)
 
 lemma condition_wp:
   "\<lbrakk> \<lbrace>Q\<rbrace> A \<lbrace>P\<rbrace>;  \<lbrace>R\<rbrace> B \<lbrace>P\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. if C s then Q s else R s\<rbrace> condition C A B \<lbrace>P\<rbrace>"
@@ -820,18 +913,18 @@ lemma unlessE_wp:
 lemma maybeM_wp:
   "(\<And>x. y = Some x \<Longrightarrow> \<lbrace>P x\<rbrace> m x \<lbrace>Q\<rbrace>) \<Longrightarrow>
    \<lbrace>\<lambda>s. (\<forall>x. y = Some x \<longrightarrow> P x s) \<and> (y = None \<longrightarrow> Q () s)\<rbrace> maybeM m y \<lbrace>Q\<rbrace>"
-  unfolding maybeM_def by (cases y; simp add: bind_def return_def valid_def)
+  unfolding maybeM_def by (wpsimp wp: return_wp) auto
 
 lemma notM_wp:
   "\<lbrace>P\<rbrace> m \<lbrace>\<lambda>c. Q (\<not> c)\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> notM m \<lbrace>Q\<rbrace>"
-  unfolding notM_def by (fastforce simp: bind_def return_def valid_def)
+  unfolding notM_def by (wpsimp wp: return_wp)
 
 lemma ifM_wp:
   assumes [wp]: "\<lbrace>Q\<rbrace> f \<lbrace>S\<rbrace>" "\<lbrace>R\<rbrace> g \<lbrace>S\<rbrace>"
   assumes [wp]: "\<lbrace>A\<rbrace> P \<lbrace>\<lambda>c s. c \<longrightarrow> Q s\<rbrace>" "\<lbrace>B\<rbrace> P \<lbrace>\<lambda>c s. \<not>c \<longrightarrow> R s\<rbrace>"
   shows "\<lbrace>A and B\<rbrace> ifM P f g \<lbrace>S\<rbrace>"
-  unfolding ifM_def using assms
-  by (fastforce simp: bind_def valid_def split: if_splits)
+  unfolding ifM_def
+  by (wpsimp wp: hoare_vcg_if_split hoare_vcg_conj_lift)
 
 lemma andM_wp:
   assumes [wp]: "\<lbrace>Q'\<rbrace> B \<lbrace>Q\<rbrace>"
@@ -889,7 +982,7 @@ lemmas liftME_E_E_wp[wp_split] = validE_validE_E [OF liftME_wp, simplified, OF v
 lemma assert_opt_wp:
   "\<lbrace>\<lambda>s. x \<noteq> None \<longrightarrow> Q (the x) s\<rbrace> assert_opt x \<lbrace>Q\<rbrace>"
   unfolding assert_opt_def
-  by (case_tac x; wpsimp wp: fail_wp return_wp)
+  by (cases x; wpsimp wp: fail_wp return_wp)
 
 lemma gets_the_wp:
   "\<lbrace>\<lambda>s. (f s \<noteq> None) \<longrightarrow> Q (the (f s)) s\<rbrace> gets_the f \<lbrace>Q\<rbrace>"
@@ -1327,5 +1420,4 @@ lemmas hoare_forward_inv_step_validE_R[forward_inv_step_rules] =
 method forward_inv_step uses wp simp =
   rule forward_inv_step_rules, solves \<open>wpsimp wp: wp simp: simp\<close>
 
-
 end

lib/Monads/nondet/Nondet_While_Loop_Rules.thy

@@ -47,12 +47,14 @@ text \<open>
 \<close>
 definition whileLoop_inv ::
   "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b, 'a) nondet_monad) \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
-   (('a \<times> 'b) \<times> 'a \<times> 'b) set \<Rightarrow> ('b, 'a) nondet_monad" where
+   (('a \<times> 'b) \<times> 'a \<times> 'b) set \<Rightarrow> ('b, 'a) nondet_monad"
+  where
   "whileLoop_inv C B x I R \<equiv> whileLoop C B x"
 
 definition whileLoopE_inv ::
   "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b, 'c + 'a) nondet_monad) \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
-   (('a \<times> 'b) \<times> 'a \<times> 'b) set \<Rightarrow> ('b, 'c + 'a) nondet_monad" where
+   (('a \<times> 'b) \<times> 'a \<times> 'b) set \<Rightarrow> ('b, 'c + 'a) nondet_monad"
+  where
   "whileLoopE_inv C B x I R \<equiv> whileLoopE C B x"
 
 lemma whileLoop_add_inv:
@@ -284,22 +286,35 @@ lemma fst_whileLoop_cond_false:
   using loop_result
   by (rule in_whileLoop_induct, auto)
 
+lemma whileLoop_terminates_results:
+  assumes non_term: "\<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<and> \<not> snd (B r s) \<rbrace> B r \<exists>\<lbrace> \<lambda>r' s'. C r' s' \<and> I r' s' \<rbrace>"
+  shows
+    "\<lbrakk>whileLoop_terminates C B r s; (Some (r, s), None) \<notin> whileLoop_results C B; I r s; C r s\<rbrakk>
+     \<Longrightarrow> False"
+proof (induct rule: whileLoop_terminates.induct)
+  case (1 r s)
+  then show ?case
+    apply clarsimp
+    done
+next
+  case (2 r s)
+  then show ?case
+    apply (cut_tac non_term[where r=r])
+    apply (clarsimp simp: exs_valid_def)
+    apply (subst (asm) (2) whileLoop_results.simps)
+    apply clarsimp
+    apply (insert whileLoop_results.simps)
+    apply fast
+    done
+qed
+
 lemma snd_whileLoop:
   assumes init_I: "I r s"
-      and cond_I: "C r s"
-      and non_term:  "\<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<and> \<not> snd (B r s) \<rbrace> B r \<exists>\<lbrace> \<lambda>r' s'. C r' s' \<and> I r' s' \<rbrace>"
+    and cond_I: "C r s"
+    and non_term: "\<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<and> \<not> snd (B r s) \<rbrace> B r \<exists>\<lbrace> \<lambda>r' s'. C r' s' \<and> I r' s' \<rbrace>"
   shows "snd (whileLoop C B r s)"
   apply (clarsimp simp: whileLoop_def)
-  apply (rotate_tac)
-  apply (insert init_I cond_I)
-  apply (induct rule: whileLoop_terminates.induct)
-   apply clarsimp
-  apply (cut_tac r=r in non_term)
-  apply (clarsimp simp: exs_valid_def)
-   apply (subst (asm) (2) whileLoop_results.simps)
-   apply clarsimp
-  apply (insert whileLoop_results.simps)
-  apply fast
+  apply (erule (1) whileLoop_terminates_results[OF non_term _ _ init_I cond_I])
   done
 
 lemma whileLoop_terminates_inv:
@@ -332,7 +347,7 @@ proof -
       apply (induct arbitrary: r s rule: whileLoop_results.inducts)
         apply simp
        apply simp
-       apply (insert snd_validNF [OF inv_holds])[1]
+       apply (insert validNF_not_failed[OF inv_holds])[1]
        apply blast
       apply (drule use_validNF [OF _ inv_holds])
        apply simp
@@ -427,11 +442,11 @@ lemma whileLoopE_wp:
   by (rule validE_whileLoopE)
 
 lemma exs_valid_whileLoop:
- assumes init_T: "\<And>s. P s \<Longrightarrow> T r s"
+  assumes init_T: "\<And>s. P s \<Longrightarrow> T r s"
     and iter_I: "\<And>r s0. \<lbrace>\<lambda>s. T r s \<and> C r s \<and> s = s0\<rbrace> B r \<exists>\<lbrace>\<lambda>r' s'. T r' s' \<and> ((r', s'),(r, s0)) \<in> R\<rbrace>"
     and wf_R: "wf R"
     and final_I: "\<And>r s. \<lbrakk> T r s; \<not> C r s  \<rbrakk> \<Longrightarrow> Q r s"
- shows "\<lbrace> P \<rbrace> whileLoop C B r \<exists>\<lbrace> Q \<rbrace>"
+  shows "\<lbrace> P \<rbrace> whileLoop C B r \<exists>\<lbrace> Q \<rbrace>"
 proof (clarsimp simp: exs_valid_def Bex_def)
   fix s
   assume "P s"
@@ -440,17 +455,21 @@ proof (clarsimp simp: exs_valid_def Bex_def)
     fix x
     have "T (fst x) (snd x) \<Longrightarrow> \<exists>r' s'. (r', s') \<in> fst (whileLoop C B (fst x) (snd x)) \<and> T r' s'"
       using wf_R
-      apply induction
-      apply atomize
-      apply (case_tac "C (fst x) (snd x)")
-       apply (subst whileLoop_unroll)
-       apply (clarsimp simp: condition_def bind_def' split: prod.splits)
-       apply (cut_tac ?s0.0=b and r=a in iter_I)
-       apply (clarsimp simp: exs_valid_def)
-       apply blast
-      apply (subst whileLoop_unroll)
-      apply (clarsimp simp: condition_def bind_def' return_def)
-      done
+    proof induct
+      case (less x)
+      then show ?case
+        apply atomize
+        apply (cases "C (fst x) (snd x)")
+         apply (subst whileLoop_unroll)
+         apply (clarsimp simp: condition_def bind_def')
+         apply (cut_tac iter_I[where ?s0.0="snd x" and r="fst x"])
+         apply (clarsimp simp: exs_valid_def)
+         apply blast
+        apply (subst whileLoop_unroll)
+        apply (cases x)
+        apply (clarsimp simp: condition_def bind_def' return_def)
+        done
+    qed
   }
 
   thus "\<exists>r' s'. (r', s') \<in> fst (whileLoop C B r s) \<and> Q r' s'"
@@ -475,8 +494,7 @@ proof -
         apply fact
        apply (rule cond_true, fact)
       apply (clarsimp simp: exs_valid_def)
-      apply (case_tac "fst (B r s) = {}")
-       apply (metis empty_failD [OF body_empty_fail])
+      apply (drule empty_failD3[OF body_empty_fail])
       apply (subst (asm) whileLoop_unroll)
       apply (fastforce simp: condition_def bind_def split_def cond_true)
       done
@@ -496,33 +514,59 @@ lemma empty_fail_whileM[empty_fail_cond, intro!, wp]:
   unfolding whileM_def
   by (wpsimp wp: empty_fail_whileLoop empty_fail_bind)
 
-lemma whileLoop_results_bisim:
+lemma whileLoop_results_bisim_helper:
   assumes base: "(a, b) \<in> whileLoop_results C B"
-  and vars1: "Q = (case a of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
-  and vars2: "R = (case b of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
-  and inv_init: "case a of Some (r, s) \<Rightarrow> I r s | _ \<Rightarrow> True"
-  and inv_step: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> I r' s'"
-  and cond_match: "\<And>r s. I r s \<Longrightarrow> C r s = C' (rt r) (st s)"
-  and fail_step: "\<And>r s. \<lbrakk>C r s; snd (B r s); I r s\<rbrakk>
+    and inv_init: "case a of Some (r, s) \<Rightarrow> I r s | _ \<Rightarrow> True"
+    and inv_step: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> I r' s'"
+    and cond_match: "\<And>r s. I r s \<Longrightarrow> C r s = C' (rt r) (st s)"
+    and fail_step: "\<And>r s. \<lbrakk>C r s; snd (B r s); I r s\<rbrakk>
                          \<Longrightarrow> (Some (rt r, st s), None) \<in> whileLoop_results C' B'"
-  and refine: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in>  fst (B r s) \<rbrakk>
+    and refine: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in>  fst (B r s) \<rbrakk>
                             \<Longrightarrow> (rt r', st s') \<in> fst (B' (rt r) (st s))"
-  shows "(Q, R) \<in> whileLoop_results C' B'"
-  apply (subst vars1)
-  apply (subst vars2)
-  apply (insert base inv_init)
-  apply (induct rule: whileLoop_results.induct)
+  defines [simp]: "Q x \<equiv> (case x of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
+    and [simp]: "R y\<equiv> (case y of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
+  shows "(Q a, R b) \<in> whileLoop_results C' B'"
+  using base inv_init
+proof (induct rule: whileLoop_results.induct)
+  case (1 r s)
+  then show ?case
     apply clarsimp
     apply (subst (asm) cond_match)
      apply (clarsimp simp: option.splits)
     apply (clarsimp simp: option.splits)
-   apply (clarsimp simp: option.splits)
-   apply (metis fail_step)
-  apply (case_tac z)
-   apply (clarsimp simp: option.splits)
-   apply (metis cond_match inv_step refine whileLoop_results.intros(3))
-  apply (clarsimp simp: option.splits)
-  apply (metis cond_match inv_step refine whileLoop_results.intros(3))
+    done
+next
+  case (2 r s)
+  then show ?case
+    apply (clarsimp simp: option.splits)
+    apply (metis fail_step)
+    done
+next
+  case (3 r s r' s' z)
+  then show ?case
+    apply (cases z)
+     apply (clarsimp simp: option.splits)
+     apply (metis cond_match inv_step refine whileLoop_results.intros(3))
+    apply (clarsimp simp: option.splits)
+    apply (metis cond_match inv_step refine whileLoop_results.intros(3))
+    done
+qed
+
+lemma whileLoop_results_bisim:
+  assumes base: "(a, b) \<in> whileLoop_results C B"
+    and vars1: "Q = (case a of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
+    and vars2: "R = (case b of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
+    and inv_init: "case a of Some (r, s) \<Rightarrow> I r s | _ \<Rightarrow> True"
+    and inv_step: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> I r' s'"
+    and cond_match: "\<And>r s. I r s \<Longrightarrow> C r s = C' (rt r) (st s)"
+    and fail_step: "\<And>r s. \<lbrakk>C r s; snd (B r s); I r s\<rbrakk>
+                         \<Longrightarrow> (Some (rt r, st s), None) \<in> whileLoop_results C' B'"
+    and refine: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in>  fst (B r s) \<rbrakk>
+                            \<Longrightarrow> (rt r', st s') \<in> fst (B' (rt r) (st s))"
+  shows "(Q, R) \<in> whileLoop_results C' B'"
+  apply (subst vars1, subst vars2)
+  apply (rule whileLoop_results_bisim_helper)
+       apply (rule assms; assumption?)+
   done
 
 lemma whileLoop_terminates_liftE:
@@ -562,6 +606,10 @@ lemma snd_X_return[simp]:
   "snd ((A >>= (\<lambda>a. return (X a))) s) = snd (A s)"
   by (clarsimp simp: return_def bind_def split_def)
 
+lemma isr_Inr_projr:
+  "\<not> isl a \<Longrightarrow> (a = Inr b) = (b = projr a)"
+  by auto
+
 lemma whileLoopE_liftE:
   "whileLoopE C (\<lambda>r. liftE (B r)) r = liftE (whileLoop C B r)"
   apply (rule ext)
@@ -569,30 +617,33 @@ lemma whileLoopE_liftE:
   apply (rule prod_eqI)
    apply (rule set_eqI, rule iffI)
     apply clarsimp
-    apply (clarsimp simp: in_bind whileLoop_def liftE_def)
-    apply (rule_tac x="b" in exI)
-    apply (rule_tac x="projr a" in exI)
+    apply (clarsimp simp: in_liftE whileLoop_def)
+    \<comment> \<open>The schematic existential is instantiated by 'subst isr_Inr_proj' ... 'rule refl' in two lines\<close>
+    apply (rule exI)
     apply (rule conjI)
-     apply (erule whileLoop_results_bisim[where rt=projr
-                                            and st="\<lambda>x. x"
-                                            and I="\<lambda>r s. case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"],
-            auto intro: whileLoop_results.intros simp: bind_def return_def lift_def split: sum.splits)[1]
-    apply (drule whileLoop_results_induct_lemma2[where P="\<lambda>(r, s). case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"])
+     apply (subst isr_Inr_projr)
+      prefer 2
+      apply (rule refl)
+     apply (drule whileLoop_results_induct_lemma2[where P="\<lambda>(r, s). \<not> isl r"])
+         apply (rule refl)
         apply (rule refl)
-       apply (rule refl)
-      apply clarsimp
-     apply (clarsimp simp: return_def bind_def lift_def split: sum.splits)
-    apply (clarsimp simp: return_def bind_def lift_def split: sum.splits)
-   apply (clarsimp simp: in_bind whileLoop_def liftE_def)
+       apply clarsimp
+      apply (clarsimp simp: return_def bind_def lift_def liftE_def split: sum.splits)
+     apply clarsimp
+    apply (erule whileLoop_results_bisim[where rt=projr
+                                           and st="\<lambda>x. x"
+                                           and I="\<lambda>r s. \<not> isl r"],
+           auto intro: whileLoop_results.intros simp: bind_def return_def lift_def liftE_def split: sum.splits)[1]
+   apply (clarsimp simp: in_liftE whileLoop_def)
    apply (erule whileLoop_results_bisim[where rt=Inr and st="\<lambda>x. x" and I="\<lambda>r s. True"],
-          auto intro: whileLoop_results.intros intro!: bexI simp: bind_def return_def lift_def
-               split: sum.splits)[1]
+          auto intro: whileLoop_results.intros intro!: bexI
+               simp: bind_def return_def lift_def liftE_def split: sum.splits)[1]
   apply (rule iffI)
    apply (clarsimp simp: whileLoop_def liftE_def del: notI)
    apply (erule disjE)
     apply (erule whileLoop_results_bisim[where rt=projr
                                            and st="\<lambda>x. x"
-                                           and I="\<lambda>r s. case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"],
+                                           and I="\<lambda>r s. \<not> isl r"],
            auto intro: whileLoop_results.intros simp: bind_def return_def lift_def split: sum.splits)[1]
    apply (subst (asm) whileLoop_terminates_liftE [symmetric])
    apply (fastforce simp: whileLoop_def liftE_def whileLoop_terminatesE_def)

lib/Monads/nondet/Nondet_While_Loop_Rules_Completeness.thy

@@ -11,7 +11,7 @@
  * You probably don't care about this.
  *)
 theory Nondet_While_Loop_Rules_Completeness
-imports Nondet_While_Loop_Rules
+  imports Nondet_While_Loop_Rules
 begin
 
 lemma whileLoop_rule_strong_complete:
@@ -34,12 +34,14 @@ lemma valid_whileLoop_complete:
     = \<lbrace> P r \<rbrace> whileLoop C B r \<lbrace> Q \<rbrace>"
   apply (rule iffI)
    apply clarsimp
+   apply (rename_tac I)
    apply (rule_tac I=I in valid_whileLoop, auto)[1]
   apply (rule exI [where x="\<lambda>r s. \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<lbrace> Q \<rbrace>"])
   apply (intro conjI)
     apply (clarsimp simp: valid_def)
    apply (subst (2) valid_def)
    apply clarsimp
+   apply (rename_tac a b)
    apply (subst (asm) (2) whileLoop_unroll)
    apply (case_tac "C a b")
     apply (clarsimp simp: valid_def bind_def' Bex_def condition_def split: if_split_asm)
@@ -66,7 +68,7 @@ proof (rule iffI)
     by auto
 
   thus ?RHS
-    by (rule_tac validNF_whileLoop [where I=I and R=R], auto)
+    by - (rule validNF_whileLoop[where I=I and R=R], auto)
 next
   assume loop: "?RHS"
 
@@ -225,6 +227,10 @@ where
   | "valid_path C B [x] = (\<not> C (fst x) (snd x))"
   | "valid_path C B (x#y#xs) = ((C (fst x) (snd x) \<and> y \<in> fst (B (fst x) (snd x)) \<and> valid_path C B (y#xs)))"
 
+lemma valid_path_not_empty:
+  "valid_path C B xs \<Longrightarrow> xs \<noteq> []"
+  by clarsimp
+
 definition "shortest_path_length C B x Q \<equiv>
         (LEAST n. \<exists>l. valid_path C B l \<and> hd l = x \<and> Q (fst (last l)) (snd (last l)) \<and> length l = n)"
 
@@ -234,8 +240,7 @@ lemma shortest_path_length_same [simp]:
   apply (rule Least_equality)
    apply (rule exI [where x="[a]"])
    apply clarsimp
-  apply (case_tac "y = 0")
-   apply clarsimp
+  apply (rule Suc_leI)
   apply clarsimp
   done
 
@@ -243,9 +248,8 @@ lemma valid_path_simp:
   "valid_path C B l =
         (((\<exists>r s. l = [(r, s)] \<and> \<not> C r s) \<or>
               (\<exists>r s r' s' xs. l = (r, s)#(r', s')#xs \<and> C r s \<and> (r', s') \<in> fst (B r s) \<and> valid_path C B ((r', s')#xs))))"
-  apply (case_tac l)
-   apply clarsimp
-  apply (case_tac list)
+  apply (cases l rule: remdups_adj.cases)
+    apply clarsimp
    apply clarsimp
   apply clarsimp
   done
@@ -260,15 +264,23 @@ proof -
     assume y: "Q r' s'"
     have ?thesis
       using x y
-      apply (induct rule: in_whileLoop_induct)
-       apply (rule_tac x="[(r,s)]" in exI)
-       apply clarsimp
-      apply clarsimp
-      apply (case_tac l)
-       apply clarsimp
-      apply (rule_tac x="(r, s)#l" in exI)
-      apply clarsimp
-      done
+    proof (induct rule: in_whileLoop_induct)
+      case (1 r s)
+      then show ?case
+        apply -
+        apply (rule exI[where x="[(r,s)]"])
+        apply clarsimp
+        done
+    next
+      case (2 r s r' s' r'' s'')
+      then show ?case
+        apply clarsimp
+        apply (frule valid_path_not_empty)
+        apply (rename_tac l)
+        apply (rule_tac x="(r, s)#l" in exI)
+        apply (clarsimp simp: neq_Nil_conv)
+        done
+    qed
   }
 
   thus ?thesis
@@ -297,27 +309,33 @@ lemma shortest_path_is_shortest:
   done
 
 lemma valid_path_implies_exs_valid_whileLoop:
-    "valid_path C B l \<Longrightarrow> \<lbrace> \<lambda>s. s = snd (hd l) \<rbrace> whileLoop C B (fst (hd l)) \<exists>\<lbrace> \<lambda>r s. (r, s) = last l  \<rbrace>"
-  apply (induct l)
-   apply clarsimp
-  apply clarsimp
-  apply rule
-   apply clarsimp
-   apply (subst whileLoop_unroll)
-   apply (clarsimp simp: condition_def bind_def' exs_valid_def return_def)
-  apply clarsimp
-  apply (subst whileLoop_unroll)
-  apply (clarsimp simp: condition_def bind_def' exs_valid_def return_def)
-  apply rule
-   apply (clarsimp split: prod.splits)
-   apply (case_tac l)
+  "valid_path C B l \<Longrightarrow> \<lbrace> \<lambda>s. s = snd (hd l) \<rbrace> whileLoop C B (fst (hd l)) \<exists>\<lbrace> \<lambda>r s. (r, s) = last l  \<rbrace>"
+proof (induct l)
+  case Nil
+  then show ?case
+    by clarsimp
+next
+  case (Cons a l)
+  then show ?case
     apply clarsimp
-   apply (clarsimp split del: if_split)
-   apply (erule bexI [rotated])
-   apply clarsimp
-  apply clarsimp
-  apply (case_tac l, auto)
-  done
+    apply rule
+     apply clarsimp
+     apply (subst whileLoop_unroll)
+     apply (clarsimp simp: condition_def bind_def' exs_valid_def return_def)
+    apply clarsimp
+    apply (subst whileLoop_unroll)
+    apply (clarsimp simp: condition_def bind_def' exs_valid_def return_def)
+    apply rule
+     apply (clarsimp split: prod.splits)
+     apply (cases l)
+      apply clarsimp
+     apply (clarsimp split del: if_split)
+     apply (erule bexI[rotated])
+     apply clarsimp
+    apply clarsimp
+    apply (cases l; clarsimp)
+    done
+qed
 
 lemma shortest_path_gets_shorter:
   "\<lbrakk> \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<exists>\<lbrace> Q \<rbrace>;
@@ -327,21 +345,22 @@ lemma shortest_path_gets_shorter:
                  \<and> \<lbrace> \<lambda>s. s = s' \<rbrace> whileLoop C B r' \<exists>\<lbrace> Q \<rbrace>"
   apply (drule shortest_path_exists)
   apply clarsimp
-  apply (case_tac l)
+  apply (rename_tac l)
+  apply (case_tac l rule: remdups_adj.cases)
+    apply clarsimp
    apply clarsimp
-  apply (case_tac list)
+  apply (rule bexI[rotated])
    apply clarsimp
-  apply (rule_tac x="aa" in bexI)
-   apply clarify
-   apply (simp only: valid_path.simps, clarify)
-   apply (frule shortest_path_is_shortest [where Q=Q])
-    apply simp
-   apply clarsimp
-   apply (drule valid_path_implies_exs_valid_whileLoop)
-   apply (clarsimp simp: exs_valid_def)
-   apply (erule bexI [rotated])
-   apply (clarsimp split: if_split_asm)
+   apply assumption
+  apply clarify
+  apply (simp only: valid_path.simps, clarify)
+  apply (frule shortest_path_is_shortest [where Q=Q])
+   apply simp
   apply clarsimp
+  apply (drule valid_path_implies_exs_valid_whileLoop)
+  apply (clarsimp simp: exs_valid_def)
+  apply (erule bexI [rotated])
+  apply (clarsimp split: if_split_asm)
   done
 
 lemma exs_valid_whileLoop_complete:

lib/Monads/reader_option/Reader_Option_ND.thy

@@ -118,6 +118,15 @@ lemma gets_the_Some:
   "gets_the (\<lambda>_. Some x) = return x"
   by (simp add: gets_the_def assert_opt_Some)
 
+lemma gets_the_oapply2_comp:
+  "gets_the (oapply2 y x \<circ> f) = gets_map (swp f y) x"
+  by (clarsimp simp: gets_map_def gets_the_def o_def gets_def)
+
+lemma gets_obind_bind_eq:
+  "(gets (f |>> (\<lambda>x. g x))) =
+   (gets f >>= (\<lambda>x. case x of None \<Rightarrow> return None | Some y \<Rightarrow> gets (g y)))"
+  by (auto simp: simpler_gets_def bind_def obind_def return_def split: option.splits)
+
 lemma fst_assert_opt:
   "fst (assert_opt opt s) = (if opt = None then {} else {(the opt,s)})"
   by (clarsimp simp: assert_opt_def fail_def return_def split: option.split)

lib/Monads/trace/Trace_Empty_Fail.thy

@@ -0,0 +1,368 @@
+(*
+ * Copyright 2023, Proofcraft Pty Ltd
+ * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
+ *
+ * SPDX-License-Identifier: BSD-2-Clause
+ *)
+
+theory Trace_Empty_Fail
+  imports
+    Trace_Monad
+    WPSimp
+begin
+
+section \<open>Monads that are wellformed w.r.t. failure\<close>
+
+text \<open>
+  Usually, well-formed monads constructed from the primitives in Trace_Monad will have the following
+  property: if they return an empty set of completed results, there exists a trace corresponding to
+  a failed result.\<close>
+definition empty_fail :: "('s,'a) tmonad \<Rightarrow> bool" where
+  "empty_fail m \<equiv> \<forall>s. mres (m s) = {} \<longrightarrow> Failed \<in> snd ` (m s)"
+
+text \<open>Useful in forcing otherwise unknown executions to have the @{const empty_fail} property.\<close>
+definition mk_ef ::
+  "((tmid \<times> 's) list \<times> ('s, 'a) tmres) set \<Rightarrow> ((tmid \<times> 's) list \<times> ('s, 'a) tmres) set" where
+  "mk_ef S \<equiv> if mres S = {} then S \<union> {([], Failed)} else S"
+
+
+subsection \<open>WPC setup\<close>
+
+lemma wpc_helper_empty_fail_final:
+  "empty_fail f \<Longrightarrow> wpc_helper (P, P', P'') (Q, Q', Q'') (empty_fail f)"
+  by (clarsimp simp: wpc_helper_def)
+
+wpc_setup "\<lambda>m. empty_fail m" wpc_helper_empty_fail_final
+
+
+subsection \<open>@{const empty_fail} intro/dest rules\<close>
+
+lemma empty_failI:
+  "(\<And>s. mres (m s) = {} \<Longrightarrow> Failed \<in> snd ` (m s)) \<Longrightarrow> empty_fail m"
+  by (simp add: empty_fail_def)
+
+lemma empty_failD:
+  "\<lbrakk> empty_fail m; mres (m s) = {} \<rbrakk> \<Longrightarrow> Failed \<in> snd ` (m s)"
+  by (simp add: empty_fail_def)
+
+lemma empty_fail_not_snd:
+  "\<lbrakk> Failed \<notin> snd ` (m s); empty_fail m \<rbrakk> \<Longrightarrow> \<exists>v. v \<in> mres (m s)"
+  by (fastforce simp: empty_fail_def)
+
+lemmas empty_failD2 = empty_fail_not_snd[rotated]
+
+lemma empty_failD3:
+  "\<lbrakk> empty_fail f; Failed \<notin> snd ` (f s) \<rbrakk> \<Longrightarrow> mres (f s) \<noteq> {}"
+  by (drule(1) empty_failD2, clarsimp)
+
+lemma empty_fail_bindD1:
+  "empty_fail (a >>= b) \<Longrightarrow> empty_fail a"
+  unfolding empty_fail_def bind_def
+  apply clarsimp
+  apply (drule_tac x=s in spec)
+  by (force simp: split_def mres_def vimage_def split: tmres.splits)
+
+
+subsection \<open>Wellformed monads\<close>
+
+(*
+  Collect generic empty_fail lemmas here:
+   - naming convention is empty_fail_NAME.
+   - add lemmas with assumptions to [empty_fail_cond] set
+   - add lemmas without assumption to [empty_fail_term] set
+*)
+
+named_theorems empty_fail_term
+named_theorems empty_fail_cond
+
+lemma empty_fail_K_bind[empty_fail_cond]:
+  "empty_fail f \<Longrightarrow> empty_fail (K_bind f x)"
+  by simp
+
+lemma empty_fail_fun_app[empty_fail_cond]:
+  "empty_fail (f x) \<Longrightarrow> empty_fail (f $ x)"
+  by simp
+
+(* empty_fail as such does not need context, but empty_fail_select_f does, so we need to build
+   up context in other rules *)
+lemma empty_fail_If[empty_fail_cond]:
+  "\<lbrakk> P \<Longrightarrow> empty_fail f; \<not>P \<Longrightarrow> empty_fail g \<rbrakk> \<Longrightarrow> empty_fail (if P then f else g)"
+  by (simp split: if_split)
+
+lemma empty_fail_If_applied[empty_fail_cond]:
+  "\<lbrakk> P \<Longrightarrow> empty_fail (f x); \<not>P \<Longrightarrow> empty_fail (g x) \<rbrakk> \<Longrightarrow> empty_fail ((if P then f else g) x)"
+  by simp
+
+lemma empty_fail_put[empty_fail_term]:
+  "empty_fail (put f)"
+  by (simp add: put_def empty_fail_def mres_def vimage_def)
+
+lemma empty_fail_modify[empty_fail_term]:
+  "empty_fail (modify f)"
+  by (simp add: empty_fail_def simpler_modify_def mres_def vimage_def)
+
+lemma empty_fail_gets[empty_fail_term]:
+  "empty_fail (gets f)"
+  by (simp add: empty_fail_def simpler_gets_def mres_def vimage_def)
+
+lemma empty_fail_select[empty_fail_cond]:
+  "S \<noteq> {} \<Longrightarrow> empty_fail (select S)"
+  by (simp add: empty_fail_def select_def mres_def image_def)
+
+lemma mres_bind_empty:
+  "mres ((f >>= g) s) = {}
+   \<Longrightarrow> mres (f s) = {} \<or> (\<forall>res\<in>mres (f s). mres (g (fst res) (snd res)) = {})"
+  apply clarsimp
+  apply (clarsimp simp: mres_def split_def vimage_def bind_def)
+  apply (rename_tac rv s' trace)
+  apply (drule_tac x=rv in spec, drule_tac x=s' in spec)
+  apply (clarsimp simp: image_def)
+  apply fastforce
+  done
+
+lemma bind_FailedI1:
+  "Failed \<in> snd ` f s \<Longrightarrow> Failed \<in> snd ` (f >>= g) s"
+  by (force simp: bind_def vimage_def)
+
+lemma bind_FailedI2:
+  "\<lbrakk>\<forall>res\<in>mres (f s). Failed \<in> snd ` (g (fst res) (snd res)); mres (f s) \<noteq> {}\<rbrakk>
+   \<Longrightarrow> Failed \<in> snd ` (f >>= g) s"
+  by (force simp: bind_def mres_def image_def split_def)
+
+lemma empty_fail_bind[empty_fail_cond]:
+  "\<lbrakk> empty_fail a; \<And>x. empty_fail (b x) \<rbrakk> \<Longrightarrow> empty_fail (a >>= b)"
+  unfolding empty_fail_def
+  apply clarsimp
+  apply (drule mres_bind_empty)
+  apply (erule context_disjE)
+   apply (fastforce intro: bind_FailedI1)
+  apply (fastforce intro!: bind_FailedI2)
+  done
+
+lemma empty_fail_return[empty_fail_term]:
+  "empty_fail (return x)"
+  by (simp add: empty_fail_def return_def mres_def vimage_def)
+
+lemma empty_fail_returnOk[empty_fail_term]:
+  "empty_fail (returnOk v)"
+  by (fastforce simp: returnOk_def empty_fail_term)
+
+lemma empty_fail_throwError[empty_fail_term]:
+  "empty_fail (throwError v)"
+  by (fastforce simp: throwError_def empty_fail_term)
+
+lemma empty_fail_lift[empty_fail_cond]:
+  "\<lbrakk> \<And>x. empty_fail (f x) \<rbrakk> \<Longrightarrow> empty_fail (lift f x)"
+  unfolding lift_def
+  by (auto simp: empty_fail_term split: sum.split)
+
+lemma empty_fail_liftE[empty_fail_cond]:
+  "empty_fail f \<Longrightarrow> empty_fail (liftE f)"
+  by (simp add: liftE_def empty_fail_cond empty_fail_term)
+
+lemma empty_fail_bindE[empty_fail_cond]:
+  "\<lbrakk> empty_fail f; \<And>rv. empty_fail (g rv) \<rbrakk> \<Longrightarrow> empty_fail (f >>=E g)"
+  by (simp add: bindE_def empty_fail_cond)
+
+lemma empty_fail_mapM[empty_fail_cond]:
+  assumes m: "\<And>x. x \<in> set xs \<Longrightarrow> empty_fail (m x)"
+  shows "empty_fail (mapM m xs)"
+using m
+proof (induct xs)
+  case Nil
+  thus ?case by (simp add: mapM_def sequence_def empty_fail_term)
+next
+  case Cons
+  have P: "\<And>m x xs. mapM m (x # xs) = (do y \<leftarrow> m x; ys \<leftarrow> (mapM m xs); return (y # ys) od)"
+    by (simp add: mapM_def sequence_def Let_def)
+  from Cons
+  show ?case by (simp add: P m empty_fail_cond empty_fail_term)
+qed
+
+lemma empty_fail_fail[empty_fail_term]:
+  "empty_fail fail"
+  by (simp add: fail_def empty_fail_def)
+
+lemma empty_fail_assert[empty_fail_term]:
+  "empty_fail (assert P)"
+  unfolding assert_def by (simp add: empty_fail_term)
+
+lemma empty_fail_assert_opt[empty_fail_term]:
+  "empty_fail (assert_opt x)"
+  by (simp add: assert_opt_def empty_fail_term split: option.splits)
+
+lemma empty_fail_mk_ef[empty_fail_term]:
+  "empty_fail (mk_ef o m)"
+  by (simp add: empty_fail_def mk_ef_def)
+
+lemma empty_fail_gets_the[empty_fail_term]:
+  "empty_fail (gets_the f)"
+  unfolding gets_the_def
+  by (simp add: empty_fail_cond empty_fail_term)
+
+lemma empty_fail_gets_map[empty_fail_term]:
+  "empty_fail (gets_map f p)"
+  unfolding gets_map_def
+  by (simp add: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_whenEs[empty_fail_cond]:
+  "(P \<Longrightarrow> empty_fail f) \<Longrightarrow> empty_fail (whenE P f)"
+  "(\<not>P \<Longrightarrow> empty_fail f) \<Longrightarrow> empty_fail (unlessE P f)"
+  by (auto simp add: whenE_def unlessE_def empty_fail_term)
+
+lemma empty_fail_assertE[empty_fail_term]:
+  "empty_fail (assertE P)"
+  by (simp add: assertE_def empty_fail_term)
+
+lemma empty_fail_get[empty_fail_term]:
+  "empty_fail get"
+  by (simp add: empty_fail_def get_def mres_def vimage_def)
+
+lemma empty_fail_catch[empty_fail_cond]:
+  "\<lbrakk> empty_fail f; \<And>x. empty_fail (g x) \<rbrakk> \<Longrightarrow> empty_fail (catch f g)"
+  by (simp add: catch_def empty_fail_cond empty_fail_term split: sum.split)
+
+lemma empty_fail_guard[empty_fail_term]:
+  "empty_fail (state_assert G)"
+  by (clarsimp simp: state_assert_def empty_fail_cond empty_fail_term)
+
+lemma empty_fail_spec[empty_fail_term]:
+  "empty_fail (state_select F)"
+  by (clarsimp simp: state_select_def empty_fail_def default_elem_def mres_def image_def)
+
+lemma empty_fail_when[empty_fail_cond]:
+  "(P \<Longrightarrow> empty_fail x) \<Longrightarrow> empty_fail (when P x)"
+  unfolding when_def
+  by (simp add: empty_fail_term)
+
+lemma empty_fail_unless[empty_fail_cond]:
+  "(\<not>P \<Longrightarrow> empty_fail f) \<Longrightarrow> empty_fail (unless P f)"
+  unfolding unless_def
+  by (simp add: empty_fail_cond)
+
+lemma empty_fail_liftM[empty_fail_cond]:
+  "empty_fail m \<Longrightarrow> empty_fail (liftM f m)"
+  unfolding liftM_def
+  by (fastforce simp: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_liftME[empty_fail_cond]:
+  "empty_fail m \<Longrightarrow> empty_fail (liftME f m)"
+  unfolding liftME_def
+  by (simp add: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_handleE[empty_fail_cond]:
+  "\<lbrakk> empty_fail L; \<And>r. empty_fail (R r) \<rbrakk> \<Longrightarrow> empty_fail (L <handle> R)"
+  by (clarsimp simp: handleE_def handleE'_def empty_fail_term empty_fail_cond split: sum.splits)
+
+lemma empty_fail_handle'[empty_fail_cond]:
+  "\<lbrakk>empty_fail f; \<And>e. empty_fail (handler e)\<rbrakk> \<Longrightarrow> empty_fail (f <handle2> handler)"
+  unfolding handleE'_def
+  by (fastforce simp: empty_fail_term empty_fail_cond split: sum.splits)
+
+lemma empty_fail_sequence[empty_fail_cond]:
+  "(\<And>m. m \<in> set ms \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (sequence ms)"
+  unfolding sequence_def
+  by (induct ms; simp add: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_sequence_x[empty_fail_cond]:
+  "(\<And>m. m \<in> set ms \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (sequence_x ms)"
+  unfolding sequence_x_def
+  by (induct ms; simp add: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_sequenceE[empty_fail_cond]:
+  "(\<And>m. m \<in> set ms \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (sequenceE ms)"
+  unfolding sequenceE_def
+  by (induct ms; simp add: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_sequenceE_x[empty_fail_cond]:
+  "(\<And>m. m \<in> set ms \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (sequenceE_x ms)"
+  unfolding sequenceE_x_def
+  by (induct ms; simp add: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_mapM_x[empty_fail_cond]:
+  "(\<And>m. m \<in> f ` set ms \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (mapM_x f ms)"
+  unfolding mapM_x_def
+  by (fastforce intro: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_mapME[empty_fail_cond]:
+  "(\<And>m. m \<in> f ` set xs \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (mapME f xs)"
+  unfolding mapME_def
+  by (fastforce intro: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_mapME_x[empty_fail_cond]:
+  "(\<And>m'. m' \<in> f ` set xs \<Longrightarrow> empty_fail m') \<Longrightarrow> empty_fail (mapME_x f xs)"
+  unfolding mapME_x_def
+  by (fastforce intro: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_filterM[empty_fail_cond]:
+  "(\<And>m. m \<in> set ms \<Longrightarrow> empty_fail (P m)) \<Longrightarrow> empty_fail (filterM P ms)"
+  by (induct ms; simp add: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_zipWithM_x[empty_fail_cond]:
+  "(\<And>x y. empty_fail (f x y)) \<Longrightarrow> empty_fail (zipWithM_x f xs ys)"
+  unfolding zipWithM_x_def zipWith_def
+  by (fastforce intro: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_zipWithM[empty_fail_cond]:
+  "(\<And>x y. empty_fail (f x y)) \<Longrightarrow> empty_fail (zipWithM f xs ys)"
+  unfolding zipWithM_def zipWith_def
+  by (fastforce intro: empty_fail_term empty_fail_cond)
+
+lemma empty_fail_maybeM[empty_fail_cond]:
+  "\<forall>x. empty_fail (f x) \<Longrightarrow> empty_fail (maybeM f t)"
+  unfolding maybeM_def
+  by (fastforce intro: empty_fail_term split: option.splits)
+
+lemma empty_fail_ifM[empty_fail_cond]:
+  "\<lbrakk> empty_fail P; empty_fail a; empty_fail b \<rbrakk> \<Longrightarrow> empty_fail (ifM P a b)"
+  by (simp add: ifM_def empty_fail_cond)
+
+lemma empty_fail_ifME[empty_fail_cond]:
+  "\<lbrakk> empty_fail P; empty_fail a; empty_fail b \<rbrakk> \<Longrightarrow> empty_fail (ifME P a b)"
+  by (simp add: ifME_def empty_fail_cond)
+
+lemma empty_fail_whenM[empty_fail_cond]:
+  "\<lbrakk> empty_fail P; empty_fail f \<rbrakk> \<Longrightarrow> empty_fail (whenM P f)"
+  by (simp add: whenM_def empty_fail_term empty_fail_cond)
+
+lemma empty_fail_andM[empty_fail_cond]:
+  "\<lbrakk> empty_fail A; empty_fail B \<rbrakk> \<Longrightarrow> empty_fail (andM A B)"
+  by (simp add: andM_def empty_fail_term empty_fail_cond)
+
+lemma empty_fail_orM[empty_fail_cond]:
+  "\<lbrakk> empty_fail A; empty_fail B \<rbrakk> \<Longrightarrow> empty_fail (orM A B)"
+  by (simp add: orM_def empty_fail_term empty_fail_cond)
+
+lemma empty_fail_notM[empty_fail_cond]:
+  "empty_fail A \<Longrightarrow> empty_fail (notM A)"
+  by (simp add: notM_def empty_fail_term empty_fail_cond)
+
+(* not everything [simp] by default, because side conditions can slow down simp a lot *)
+lemmas empty_fail[wp, intro!] = empty_fail_term empty_fail_cond
+lemmas [simp] = empty_fail_term
+
+
+subsection \<open>Equations and legacy names\<close>
+
+lemma empty_fail_select_eq[simp]:
+  "empty_fail (select V) = (V \<noteq> {})"
+  by (clarsimp simp: select_def empty_fail_def mres_def image_def)
+
+lemma empty_fail_liftM_eq[simp]:
+  "empty_fail (liftM f m) = empty_fail m"
+  unfolding liftM_def
+  by (fastforce dest: empty_fail_bindD1)
+
+lemma empty_fail_liftE_eq[simp]:
+  "empty_fail (liftE f) = empty_fail f"
+  by (auto simp: liftE_def empty_fail_bindD1)
+
+lemma liftME_empty_fail_eq[simp]:
+  "empty_fail (liftME f m) = empty_fail m"
+  unfolding liftME_def
+  by (fastforce dest: empty_fail_bindD1 simp: bindE_def)
+
+(* legacy name binding *)
+lemmas empty_fail_error_bits = empty_fail_returnOk empty_fail_throwError empty_fail_liftE_eq
+
+end

lib/Monads/trace/Trace_In_Monad.thy

@@ -54,6 +54,10 @@ lemma inl_whenE:
   "((Inl x, s') \<in> mres (whenE P f s)) = (P \<and> (Inl x, s') \<in> mres (f s))"
   by (auto simp add: in_whenE)
 
+lemma inr_in_unlessE_throwError[termination_simp]:
+  "(Inr (), s') \<in> mres (unlessE P (throwError E) s) = (P \<and> s'=s)"
+  by (simp add: unlessE_def returnOk_def throwError_def in_return)
+
 lemma in_fail:
   "r \<in> mres (fail s) = False"
   by (simp add: fail_def mres_def)
@@ -86,6 +90,18 @@ lemma in_when:
   "(v, s') \<in> mres (when P f s) = ((P \<longrightarrow> (v, s') \<in> mres (f s)) \<and> (\<not>P \<longrightarrow> v = () \<and> s' = s))"
   by (simp add: when_def in_return)
 
+lemma in_unless:
+  "(v, s') \<in> mres (unless P f s) = ((\<not> P \<longrightarrow> (v, s') \<in> mres (f s)) \<and> (P \<longrightarrow> v = () \<and> s' = s))"
+  by (simp add: unless_def in_when)
+
+lemma in_unlessE:
+  "(v, s') \<in> mres (unlessE P f s) = ((\<not> P \<longrightarrow> (v, s') \<in> mres (f s)) \<and> (P \<longrightarrow> v = Inr () \<and> s' = s))"
+  by (simp add: unlessE_def in_returnOk)
+
+lemma inl_unlessE:
+  "((Inl x, s') \<in> mres (unlessE P f s)) = (\<not> P \<and> (Inl x, s') \<in> mres (f s))"
+  by (auto simp add: in_unlessE)
+
 lemma in_modify:
   "(v, s') \<in> mres (modify f s) = (s'=f s \<and> v = ())"
   by (auto simp add: modify_def bind_def get_def put_def mres_def)
@@ -114,8 +130,8 @@ lemma in_bindE:
 lemmas in_monad = inl_whenE in_whenE in_liftE in_bind in_bindE_L
                   in_bindE_R in_returnOk in_throwError in_fail
                   in_assertE in_assert in_return in_assert_opt
-                  in_get in_gets in_put in_when (* unlessE_whenE *)
-                  (* unless_when *) in_modify gets_the_in_monad
+                  in_get in_gets in_put in_when inl_unlessE in_unlessE
+                  in_unless in_modify gets_the_in_monad
                   in_alternative in_liftM
 
 lemma bind_det_exec:

lib/Monads/trace/Trace_Lemmas.thy

@@ -30,17 +30,170 @@ lemma bind_apply_cong':
 
 lemmas bind_apply_cong = bind_apply_cong'[rule_format, fundef_cong]
 
+lemma bind_cong[fundef_cong]:
+  "\<lbrakk> f = f'; \<And>v s s'. (v, s') \<in> mres (f' s) \<Longrightarrow> g v s' = g' v s' \<rbrakk> \<Longrightarrow> f >>= g = f' >>= g'"
+  by (auto intro!: bind_apply_cong)
+
+lemma bindE_cong[fundef_cong]:
+  "\<lbrakk> M = M' ; \<And>v s s'. (Inr v, s') \<in> mres (M' s) \<Longrightarrow> N v s' = N' v s' \<rbrakk> \<Longrightarrow> bindE M N = bindE M' N'"
+  by (auto simp: bindE_def lift_def split: sum.splits intro!: bind_cong)
+
+lemma bindE_apply_cong[fundef_cong]:
+  "\<lbrakk> f s = f' s'; \<And>rv st. (Inr rv, st) \<in> mres (f' s') \<Longrightarrow> g rv st = g' rv st \<rbrakk>
+  \<Longrightarrow> (f >>=E g) s = (f' >>=E g') s'"
+  by (auto simp: bindE_def lift_def split: sum.splits intro!: bind_apply_cong)
+
+lemma K_bind_apply_cong[fundef_cong]:
+  "\<lbrakk> f st = f' st' \<rbrakk> \<Longrightarrow> K_bind f arg st = K_bind f' arg' st'"
+  by simp
+
+lemma when_apply_cong[fundef_cong]:
+  "\<lbrakk> C = C'; s = s'; C' \<Longrightarrow> m s' = m' s' \<rbrakk> \<Longrightarrow> when C m s = when C' m' s'"
+  by (simp add: when_def)
+
+lemma unless_apply_cong[fundef_cong]:
+  "\<lbrakk> C = C'; s = s'; \<not> C' \<Longrightarrow> m s' = m' s' \<rbrakk> \<Longrightarrow> unless C m s = unless C' m' s'"
+  by (simp add: when_def unless_def)
+
+lemma whenE_apply_cong[fundef_cong]:
+  "\<lbrakk> C = C'; s = s'; C' \<Longrightarrow> m s' = m' s' \<rbrakk> \<Longrightarrow> whenE C m s = whenE C' m' s'"
+  by (simp add: whenE_def)
+
+lemma unlessE_apply_cong[fundef_cong]:
+  "\<lbrakk> C = C'; s = s'; \<not> C' \<Longrightarrow> m s' = m' s' \<rbrakk> \<Longrightarrow> unlessE C m s = unlessE C' m' s'"
+  by (simp add: unlessE_def)
+
 
 subsection \<open>Simplifying Monads\<close>
 
+lemma nested_bind[simp]:
+  "do x <- do y <- f; return (g y) od; h x od = do y <- f; h (g y) od"
+  by (fastforce simp: bind_def return_def split: tmres.splits)
+
+lemma bind_dummy_ret_val:
+  "do y \<leftarrow> a; b od = do a; b od"
+  by simp
+
 lemma fail_update[iff]:
   "fail (f s) = fail s"
   by (simp add: fail_def)
 
+lemma fail_bind[simp]:
+  "fail >>= f = fail"
+  by (simp add: bind_def fail_def)
+
+lemma fail_bindE[simp]:
+  "fail >>=E f = fail"
+  by (simp add: bindE_def bind_def fail_def)
+
+lemma assert_A_False[simp]:
+  "assert False = fail"
+  by (simp add: assert_def)
+
 lemma assert_A_True[simp]:
   "assert True = return ()"
   by (simp add: assert_def)
 
+lemma assert_False[simp]:
+  "assert False >>= f = fail"
+  by simp
+
+lemma assert_True[simp]:
+  "assert True >>= f = f ()"
+  by simp
+
+lemma assertE_False[simp]:
+  "assertE False >>=E f = fail"
+  by (simp add: assertE_def)
+
+lemma assertE_True[simp]:
+  "assertE True >>=E f = f ()"
+  by (simp add: assertE_def)
+
+lemma when_False_bind[simp]:
+  "when False g >>= f = f ()"
+  by (rule ext) (simp add: when_def bind_def return_def)
+
+lemma when_True_bind[simp]:
+  "when True g >>= f = g >>= f"
+  by (simp add: when_def bind_def return_def)
+
+lemma whenE_False_bind[simp]:
+  "whenE False g >>=E f = f ()"
+  by (simp add: whenE_def bindE_def returnOk_def lift_def)
+
+lemma whenE_True_bind[simp]:
+  "whenE True g >>=E f = g >>=E f"
+  by (simp add: whenE_def bindE_def returnOk_def lift_def)
+
+lemma when_True[simp]:
+  "when True X = X"
+  by (clarsimp simp: when_def)
+
+lemma when_False[simp]:
+  "when False X = return ()"
+  by (clarsimp simp: when_def)
+
+lemma unless_False[simp]:
+  "unless False X = X"
+  by (clarsimp simp: unless_def)
+
+lemma unlessE_False[simp]:
+  "unlessE False f = f"
+  unfolding unlessE_def by fastforce
+
+lemma unless_True[simp]:
+  "unless True X = return ()"
+  by (clarsimp simp: unless_def)
+
+lemma unlessE_True[simp]:
+  "unlessE True f = returnOk ()"
+  unfolding unlessE_def by fastforce
+
+lemma unlessE_whenE:
+  "unlessE P = whenE (\<not>P)"
+  by (rule ext) (simp add: unlessE_def whenE_def)
+
+lemma unless_when:
+  "unless P = when (\<not>P)"
+  by (rule ext) (simp add: unless_def when_def)
+
+lemma gets_to_return[simp]:
+  "gets (\<lambda>s. v) = return v"
+  by (clarsimp simp: gets_def put_def get_def bind_def return_def)
+
+lemma assert_opt_Some:
+  "assert_opt (Some x) = return x"
+  by (simp add: assert_opt_def)
+
+lemma assertE_liftE:
+  "assertE P = liftE (assert P)"
+  by (simp add: assertE_def assert_def liftE_def returnOk_def)
+
+lemma liftE_handleE'[simp]:
+  "(liftE a <handle2> b) = liftE a"
+  by (clarsimp simp: liftE_def handleE'_def)
+
+lemma liftE_handleE[simp]:
+  "(liftE a <handle> b) = liftE a"
+  unfolding handleE_def by simp
+
+lemma alternative_bind:
+  "((a \<sqinter> b) >>= c) = ((a >>= c) \<sqinter> (b >>= c))"
+  by (fastforce simp add: alternative_def bind_def split_def)
+
+lemma alternative_refl:
+  "(a \<sqinter> a) = a"
+  by (simp add: alternative_def)
+
+lemma alternative_com:
+  "(f \<sqinter> g) = (g \<sqinter> f)"
+  by (auto simp: alternative_def)
+
+lemma liftE_alternative:
+  "liftE (a \<sqinter> b) = (liftE a \<sqinter> liftE b)"
+  by (simp add: liftE_def alternative_bind)
+
 
 subsection \<open>Lifting and Alternative Basic Definitions\<close>
 
@@ -65,7 +218,7 @@ lemma liftM_id[simp]:
   by (auto simp: liftM_def)
 
 lemma liftM_bind:
-  "liftM t f >>= g = (f >>= (\<lambda>x. g (t x)))"
+  "liftM t f >>= g = f >>= (\<lambda>x. g (t x))"
   by (simp add: liftM_def bind_assoc)
 
 lemma gets_bind_ign:
@@ -86,4 +239,33 @@ lemma bind_eqI:
   "\<lbrakk> f = f'; \<And>x. g x = g' x \<rbrakk> \<Longrightarrow> f >>= g = f' >>= g'"
   by (auto simp: bind_def split_def)
 
+lemma condition_split:
+  "P (condition C a b s) \<longleftrightarrow> (C s \<longrightarrow> P (a s)) \<and> (\<not>C s \<longrightarrow> P (b s))"
+  by (clarsimp simp: condition_def)
+
+lemma condition_split_asm:
+  "P (condition C a b s) \<longleftrightarrow> (\<not>(C s \<and> \<not> P (a s) \<or> \<not>C s \<and> \<not>P (b s)))"
+  by (clarsimp simp: condition_def)
+
+lemmas condition_splits = condition_split condition_split_asm
+
+lemma condition_true_triv[simp]:
+  "condition (\<lambda>_. True) A B = A"
+  by (fastforce split: condition_splits)
+
+lemma condition_false_triv[simp]:
+  "condition (\<lambda>_. False) A B = B"
+  by (fastforce split: condition_splits)
+
+lemma condition_true:
+  "P s \<Longrightarrow> condition P A B s = A s"
+  by (clarsimp simp: condition_def)
+
+lemma condition_false:
+  "\<not> P s \<Longrightarrow> condition P A B s = B s"
+  by (clarsimp simp: condition_def)
+
+lemmas arg_cong_bind = arg_cong2[where f=bind]
+lemmas arg_cong_bind1 = arg_cong_bind[OF refl ext]
+
 end

lib/Monads/trace/Trace_Monad.thy

@@ -38,14 +38,32 @@ datatype ('s, 'a) tmres = Failed | Incomplete | Result "('a \<times> 's)"
 abbreviation map_tmres_rv :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s, 'a) tmres \<Rightarrow> ('s, 'b) tmres" where
   "map_tmres_rv f \<equiv> map_tmres id f"
 
-section "The Monad"
-
 text \<open>
   tmonad returns a set of non-deterministic computations, including
   a trace as a list of "thread identifier" \<times> state, and an optional
   pair of result and state when the computation did not fail.\<close>
 type_synonym ('s, 'a) tmonad = "'s \<Rightarrow> ((tmid \<times> 's) list \<times> ('s, 'a) tmres) set"
 
+
+text \<open>
+  Print the type @{typ "('s,'a) tmonad"} instead of its unwieldy expansion.
+  Needs an AST translation in code, because it needs to check that the state variable
+  @{typ 's} occurs three times. This comparison is not guaranteed to always work as expected
+  (AST instances might have different decoration), but it does seem to work here.\<close>
+print_ast_translation \<open>
+  let
+    fun tmonad_tr _ [t1, Ast.Appl [Ast.Constant @{type_syntax set},
+                          Ast.Appl [Ast.Constant @{type_syntax prod},
+                            Ast.Appl [Ast.Constant @{type_syntax list},
+                              Ast.Appl [Ast.Constant @{type_syntax prod},
+                                Ast.Constant @{type_syntax tmid}, t2]],
+                            Ast.Appl [Ast.Constant @{type_syntax tmres}, t3, t4]]]] =
+      if t1 = t2 andalso t1 = t3
+      then Ast.Appl [Ast.Constant @{type_syntax "tmonad"}, t1, t4]
+      else raise Match
+  in [(@{type_syntax "fun"}, tmonad_tr)] end\<close>
+
+
 text \<open>Returns monad results, ignoring failures and traces.\<close>
 definition mres :: "((tmid \<times> 's) list \<times> ('s, 'a) tmres) set \<Rightarrow> ('a \<times> 's) set" where
   "mres r = Result -` (snd ` r)"
@@ -80,7 +98,7 @@ definition bind ::
     | Result (rv, s) \<Rightarrow> fst_upd (\<lambda>ys. ys @ xs) ` g rv s"
 
 text \<open>Sometimes it is convenient to write @{text bind} in reverse order.\<close>
-abbreviation(input) bind_rev ::
+abbreviation (input) bind_rev ::
   "('c \<Rightarrow> ('a, 'b) tmonad) \<Rightarrow> ('a, 'c) tmonad \<Rightarrow> ('a, 'b) tmonad" (infixl "=<<" 60)
   where
   "g =<< f \<equiv> f >>= g"
@@ -105,6 +123,7 @@ primrec put_trace :: "(tmid \<times> 's) list \<Rightarrow> ('s, unit) tmonad" w
     "put_trace [] = return ()"
   | "put_trace (x # xs) = (put_trace xs >>= (\<lambda>_. put_trace_elem x))"
 
+
 subsection "Nondeterminism"
 
 text \<open>
@@ -116,14 +135,27 @@ text \<open>
 definition select :: "'a set \<Rightarrow> ('s, 'a) tmonad" where
   "select A \<equiv> \<lambda>s. (Pair [] ` Result ` (A \<times> {s}))"
 
-definition alternative :: "('s,'a) tmonad \<Rightarrow> ('s,'a) tmonad \<Rightarrow> ('s,'a) tmonad"
-  (infixl "\<sqinter>" 20) where
+definition alternative ::
+  "('s,'a) tmonad \<Rightarrow> ('s,'a) tmonad \<Rightarrow> ('s,'a) tmonad" (infixl "\<sqinter>" 20)
+  where
   "f \<sqinter> g \<equiv> \<lambda>s. (f s \<union> g s)"
 
 text \<open>
   FIXME: The @{text select_f} function was left out here until we figure
   out what variant we actually need.\<close>
 
+definition
+  "default_elem dflt A \<equiv> if A = {} then {dflt} else A"
+
+text \<open>
+  @{text state_select} takes a relationship between states, and outputs
+  nondeterministically a state related to the input state. Fails if no such
+  state exists.\<close>
+definition state_select :: "('s \<times> 's) set \<Rightarrow> ('s, unit) tmonad" where
+  "state_select r \<equiv>
+     \<lambda>s. (Pair [] ` default_elem Failed (Result ` (\<lambda>x. ((), x)) ` {s'. (s, s') \<in> r}))"
+
+
 subsection "Failure"
 
 text \<open>
@@ -173,7 +205,8 @@ text \<open>
   Perform a test on the current state, performing the left monad if
   the result is true or the right monad if the result is false.\<close>
 definition condition ::
-  "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'r) tmonad \<Rightarrow> ('s, 'r) tmonad \<Rightarrow> ('s, 'r) tmonad" where
+  "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'r) tmonad \<Rightarrow> ('s, 'r) tmonad \<Rightarrow> ('s, 'r) tmonad"
+  where
   "condition P L R \<equiv> \<lambda>s. if (P s) then (L s) else (R s)"
 
 notation (output)
@@ -185,11 +218,17 @@ text \<open>
 definition gets_the :: "('s \<Rightarrow> 'a option) \<Rightarrow> ('s, 'a) tmonad" where
   "gets_the f \<equiv> gets f >>= assert_opt"
 
+text \<open>
+  Get a map (such as a heap) from the current state and apply an argument to the map.
+  Fail if the map returns @{const None}, otherwise return the value.\<close>
+definition gets_map :: "('s \<Rightarrow> 'a \<Rightarrow> 'b option) \<Rightarrow> 'a \<Rightarrow> ('s, 'b) tmonad" where
+  "gets_map f p \<equiv> gets f >>= (\<lambda>m. assert_opt (m p))"
+
 
 subsection \<open>The Monad Laws\<close>
 
-text \<open>An alternative definition of bind, sometimes more convenient.\<close>
-lemma bind_def2:
+text \<open>An alternative definition of @{term bind}, sometimes more convenient.\<close>
+lemma bind_def':
   "bind f g \<equiv>
      \<lambda>s. ((\<lambda>xs. (xs, Failed)) ` {xs. (xs, Failed) \<in> f s})
          \<union> ((\<lambda>xs. (xs, Incomplete)) ` {xs. (xs, Incomplete) \<in> f s})
@@ -206,7 +245,7 @@ lemma elem_bindE:
     \<lbrakk>res = Incomplete \<or> res = Failed; (tr, map_tmres undefined undefined res) \<in> f s\<rbrakk> \<Longrightarrow> P;
     \<And>tr' tr'' x s'. \<lbrakk>(tr', Result (x, s')) \<in> f s; (tr'', res) \<in> g x s'; tr = tr'' @ tr'\<rbrakk> \<Longrightarrow> P\<rbrakk>
    \<Longrightarrow> P"
-  by (auto simp: bind_def2)
+  by (auto simp: bind_def')
 
 text \<open>Each monad satisfies at least the following three laws.\<close>
 
@@ -241,6 +280,7 @@ lemma bind_assoc:
   apply (simp add: image_image)
   done
 
+
 section \<open>Adding Exceptions\<close>
 
 text \<open>
@@ -276,8 +316,8 @@ text \<open>
   the right-hand side is skipped if the left-hand side
   produced an exception.\<close>
 definition bindE ::
-  "('s, 'e + 'a) tmonad \<Rightarrow> ('a \<Rightarrow> ('s, 'e + 'b) tmonad) \<Rightarrow> ('s, 'e + 'b) tmonad"
-  (infixl ">>=E" 60) where
+  "('s, 'e + 'a) tmonad \<Rightarrow> ('a \<Rightarrow> ('s, 'e + 'b) tmonad) \<Rightarrow> ('s, 'e + 'b) tmonad" (infixl ">>=E" 60)
+  where
   "f >>=E g \<equiv> f >>= lift g"
 
 text \<open>
@@ -309,6 +349,7 @@ text \<open>
 definition assertE :: "bool \<Rightarrow> ('a, 'e + unit) tmonad" where
   "assertE P \<equiv> if P then returnOk () else fail"
 
+
 subsection "Monad Laws for the Exception Monad"
 
 text \<open>More direct definition of @{const liftE}:\<close>
@@ -490,6 +531,10 @@ text \<open>The same for the exception monad:\<close>
 definition liftME :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'e+'a) tmonad \<Rightarrow> ('s,'e+'b) tmonad" where
   "liftME f m \<equiv> doE x \<leftarrow> m; returnOk (f x) odE"
 
+text \<open>Execute @{term f} for @{term "Some x"}, otherwise do nothing.\<close>
+definition maybeM :: "('a \<Rightarrow> ('s, unit) tmonad) \<Rightarrow> 'a option \<Rightarrow> ('s, unit) tmonad" where
+  "maybeM f y \<equiv> case y of Some x \<Rightarrow> f x | None \<Rightarrow> return ()"
+
 text \<open>Run a sequence of monads from left to right, ignoring return values.\<close>
 definition sequence_x :: "('s, 'a) tmonad list \<Rightarrow> ('s, unit) tmonad" where
   "sequence_x xs \<equiv> foldr (\<lambda>x y. x >>= (\<lambda>_. y)) xs (return ())"
@@ -505,7 +550,8 @@ text \<open>
   going through both lists simultaneously, left to right, ignoring
   return values.\<close>
 definition zipWithM_x ::
-  "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) tmonad) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, unit) tmonad" where
+  "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) tmonad) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, unit) tmonad"
+  where
   "zipWithM_x f xs ys \<equiv> sequence_x (zipWith f xs ys)"
 
 text \<open>
@@ -519,14 +565,16 @@ definition mapM :: "('a \<Rightarrow> ('s,'b) tmonad) \<Rightarrow> 'a list \<Ri
   "mapM f xs \<equiv> sequence (map f xs)"
 
 definition zipWithM ::
-  "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) tmonad) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, 'c list) tmonad" where
+  "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) tmonad) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, 'c list) tmonad"
+  where
   "zipWithM f xs ys \<equiv> sequence (zipWith f xs ys)"
 
 definition foldM :: "('b \<Rightarrow> 'a \<Rightarrow> ('s, 'a) tmonad) \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> ('s, 'a) tmonad" where
   "foldM m xs a \<equiv> foldr (\<lambda>p q. q >>= m p) xs (return a) "
 
 definition foldME ::
-  "('b \<Rightarrow> 'a \<Rightarrow> ('s,('e + 'b)) tmonad) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> ('s, ('e + 'b)) tmonad" where
+  "('b \<Rightarrow> 'a \<Rightarrow> ('s,('e + 'b)) tmonad) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> ('s, ('e + 'b)) tmonad"
+  where
   "foldME m a xs \<equiv> foldr (\<lambda>p q. q >>=E swp m p) xs (returnOk a)"
 
 text \<open>
@@ -545,7 +593,6 @@ definition sequenceE :: "('s, 'e+'a) tmonad list \<Rightarrow> ('s, 'e+'a list)
 definition mapME :: "('a \<Rightarrow> ('s,'e+'b) tmonad) \<Rightarrow> 'a list \<Rightarrow> ('s,'e+'b list) tmonad" where
   "mapME f xs \<equiv> sequenceE (map f xs)"
 
-
 text \<open>Filtering a list using a monadic function as predicate:\<close>
 primrec filterM :: "('a \<Rightarrow> ('s, bool) tmonad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'a list) tmonad" where
   "filterM P []       = return []"
@@ -555,10 +602,8 @@ primrec filterM :: "('a \<Rightarrow> ('s, bool) tmonad) \<Rightarrow> 'a list \
      return (if b then (x # ys) else ys)
    od"
 
-text \<open>
-  @{text select_state} takes a relationship between states, and outputs
-  nondeterministically a state related to the input state.\<close>
-definition state_select :: "('s \<times> 's) set \<Rightarrow> ('s, unit) tmonad" where
+text \<open>An alternative definition of @{term state_select}\<close>
+lemma state_select_def2:
   "state_select r \<equiv> (do
     s \<leftarrow> get;
     S \<leftarrow> return {s'. (s, s') \<in> r};
@@ -566,6 +611,11 @@ definition state_select :: "('s \<times> 's) set \<Rightarrow> ('s, unit) tmonad
     s' \<leftarrow> select S;
     put s'
   od)"
+  apply (clarsimp simp add: state_select_def get_def return_def assert_def fail_def select_def
+                            put_def bind_def fun_eq_iff default_elem_def
+                    intro!: eq_reflection)
+  apply fastforce
+  done
 
 
 section "Catching and Handling Exceptions"
@@ -574,7 +624,8 @@ text \<open>
   Turning an exception monad into a normal state monad
   by catching and handling any potential exceptions:\<close>
 definition catch ::
-  "('s, 'e + 'a) tmonad \<Rightarrow> ('e \<Rightarrow> ('s, 'a) tmonad) \<Rightarrow> ('s, 'a) tmonad" (infix "<catch>" 10) where
+  "('s, 'e + 'a) tmonad \<Rightarrow> ('e \<Rightarrow> ('s, 'a) tmonad) \<Rightarrow> ('s, 'a) tmonad" (infix "<catch>" 10)
+  where
   "f <catch> handler \<equiv>
      do x \<leftarrow> f;
         case x of
@@ -602,8 +653,8 @@ text \<open>
   practice: the exception handle (potentially) throws exception
   of the same type as the left-hand side.\<close>
 definition handleE ::
-  "('s, 'x + 'a) tmonad \<Rightarrow> ('x \<Rightarrow> ('s, 'x + 'a) tmonad) \<Rightarrow> ('s, 'x + 'a) tmonad"
-  (infix "<handle>" 10) where
+  "('s, 'x + 'a) tmonad \<Rightarrow> ('x \<Rightarrow> ('s, 'x + 'a) tmonad) \<Rightarrow> ('s, 'x + 'a) tmonad" (infix "<handle>" 10)
+  where
   "handleE \<equiv> handleE'"
 
 text \<open>
@@ -611,8 +662,8 @@ text \<open>
   if the left-hand side throws no exception:\<close>
 definition handle_elseE ::
   "('s, 'e + 'a) tmonad \<Rightarrow> ('e \<Rightarrow> ('s, 'ee + 'b) tmonad) \<Rightarrow> ('a \<Rightarrow> ('s, 'ee + 'b) tmonad) \<Rightarrow>
-   ('s, 'ee + 'b) tmonad"
-  ("_ <handle> _ <else> _" 10) where
+   ('s, 'ee + 'b) tmonad" ("_ <handle> _ <else> _" 10)
+  where
   "f <handle> handler <else> continue \<equiv>
    do v \<leftarrow> f;
    case v of Inl e  \<Rightarrow> handler e
@@ -655,7 +706,8 @@ inductive_cases whileLoop_terminates_cases: "whileLoop_terminates C B r s"
 inductive_simps whileLoop_terminates_simps: "whileLoop_terminates C B r s"
 
 definition whileLoop ::
-  "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) tmonad) \<Rightarrow> 'r \<Rightarrow> ('s, 'r) tmonad" where
+  "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) tmonad) \<Rightarrow> 'r \<Rightarrow> ('s, 'r) tmonad"
+  where
   "whileLoop C B \<equiv> (\<lambda>r s. {(ts, res). ((r,s), ts,res) \<in> whileLoop_results C B})"
 
 notation (output)
@@ -663,7 +715,8 @@ notation (output)
 
 \<comment> \<open>FIXME: why does this differ to Nondet_Monad?\<close>
 definition whileLoopT ::
-  "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) tmonad) \<Rightarrow> 'r \<Rightarrow> ('s, 'r) tmonad" where
+  "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) tmonad) \<Rightarrow> 'r \<Rightarrow> ('s, 'r) tmonad"
+  where
   "whileLoopT C B \<equiv> (\<lambda>r s. {(ts, res). ((r,s), ts,res) \<in> whileLoop_results C B
                                          \<and> whileLoop_terminates C B r s})"
 
@@ -671,14 +724,52 @@ notation (output)
   whileLoopT  ("(whileLoopT (_)//  (_))" [1000, 1000] 1000)
 
 definition whileLoopE ::
-  "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'e + 'r) tmonad) \<Rightarrow> 'r \<Rightarrow> ('s, ('e + 'r)) tmonad" where
+  "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'e + 'r) tmonad) \<Rightarrow> 'r \<Rightarrow> ('s, ('e + 'r)) tmonad"
+  where
   "whileLoopE C body \<equiv>
       \<lambda>r. whileLoop (\<lambda>r s. (case r of Inr v \<Rightarrow> C v s | _ \<Rightarrow> False)) (lift body) (Inr r)"
 
 notation (output)
   whileLoopE  ("(whileLoopE (_)//  (_))" [1000, 1000] 1000)
 
-subsection "Await command"
+
+section "Combinators that have conditions with side effects"
+
+definition notM :: "('s, bool) tmonad \<Rightarrow> ('s, bool) tmonad" where
+  "notM m = do c \<leftarrow> m; return (\<not> c) od"
+
+definition whileM :: "('s, bool) tmonad \<Rightarrow> ('s, 'a) tmonad \<Rightarrow> ('s, unit) tmonad" where
+  "whileM C B \<equiv> do
+    c \<leftarrow> C;
+    whileLoop (\<lambda>c s. c) (\<lambda>_. do B; C od) c;
+    return ()
+  od"
+
+definition ifM :: "('s, bool) tmonad \<Rightarrow> ('s, 'a) tmonad \<Rightarrow> ('s, 'a) tmonad \<Rightarrow> ('s, 'a) tmonad" where
+  "ifM test t f = do
+    c \<leftarrow> test;
+    if c then t else f
+   od"
+
+definition ifME ::
+  "('a, 'b + bool) tmonad \<Rightarrow> ('a, 'b + 'c) tmonad \<Rightarrow> ('a, 'b + 'c) tmonad \<Rightarrow> ('a, 'b + 'c) tmonad"
+  where
+  "ifME test t f = doE
+    c \<leftarrow> test;
+    if c then t else f
+   odE"
+
+definition whenM :: "('s, bool) tmonad \<Rightarrow> ('s, unit) tmonad \<Rightarrow> ('s, unit) tmonad" where
+  "whenM t m = ifM t m (return ())"
+
+definition orM :: "('s, bool) tmonad \<Rightarrow> ('s, bool) tmonad \<Rightarrow> ('s, bool) tmonad" where
+  "orM a b = ifM a (return True) b"
+
+definition andM :: "('s, bool) tmonad \<Rightarrow> ('s, bool) tmonad \<Rightarrow> ('s, bool) tmonad" where
+  "andM a b = ifM a b (return False)"
+
+
+section "Await command"
 
 text \<open>@{term "Await c f"} blocks the execution until @{term "c"} is true,
       and then atomically executes @{term "f"}.\<close>
@@ -696,7 +787,7 @@ definition Await :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,unit) tmonad" whe
   od"
 
 
-section "Trace monad Parallel"
+section "Parallel combinator"
 
 definition parallel :: "('s,'a) tmonad \<Rightarrow> ('s,'a) tmonad \<Rightarrow> ('s,'a) tmonad" where
   "parallel f g = (\<lambda>s. {(xs, rv). \<exists>f_steps. length f_steps = length xs

lib/Monads/trace/Trace_Monad_Equations.thy

@@ -10,41 +10,371 @@
 
 theory Trace_Monad_Equations
   imports
-    Trace_Lemmas
+    Trace_No_Fail
 begin
 
+lemmas assertE_assert = assertE_liftE
+
+lemma assert_def2:
+  "assert v = assert_opt (if v then Some () else None)"
+  by (cases v; simp add: assert_def assert_opt_def)
+
+lemma return_returnOk:
+  "return (Inr x) = returnOk x"
+  unfolding returnOk_def by simp
+
+lemma exec_modify:
+  "(modify f >>= g) s = g () (f s)"
+  by (simp add: bind_def simpler_modify_def)
+
+lemma bind_return_eq:
+  "(a >>= return) = (b >>= return) \<Longrightarrow> a = b"
+  by clarsimp
+
 lemmas bind_then_eq = arg_cong2[where f=bind, OF _ refl]
 
-lemma modify_id:
-  "modify id = return ()"
-  by (simp add: modify_def get_def bind_def put_def return_def)
+lemma bindE_bind_linearise:
+  "((f >>=E g) >>= h) =
+   (f >>= case_sum (h o Inl) (\<lambda>rv. g rv >>= h))"
+  apply (simp add: bindE_def bind_assoc)
+  apply (rule ext, rule bind_apply_cong, rule refl)
+  apply (simp add: lift_def throwError_def split: sum.split)
+  done
+
+lemma throwError_bind:
+  "(throwError e >>= f) = (f (Inl e))"
+  by (simp add: throwError_def)
+
+lemma bind_bindE_assoc:
+  "((f >>= g) >>=E h)
+   = f >>= (\<lambda>rv. g rv >>=E h)"
+  by (simp add: bindE_def bind_assoc)
+
+lemma returnOk_bind:
+  "returnOk v >>= f = (f (Inr v))"
+  by (simp add: returnOk_def)
+
+lemma liftE_bind:
+  "(liftE m >>= m') = (m >>= (\<lambda>rv. m' (Inr rv)))"
+  by (simp add: liftE_def)
+
+lemma catch_throwError: "catch (throwError ft) g = g ft"
+  by (simp add: catch_def throwError_bind)
+
+lemma cart_singleton_image:
+  "S \<times> {s} = (\<lambda>v. (v, s)) ` S"
+  by auto
+
+lemma liftE_bindE_handle:
+  "((liftE f >>=E (\<lambda>x. g x)) <handle> h)
+   = f >>= (\<lambda>x. g x <handle> h)"
+  by (simp add: liftE_bindE handleE_def handleE'_def
+                bind_assoc)
+
+lemma catch_liftE:
+  "catch (liftE g) h = g"
+  by (simp add: catch_def liftE_def)
+
+lemma catch_liftE_bindE:
+  "catch (liftE g >>=E (\<lambda>x. f x)) h = g >>= (\<lambda>x. catch (f x) h)"
+  by (simp add: liftE_bindE catch_def bind_assoc)
+
+lemma returnOk_catch_bind:
+  "catch (returnOk v) h >>= g = g v"
+  by (simp add: returnOk_liftE catch_liftE)
+
+lemma liftE_bindE_assoc:
+  "(liftE f >>=E g) >>= h = f >>= (\<lambda>x. g x >>= h)"
+  by (simp add: liftE_bindE bind_assoc)
+
+lemma unlessE_throw_catch_If:
+  "catch (unlessE P (throwError e) >>=E f) g
+   = (if P then catch (f ()) g else g e)"
+  by (simp add: unlessE_def catch_throwError split: if_split)
+
+lemma whenE_bindE_throwError_to_if:
+  "whenE P (throwError e) >>=E (\<lambda>_. b) = (if P then (throwError e) else b)"
+  unfolding whenE_def bindE_def
+  by (auto simp: lift_def throwError_def returnOk_def)
+
+lemma alternative_liftE_returnOk:
+  "(liftE m \<sqinter> returnOk v) = liftE (m \<sqinter> return v)"
+  by (simp add: liftE_def alternative_def returnOk_def bind_def return_def)
+
+lemma gets_the_return:
+  "(return x = gets_the f) = (\<forall>s. f s = Some x)"
+  apply (subst fun_eq_iff)
+  apply (simp add: return_def gets_the_def exec_gets
+                   assert_opt_def fail_def
+            split: option.split)
+  apply auto
+  done
+
+lemma gets_the_returns:
+  "(return x = gets_the f) = (\<forall>s. f s = Some x)"
+  "(returnOk x = gets_the g) = (\<forall>s. g s = Some (Inr x))"
+  "(throwError x = gets_the h) = (\<forall>s. h s = Some (Inl x))"
+  by (simp_all add: returnOk_def throwError_def
+                    gets_the_return)
+
+lemma all_rv_choice_fn_eq_pred:
+  "\<lbrakk> \<And>rv. P rv \<Longrightarrow> \<exists>fn. f rv = g fn \<rbrakk> \<Longrightarrow> \<exists>fn. \<forall>rv. P rv \<longrightarrow> f rv = g (fn rv)"
+  apply (rule_tac x="\<lambda>rv. SOME h. f rv = g h" in exI)
+  apply (clarsimp split: if_split)
+  by (meson someI_ex)
+
+lemma all_rv_choice_fn_eq:
+  "\<lbrakk> \<And>rv. \<exists>fn. f rv = g fn \<rbrakk>
+   \<Longrightarrow> \<exists>fn. f = (\<lambda>rv. g (fn rv))"
+  using all_rv_choice_fn_eq_pred[where f=f and g=g and P=\<top>]
+  by (simp add: fun_eq_iff)
+
+lemma gets_the_eq_bind:
+  "\<lbrakk> \<exists>fn. f = gets_the (fn o fn'); \<And>rv. \<exists>fn. g rv = gets_the (fn o fn') \<rbrakk>
+   \<Longrightarrow> \<exists>fn. (f >>= g) = gets_the (fn o fn')"
+  apply (clarsimp dest!: all_rv_choice_fn_eq)
+  apply (rule_tac x="\<lambda>s. case (fn s) of None \<Rightarrow> None | Some v \<Rightarrow> fna v s" in exI)
+  apply (simp add: gets_the_def bind_assoc exec_gets
+                   assert_opt_def fun_eq_iff
+            split: option.split)
+  done
+
+lemma gets_the_eq_bindE:
+  "\<lbrakk> \<exists>fn. f = gets_the (fn o fn'); \<And>rv. \<exists>fn. g rv = gets_the (fn o fn') \<rbrakk>
+   \<Longrightarrow> \<exists>fn. (f >>=E g) = gets_the (fn o fn')"
+  apply (simp add: bindE_def)
+  apply (erule gets_the_eq_bind)
+  apply (simp add: lift_def gets_the_returns split: sum.split)
+  apply fastforce
+  done
+
+lemma gets_the_fail:
+  "(fail = gets_the f) = (\<forall>s. f s = None)"
+  by (simp add: gets_the_def exec_gets assert_opt_def
+                fail_def return_def fun_eq_iff
+         split: option.split)
+
+lemma gets_the_asserts:
+  "(fail = gets_the f) = (\<forall>s. f s = None)"
+  "(assert P = gets_the g) = (\<forall>s. g s = (if P then Some () else None))"
+  "(assertE P = gets_the h) = (\<forall>s. h s = (if P then Some (Inr ()) else None))"
+  by (simp add: assert_def assertE_def gets_the_fail gets_the_returns
+         split: if_split)+
+
+lemma ex_const_function:
+  "\<exists>f. \<forall>s. f (f' s) = v"
+  by force
+
+lemma gets_the_condsE:
+  "(\<exists>fn. whenE P f = gets_the (fn o fn'))
+   = (P \<longrightarrow> (\<exists>fn. f = gets_the (fn o fn')))"
+  "(\<exists>fn. unlessE P g = gets_the (fn o fn'))
+   = (\<not> P \<longrightarrow> (\<exists>fn. g = gets_the (fn o fn')))"
+  by (simp add: whenE_def unlessE_def gets_the_returns ex_const_function
+         split: if_split)+
+
+lemma let_into_return:
+  "(let f = x in m f) = (do f \<leftarrow> return x; m f od)"
+  by simp
+
+lemma liftME_return:
+  "liftME f (returnOk v) = returnOk (f v)"
+  by (simp add: liftME_def)
+
+lemma fold_bindE_into_list_case:
+  "(doE v \<leftarrow> f; case_list (g v) (h v) x odE)
+   = (case_list (doE v \<leftarrow> f; g v odE) (\<lambda>x xs. doE v \<leftarrow> f; h v x xs odE) x)"
+  by (simp split: list.split)
+
+lemma whenE_liftE:
+  "whenE P (liftE f) = liftE (when P f)"
+  by (simp add: whenE_def when_def returnOk_liftE)
+
+lemma whenE_whenE_body:
+  "whenE P (throwError f) >>=E (\<lambda>_. whenE Q (throwError f) >>=E r) = whenE (P \<or> Q) (throwError f) >>=E r"
+  apply (cases P)
+   apply (simp add: whenE_def)
+  apply simp
+  done
+
+lemma whenE_whenE_same:
+  "whenE P (throwError f) >>=E (\<lambda>_. whenE P (throwError g) >>=E r) = whenE P (throwError f) >>=E r"
+  apply (cases P)
+   apply (simp add: whenE_def)
+  apply simp
+  done
+
+lemma maybe_fail_bind_fail:
+  "unless P fail >>= (\<lambda>_. fail) = fail"
+  "when P fail >>= (\<lambda>_. fail) = fail"
+  by (clarsimp simp: bind_def fail_def return_def
+                     unless_def when_def)+
+
+lemma select_singleton[simp]:
+  "select {x} = return x"
+  by (simp add: select_def return_def)
+
+lemma return_modify:
+  "return () = modify id"
+  by (simp add: return_def simpler_modify_def)
+
+lemma liftE_liftM_liftME:
+  "liftE (liftM f m) = liftME f (liftE m)"
+  by (simp add: liftE_liftM liftME_liftM liftM_def)
+
+lemma bind_return_unit:
+  "f = (f >>= (\<lambda>x. return ()))"
+  by simp
+
+lemma modify_id_return:
+ "modify id = return ()"
+  by (simp add: simpler_modify_def return_def)
+
+lemma liftE_bind_return_bindE_returnOk:
+  "liftE (v >>= (\<lambda>rv. return (f rv)))
+   = (liftE v >>=E (\<lambda>rv. returnOk (f rv)))"
+  by (simp add: liftE_bindE, simp add: liftE_def returnOk_def)
+
+lemma bind_eqI:
+  "g = g' \<Longrightarrow> f >>= g = f >>= g'" by simp
+
+lemma unlessE_throwError_returnOk:
+  "(if P then returnOk v else throwError x)
+   = (unlessE P (throwError x) >>=E (\<lambda>_. returnOk v))"
+  by (cases P, simp_all add: unlessE_def)
+
+lemma gets_the_bind_eq:
+  "\<lbrakk> f s = Some x; g x s = h s \<rbrakk>
+   \<Longrightarrow> (gets_the f >>= g) s = h s"
+  by (simp add: gets_the_def bind_assoc exec_gets assert_opt_def)
+
+lemma zipWithM_x_modify:
+  "zipWithM_x (\<lambda>a b. modify (f a b)) as bs
+   = modify (\<lambda>s. foldl (\<lambda>s (a, b). f a b s) s (zip as bs))"
+  apply (simp add: zipWithM_x_def zipWith_def sequence_x_def)
+  apply (induct ("zip as bs"))
+   apply (simp add: simpler_modify_def return_def)
+  apply (rule ext)
+  apply (simp add: simpler_modify_def bind_def split_def)
+  done
+
+lemma assert2:
+  "(do v1 \<leftarrow> assert P; v2 \<leftarrow> assert Q; c od)
+   = (do v \<leftarrow> assert (P \<and> Q); c od)"
+  by (simp add: assert_def split: if_split)
+
+lemma assert_opt_def2:
+  "assert_opt v = (do assert (v \<noteq> None); return (the v) od)"
+  by (simp add: assert_opt_def split: option.split)
+
+lemma gets_assert:
+  "(do v1 \<leftarrow> assert v; v2 \<leftarrow> gets f; c v1 v2 od)
+   = (do v2 \<leftarrow> gets f; v1 \<leftarrow> assert v; c v1 v2 od)"
+  by (simp add: simpler_gets_def return_def assert_def fail_def bind_def
+         split: if_split)
+
+lemma modify_assert:
+  "(do v2 \<leftarrow> modify f; v1 \<leftarrow> assert v; c v1 od)
+   = (do v1 \<leftarrow> assert v; v2 \<leftarrow> modify f; c v1 od)"
+  by (simp add: simpler_modify_def return_def assert_def fail_def bind_def
+         split: if_split)
+
+lemma gets_fold_into_modify:
+  "do x \<leftarrow> gets f; modify (g x) od = modify (\<lambda>s. g (f s) s)"
+  "do x \<leftarrow> gets f; _ \<leftarrow> modify (g x); h od
+   = do modify (\<lambda>s. g (f s) s); h od"
+  by (simp_all add: fun_eq_iff modify_def bind_assoc exec_gets
+                    exec_get exec_put)
+
+lemma gets_return_gets_eq:
+  "gets f >>= (\<lambda>g. return (h g)) = gets (\<lambda>s. h (f s))"
+  by (simp add: simpler_gets_def bind_def return_def)
+
+lemma gets_prod_comp:
+  "gets (case x of (a, b) \<Rightarrow> f a b) = (case x of (a, b) \<Rightarrow> gets (f a b))"
+  by (auto simp: split_def)
+
+lemma bind_assoc2:
+  "(do x \<leftarrow> a; _ \<leftarrow> b; c x od) = (do x \<leftarrow> (do x' \<leftarrow> a; _ \<leftarrow> b; return x' od); c x od)"
+  by (simp add: bind_assoc)
+
+lemma bind_assoc_return_reverse:
+  "do x \<leftarrow> f;
+      _ \<leftarrow> g x;
+      h x
+   od =
+   do x \<leftarrow> do x \<leftarrow> f;
+              _ \<leftarrow> g x;
+              return x
+           od;
+      h x
+   od"
+  by (simp only: bind_assoc return_bind)
+
+lemma if_bind:
+  "(if P then (a >>= (\<lambda>_. b)) else return ()) =
+   (if P then a else return ()) >>= (\<lambda>_. if P then b else return ())"
+  by (cases P; simp)
+
+lemma bind_liftE_distrib: "(liftE (A >>= (\<lambda>x. B x))) = (liftE A >>=E (\<lambda>x. liftE (\<lambda>s. B x s)))"
+  by (clarsimp simp: liftE_def bindE_def lift_def bind_assoc)
+
+lemma if_catch_distrib:
+  "((if P then f else g) <catch> h) = (if P then f <catch> h else g <catch> h)"
+  by (simp split: if_split)
+
+lemma will_throw_and_catch:
+  "f = throwError e \<Longrightarrow> (f <catch> (\<lambda>_. g)) = g"
+  by (simp add: catch_def throwError_def)
+
+lemma catch_is_if:
+  "(doE x <- f; g x odE <catch> h) =
+   do
+     rv <- f;
+     if sum.isl rv then h (projl rv) else g (projr rv) <catch> h
+   od"
+  apply (simp add: bindE_def catch_def bind_assoc cong: if_cong)
+  apply (rule bind_cong, rule refl)
+  apply (clarsimp simp: lift_def throwError_def split: sum.splits)
+  done
+
+lemma liftE_K_bind: "liftE ((K_bind (\<lambda>s. A s)) x) = K_bind (liftE (\<lambda>s. A s)) x"
+  by clarsimp
+
+lemma monad_eq_split_tail:
+  "\<lbrakk>f = g; a s = b s\<rbrakk> \<Longrightarrow> (a >>= f) s = ((b >>= g) s)"
+  by (simp add:bind_def)
+
+lemma assert_opt_If:
+  "assert_opt v = If (v = None) fail (return (the v))"
+  by (simp add: assert_opt_def split: option.split)
+
+lemma if_to_top_of_bind:
+  "(bind (If P x y) z) = If P (bind x z) (bind y z)"
+  by (simp split: if_split)
+
+lemma if_to_top_of_bindE:
+  "(bindE (If P x y) z) = If P (bindE x z) (bindE y z)"
+  by (simp split: if_split)
 
 lemma modify_modify:
   "(do x \<leftarrow> modify f; modify (g x) od) = modify (g () o f)"
   by (simp add: bind_def simpler_modify_def)
 
-lemmas modify_modify_bind = arg_cong2[where f=bind,
-  OF modify_modify refl, simplified bind_assoc]
-
-lemma select_single:
-  "select {x} = return x"
-  by (simp add: select_def return_def)
+lemmas modify_modify_bind =
+  arg_cong2[where f=bind, OF modify_modify refl, simplified bind_assoc]
 
 lemma put_then_get[unfolded K_bind_def]:
   "do put s; get od = do put s; return s od"
   by (simp add: put_def bind_def get_def return_def)
 
-lemmas put_then_get_then
-    = put_then_get[THEN bind_then_eq, simplified bind_assoc return_bind]
+lemmas put_then_get_then =
+    put_then_get[THEN bind_then_eq, simplified bind_assoc return_bind]
 
 lemma select_empty_bind[simp]:
   "select {} >>= f = select {}"
   by (simp add: select_def bind_def)
 
-lemma fail_bind[simp]:
-  "fail >>= f = fail"
-  by (simp add: bind_def fail_def)
-
 
 subsection \<open>Alternative env_steps with repeat\<close>
 

lib/Monads/trace/Trace_More_VCG.thy

@@ -11,10 +11,743 @@
 theory Trace_More_VCG
   imports
     Trace_VCG
+    Trace_In_Monad
 begin
 
+lemma hoare_take_disjunct:
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. P' rv s \<and> (False \<or> P'' rv s)\<rbrace>
+   \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>P''\<rbrace>"
+  by (erule hoare_strengthen_post, simp)
+
+lemma hoare_post_add:
+  "\<lbrace>P\<rbrace> S \<lbrace>\<lambda>r s. R r s \<and> Q r s\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> S \<lbrace>Q\<rbrace>"
+  by (erule hoare_strengthen_post, simp)
+
+lemma hoare_post_addE:
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>_ s. R s \<and> Q s\<rbrace>, \<lbrace>T\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_ s. Q s\<rbrace>, \<lbrace>T\<rbrace>"
+  by (erule hoare_post_impErr'; simp)
+
+lemma hoare_pre_add:
+  "(\<forall>s. P s \<longrightarrow> R s) \<Longrightarrow> (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<longleftrightarrow> \<lbrace>P and R\<rbrace> f \<lbrace>Q\<rbrace>)"
+  apply (subst iff_conv_conj_imp)
+  by(intro conjI impI; rule hoare_weaken_pre, assumption, clarsimp)
+
+lemma hoare_pre_addE:
+  "(\<forall>s. P s \<longrightarrow> R s) \<Longrightarrow> (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>S\<rbrace> \<longleftrightarrow> \<lbrace>P and R\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>S\<rbrace>)"
+  apply (subst iff_conv_conj_imp)
+  by(intro conjI impI; rule hoare_weaken_preE, assumption, clarsimp)
+
+lemma hoare_name_pre_state:
+  "\<lbrakk> \<And>s. P s \<Longrightarrow> \<lbrace>(=) s\<rbrace> f \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (clarsimp simp: valid_def)
+
+lemma hoare_name_pre_stateE:
+  "\<lbrakk>\<And>s. P s \<Longrightarrow> \<lbrace>(=) s\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>"
+  by (clarsimp simp: validE_def2)
+
+lemma hoare_vcg_if_lift_strong:
+  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>P\<rbrace>; \<lbrace>\<lambda>s. \<not> P' s\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>R'\<rbrace> f \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow>
+   \<lbrace>\<lambda>s. if P' s then Q' s else R' s\<rbrace> f \<lbrace>\<lambda>rv s. if P rv s then Q rv s else R rv s\<rbrace>"
+
+  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>P\<rbrace>; \<lbrace>\<lambda>s. \<not> P' s\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>; \<lbrace>Q'\<rbrace> f \<lbrace> Q\<rbrace>; \<lbrace>R'\<rbrace> f \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow>
+   \<lbrace>\<lambda>s. if P' s then Q' s else R' s\<rbrace> f \<lbrace>\<lambda>rv s. (if P rv s then Q rv else R rv) s\<rbrace>"
+  by (wpsimp wp: hoare_vcg_imp_lift' | assumption | fastforce)+
+
+lemma hoare_vcg_imp_lift_pre_add:
+  "\<lbrakk> \<lbrace>P and Q\<rbrace> f \<lbrace>\<lambda>rv s. R rv s\<rbrace>; f \<lbrace>\<lambda>s. \<not> Q s\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q s \<longrightarrow> R rv s\<rbrace>"
+  apply (rule hoare_weaken_pre)
+   apply (rule hoare_vcg_imp_lift')
+    apply fastforce
+   apply fastforce
+  apply (clarsimp simp: pred_conj_def valid_def)
+  done
+
 lemma hoare_pre_tautI:
   "\<lbrakk> \<lbrace>A and P\<rbrace> a \<lbrace>B\<rbrace>; \<lbrace>A and not P\<rbrace> a \<lbrace>B\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> a \<lbrace>B\<rbrace>"
   by (fastforce simp: valid_def split_def pred_conj_def pred_neg_def)
 
+lemma hoare_lift_Pf_pre_conj:
+  assumes P: "\<And>x. \<lbrace>\<lambda>s. Q x s\<rbrace> m \<lbrace>P x\<rbrace>"
+  assumes f: "\<And>P. \<lbrace>\<lambda>s. P (g s) \<and> R s\<rbrace> m \<lbrace>\<lambda>_ s. P (f s)\<rbrace>"
+  shows "\<lbrace>\<lambda>s. Q (g s) s \<and> R s\<rbrace> m \<lbrace>\<lambda>rv s. P (f s) rv s\<rbrace>"
+  apply (clarsimp simp: valid_def)
+  apply (rule use_valid [OF _ P], simp)
+  apply (rule use_valid [OF _ f], simp, simp)
+  done
+
+lemmas hoare_lift_Pf4 = hoare_lift_Pf_pre_conj[where R=\<top>, simplified]
+lemmas hoare_lift_Pf3 = hoare_lift_Pf4[where f=f and g=f for f]
+lemmas hoare_lift_Pf2 = hoare_lift_Pf3[where P="\<lambda>f _. P f" for P]
+lemmas hoare_lift_Pf = hoare_lift_Pf2[where Q=P and P=P for P]
+
+lemmas hoare_lift_Pf3_pre_conj = hoare_lift_Pf_pre_conj[where f=f and g=f for f]
+lemmas hoare_lift_Pf2_pre_conj = hoare_lift_Pf3_pre_conj[where P="\<lambda>f _. P f" for P]
+lemmas hoare_lift_Pf_pre_conj' = hoare_lift_Pf2_pre_conj[where Q=P and P=P for P]
+
+lemma hoare_if_r_and:
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>r. if R r then Q r else Q' r\<rbrace>
+   = \<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. (R r \<longrightarrow> Q r s) \<and> (\<not>R r \<longrightarrow> Q' r s)\<rbrace>"
+  by (fastforce simp: valid_def)
+
+lemma hoare_convert_imp:
+  "\<lbrakk> \<lbrace>\<lambda>s. \<not> P s\<rbrace> f \<lbrace>\<lambda>rv s. \<not> Q s\<rbrace>; \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace> \<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. P s \<longrightarrow> R s\<rbrace> f \<lbrace>\<lambda>rv s. Q s \<longrightarrow> S rv s\<rbrace>"
+  apply (simp only: imp_conv_disj)
+  apply (erule(1) hoare_vcg_disj_lift)
+  done
+
+lemma hoare_vcg_ex_lift_R:
+  "\<lbrakk> \<And>v. \<lbrace>P v\<rbrace> f \<lbrace>Q v\<rbrace>,- \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<exists>v. P v s\<rbrace> f \<lbrace>\<lambda>rv s. \<exists>v. Q v rv s\<rbrace>,-"
+  apply (simp add: validE_R_def validE_def)
+  apply (rule hoare_strengthen_post, erule hoare_vcg_ex_lift)
+  apply (auto split: sum.split)
+  done
+
+lemma hoare_case_option_wpR:
+  "\<lbrakk>\<lbrace>P\<rbrace> f None \<lbrace>Q\<rbrace>,-; \<And>x. \<lbrace>P' x\<rbrace> f (Some x) \<lbrace>Q' x\<rbrace>,-\<rbrakk>
+   \<Longrightarrow> \<lbrace>case_option P P' v\<rbrace> f v \<lbrace>\<lambda>rv. case v of None \<Rightarrow> Q rv | Some x \<Rightarrow> Q' x rv\<rbrace>,-"
+  by (cases v) auto
+
+lemma hoare_vcg_conj_liftE_R:
+  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>P'\<rbrace>,-; \<lbrace>Q\<rbrace> f \<lbrace>Q'\<rbrace>,- \<rbrakk> \<Longrightarrow> \<lbrace>P and Q\<rbrace> f \<lbrace>\<lambda>rv s. P' rv s \<and> Q' rv s\<rbrace>, -"
+  apply (simp add: validE_R_def validE_def valid_def split: sum.splits)
+  apply blast
+  done
+
+lemma K_valid[wp]:
+  "\<lbrace>K P\<rbrace> f \<lbrace>\<lambda>_. K P\<rbrace>"
+  by (simp add: valid_def)
+
+lemma hoare_exI_tuple:
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>(rv,rv') s. Q x rv rv' s\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>(rv,rv') s. \<exists>x. Q x rv rv' s\<rbrace>"
+  by (fastforce simp: valid_def)
+
+lemma hoare_ex_all:
+  "(\<forall>x. \<lbrace>P x\<rbrace> f \<lbrace>Q\<rbrace>) = \<lbrace>\<lambda>s. \<exists>x. P x s\<rbrace> f \<lbrace>Q\<rbrace>"
+  apply (rule iffI)
+   apply (fastforce simp: valid_def)+
+  done
+
+lemma hoare_imp_eq_substR:
+  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,- \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. rv = x \<longrightarrow> Q x s\<rbrace>,-"
+  by (fastforce simp add: valid_def validE_R_def validE_def split: sum.splits)
+
+lemma hoare_split_bind_case_sum:
+  assumes x: "\<And>rv. \<lbrace>R rv\<rbrace> g rv \<lbrace>Q\<rbrace>"
+             "\<And>rv. \<lbrace>S rv\<rbrace> h rv \<lbrace>Q\<rbrace>"
+  assumes y: "\<lbrace>P\<rbrace> f \<lbrace>S\<rbrace>,\<lbrace>R\<rbrace>"
+  shows      "\<lbrace>P\<rbrace> f >>= case_sum g h \<lbrace>Q\<rbrace>"
+  apply (rule hoare_seq_ext [OF _ y[unfolded validE_def]])
+  apply (case_tac x, simp_all add: x)
+  done
+
+lemma hoare_split_bind_case_sumE:
+  assumes x: "\<And>rv. \<lbrace>R rv\<rbrace> g rv \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
+             "\<And>rv. \<lbrace>S rv\<rbrace> h rv \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
+  assumes y: "\<lbrace>P\<rbrace> f \<lbrace>S\<rbrace>,\<lbrace>R\<rbrace>"
+  shows      "\<lbrace>P\<rbrace> f >>= case_sum g h \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
+  apply (unfold validE_def)
+  apply (rule hoare_seq_ext [OF _ y[unfolded validE_def]])
+  apply (case_tac x, simp_all add: x [unfolded validE_def])
+  done
+
+lemma assertE_sp:
+  "\<lbrace>P\<rbrace> assertE Q \<lbrace>\<lambda>rv s. Q \<and> P s\<rbrace>,\<lbrace>E\<rbrace>"
+  by (clarsimp simp: assertE_def) wp
+
+lemma throwErrorE_E [wp]:
+  "\<lbrace>Q e\<rbrace> throwError e -, \<lbrace>Q\<rbrace>"
+  by (simp add: validE_E_def) wp
+
+lemma gets_inv [simp]:
+  "\<lbrace> P \<rbrace> gets f \<lbrace> \<lambda>r. P \<rbrace>"
+  by (simp add: gets_def, wp)
+
+lemma select_inv:
+  "\<lbrace> P \<rbrace> select S \<lbrace> \<lambda>r. P \<rbrace>"
+  by wpsimp
+
+lemmas return_inv = hoare_return_drop_var
+
+lemma assert_inv: "\<lbrace>P\<rbrace> assert Q \<lbrace>\<lambda>r. P\<rbrace>"
+  unfolding assert_def
+  by (cases Q) simp+
+
+lemma assert_opt_inv: "\<lbrace>P\<rbrace> assert_opt Q \<lbrace>\<lambda>r. P\<rbrace>"
+  unfolding assert_opt_def
+  by (cases Q) simp+
+
+lemma case_options_weak_wp:
+  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<And>x. \<lbrace>P'\<rbrace> g x \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P and P'\<rbrace> case opt of None \<Rightarrow> f | Some x \<Rightarrow> g x \<lbrace>Q\<rbrace>"
+  apply (cases opt)
+   apply (clarsimp elim!: hoare_weaken_pre)
+  apply (rule hoare_weaken_pre [where Q=P'])
+   apply simp+
+  done
+
+lemma case_option_wp_None_return:
+  assumes [wp]: "\<And>x. \<lbrace>P' x\<rbrace> f x \<lbrace>\<lambda>_. Q\<rbrace>"
+  shows "\<lbrakk>\<And>x s. (Q and P x) s \<Longrightarrow> P' x s \<rbrakk>
+         \<Longrightarrow> \<lbrace>Q and (\<lambda>s. opt \<noteq> None \<longrightarrow> P (the opt) s)\<rbrace>
+             (case opt of None \<Rightarrow> return () | Some x \<Rightarrow> f x)
+             \<lbrace>\<lambda>_. Q\<rbrace>"
+  by (cases opt; wpsimp)
+
+lemma case_option_wp_None_returnOk:
+  assumes [wp]: "\<And>x. \<lbrace>P' x\<rbrace> f x \<lbrace>\<lambda>_. Q\<rbrace>,\<lbrace>E\<rbrace>"
+  shows "\<lbrakk>\<And>x s. (Q and P x) s \<Longrightarrow> P' x s \<rbrakk>
+         \<Longrightarrow> \<lbrace>Q and (\<lambda>s. opt \<noteq> None \<longrightarrow> P (the opt) s)\<rbrace>
+             (case opt of None \<Rightarrow> returnOk () | Some x \<Rightarrow> f x)
+             \<lbrace>\<lambda>_. Q\<rbrace>,\<lbrace>E\<rbrace>"
+  by (cases opt; wpsimp)
+
+lemma list_cases_weak_wp:
+  assumes "\<lbrace>P_A\<rbrace> a \<lbrace>Q\<rbrace>"
+  assumes "\<And>x xs. \<lbrace>P_B\<rbrace> b x xs \<lbrace>Q\<rbrace>"
+  shows
+  "\<lbrace>P_A and P_B\<rbrace>
+   case ts of
+       [] \<Rightarrow> a
+     | x#xs \<Rightarrow> b x xs
+   \<lbrace>Q\<rbrace>"
+  apply (cases ts)
+  apply (simp, rule hoare_weaken_pre, rule assms, simp)+
+  done
+
+lemmas hoare_FalseE_R = hoare_FalseE[where E="\<top>\<top>", folded validE_R_def]
+
+lemma hoare_vcg_if_lift2:
+  "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P rv s \<longrightarrow> X rv s) \<and> (\<not> P rv s \<longrightarrow> Y rv s)\<rbrace> \<Longrightarrow>
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. if P rv s then X rv s else Y rv s\<rbrace>"
+
+  "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P' rv \<longrightarrow> X rv s) \<and> (\<not> P' rv \<longrightarrow> Y rv s)\<rbrace> \<Longrightarrow>
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv. if P' rv then X rv else Y rv\<rbrace>"
+  by (auto simp: valid_def split_def)
+
+lemma hoare_vcg_if_lift_ER: (* Required because of lack of rv in lifting rules *)
+  "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P rv s \<longrightarrow> X rv s) \<and> (\<not> P rv s \<longrightarrow> Y rv s)\<rbrace>, - \<Longrightarrow>
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. if P rv s then X rv s else Y rv s\<rbrace>, -"
+
+  "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P' rv \<longrightarrow> X rv s) \<and> (\<not> P' rv \<longrightarrow> Y rv s)\<rbrace>, - \<Longrightarrow>
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv. if P' rv then X rv else Y rv\<rbrace>, -"
+  by (auto simp: valid_def validE_R_def validE_def split_def)
+
+lemma hoare_list_all_lift:
+  "(\<And>r. r \<in> set xs \<Longrightarrow> \<lbrace>Q r\<rbrace> f \<lbrace>\<lambda>rv. Q r\<rbrace>)
+   \<Longrightarrow> \<lbrace>\<lambda>s. list_all (\<lambda>r. Q r s) xs\<rbrace> f \<lbrace>\<lambda>rv s. list_all (\<lambda>r. Q r s) xs\<rbrace>"
+  apply (induct xs; simp)
+  apply wpsimp
+  apply (rule hoare_vcg_conj_lift; simp)
+  done
+
+lemma undefined_valid: "\<lbrace>\<bottom>\<rbrace> undefined \<lbrace>Q\<rbrace>"
+  by (rule hoare_pre_cont)
+
+lemma assertE_wp:
+  "\<lbrace>\<lambda>s. F \<longrightarrow> Q () s\<rbrace> assertE F \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
+  apply (rule hoare_pre)
+   apply (unfold assertE_def)
+   apply wp
+  apply simp
+  done
+
+lemma doesn't_grow_proof:
+  assumes y: "\<And>s. finite (S s)"
+  assumes x: "\<And>x. \<lbrace>\<lambda>s. x \<notin> S s \<and> P s\<rbrace> f \<lbrace>\<lambda>rv s. x \<notin> S s\<rbrace>"
+  shows      "\<lbrace>\<lambda>s. card (S s) < n \<and> P s\<rbrace> f \<lbrace>\<lambda>rv s. card (S s) < n\<rbrace>"
+  apply (clarsimp simp: valid_def)
+  apply (subgoal_tac "S b \<subseteq> S s")
+   apply (drule card_mono [OF y], simp)
+  apply clarsimp
+  apply (rule ccontr)
+  apply (subgoal_tac "x \<notin> S b", simp)
+  apply (erule use_valid [OF _ x])
+  apply simp
+  done
+
+lemma hoare_vcg_propE_R:
+  "\<lbrace>\<lambda>s. P\<rbrace> f \<lbrace>\<lambda>rv s. P\<rbrace>, -"
+  by (simp add: validE_R_def validE_def valid_def split_def split: sum.split)
+
+lemma set_preserved_proof:
+  assumes y: "\<And>x. \<lbrace>\<lambda>s. Q s \<and> x \<in> S s\<rbrace> f \<lbrace>\<lambda>rv s. x \<in> S s\<rbrace>"
+  assumes x: "\<And>x. \<lbrace>\<lambda>s. Q s \<and> x \<notin> S s\<rbrace> f \<lbrace>\<lambda>rv s. x \<notin> S s\<rbrace>"
+  shows      "\<lbrace>\<lambda>s. Q s \<and> P (S s)\<rbrace> f \<lbrace>\<lambda>rv s. P (S s)\<rbrace>"
+  apply (clarsimp simp: valid_def)
+  by (metis (mono_tags, lifting) equalityI post_by_hoare subsetI x y)
+
+lemma set_shrink_proof:
+  assumes x: "\<And>x. \<lbrace>\<lambda>s. x \<notin> S s\<rbrace> f \<lbrace>\<lambda>rv s. x \<notin> S s\<rbrace>"
+  shows
+  "\<lbrace>\<lambda>s. \<forall>S'. S' \<subseteq> S s \<longrightarrow> P S'\<rbrace>
+   f
+   \<lbrace>\<lambda>rv s. P (S s)\<rbrace>"
+  apply (clarsimp simp: valid_def)
+  apply (drule spec, erule mp)
+  apply (clarsimp simp: subset_iff)
+  apply (rule ccontr)
+  apply (drule(1) use_valid [OF _ x])
+  apply simp
+  done
+
+lemma shrinks_proof:
+  assumes y: "\<And>s. finite (S s)"
+  assumes x: "\<And>x. \<lbrace>\<lambda>s. x \<notin> S s \<and> P s\<rbrace> f \<lbrace>\<lambda>rv s. x \<notin> S s\<rbrace>"
+  assumes z: "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. x \<notin> S s\<rbrace>"
+  assumes w: "\<And>s. P s \<Longrightarrow> x \<in> S s"
+  shows      "\<lbrace>\<lambda>s. card (S s) \<le> n \<and> P s\<rbrace> f \<lbrace>\<lambda>rv s. card (S s) < n\<rbrace>"
+  apply (clarsimp simp: valid_def)
+  apply (subgoal_tac "S b \<subset> S s")
+   apply (drule psubset_card_mono [OF y], simp)
+  apply (rule psubsetI)
+   apply clarsimp
+   apply (rule ccontr)
+   apply (subgoal_tac "x \<notin> S b", simp)
+   apply (erule use_valid [OF _ x])
+   apply simp
+  by (metis use_valid w z)
+
+lemma use_validE_R:
+  "\<lbrakk> (Inr r, s') \<in> mres (f s); \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-; P s \<rbrakk> \<Longrightarrow> Q r s'"
+  unfolding validE_R_def validE_def
+  by (frule(2) use_valid, simp)
+
+lemma valid_preservation_ex:
+  assumes x: "\<And>x P. \<lbrace>\<lambda>s. P (f s x :: 'b)\<rbrace> m \<lbrace>\<lambda>rv s. P (f s x)\<rbrace>"
+  shows      "\<lbrace>\<lambda>s. P (f s :: 'a \<Rightarrow> 'b)\<rbrace> m \<lbrace>\<lambda>rv s. P (f s)\<rbrace>"
+  apply (clarsimp simp: valid_def)
+  apply (erule subst[rotated, where P=P])
+  apply (rule ext)
+  apply (erule use_valid [OF _ x])
+  apply simp
+  done
+
+lemma whenE_inv:
+  assumes a: "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"
+  shows "\<lbrace>P\<rbrace> whenE Q f \<lbrace>\<lambda>_. P\<rbrace>"
+  by (wpsimp wp: a)
+
+lemma whenE_throwError_wp:
+  "\<lbrace>\<lambda>s. \<not> P \<longrightarrow> Q s\<rbrace> whenE P (throwError e) \<lbrace>\<lambda>_. Q\<rbrace>, \<lbrace>\<top>\<top>\<rbrace>"
+  by wpsimp
+
+lemma ifM_throwError_returnOk:
+  "\<lbrace>Q\<rbrace> test \<lbrace>\<lambda>c s. \<not> c \<longrightarrow> P s\<rbrace> \<Longrightarrow> \<lbrace>Q\<rbrace> ifM test (throwError e) (returnOk ()) \<lbrace>\<lambda>_. P\<rbrace>, -"
+  unfolding ifM_def
+  apply (fold liftE_bindE)
+  apply wpsimp
+   apply assumption
+  apply simp
+  done
+
+lemma ifME_liftE:
+  "ifME (liftE test) a b = ifM test a b"
+  by (simp add: ifME_def ifM_def liftE_bindE)
+
+lemma gets_the_inv: "\<lbrace>P\<rbrace> gets_the V \<lbrace>\<lambda>rv. P\<rbrace>" by wpsimp
+
+lemmas state_unchanged = in_inv_by_hoareD [THEN sym]
+
+lemma validI:
+  assumes rl: "\<And>s r s'. \<lbrakk> P s; (r, s') \<in> mres (S s) \<rbrakk> \<Longrightarrow> Q r s'"
+  shows "\<lbrace>P\<rbrace> S \<lbrace>Q\<rbrace>"
+  unfolding valid_def using rl by safe
+
+lemma opt_return_pres_lift:
+  assumes x: "\<And>v. \<lbrace>P\<rbrace> f v \<lbrace>\<lambda>rv. P\<rbrace>"
+  shows      "\<lbrace>P\<rbrace> case x of None \<Rightarrow> return () | Some v \<Rightarrow> f v \<lbrace>\<lambda>rv. P\<rbrace>"
+  by (wpsimp wp: x)
+
+lemma valid_return_unit:
+  "\<lbrace>P\<rbrace> f >>= (\<lambda>_. return ()) \<lbrace>\<lambda>r. Q\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>r. Q\<rbrace>"
+  by (auto simp: valid_def in_bind in_return Ball_def)
+
+lemma hoare_weak_lift_imp_conj:
+  "\<lbrakk> \<lbrace>Q\<rbrace> m \<lbrace>Q'\<rbrace>; \<lbrace>R\<rbrace> m \<lbrace>R'\<rbrace> \<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. (P \<longrightarrow> Q s) \<and> R s\<rbrace> m \<lbrace>\<lambda>rv s. (P \<longrightarrow> Q' rv s) \<and> R' rv s\<rbrace>"
+  apply (rule hoare_vcg_conj_lift)
+   apply (rule hoare_weak_lift_imp)
+   apply assumption+
+  done
+
+lemma hoare_eq_P:
+  assumes "\<And>P. \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"
+  shows "\<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>_. (=) s\<rbrace>"
+  by (rule assms)
+
+lemma hoare_validE_R_conj:
+  "\<lbrakk>\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, -; \<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>, -\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q and R\<rbrace>, -"
+  by (simp add: valid_def validE_def validE_R_def Let_def split_def split: sum.splits)
+
+lemmas throwError_validE_R = throwError_wp [where E="\<top>\<top>", folded validE_R_def]
+
+lemma valid_case_option_post_wp:
+  "\<lbrakk>\<And>x. \<lbrace>P x\<rbrace> f \<lbrace>\<lambda>rv. Q x\<rbrace>\<rbrakk> \<Longrightarrow>
+   \<lbrace>\<lambda>s. case ep of Some x \<Rightarrow> P x s | _ \<Rightarrow> True\<rbrace>
+   f
+   \<lbrace>\<lambda>rv s. case ep of Some x \<Rightarrow> Q x s | _ \<Rightarrow> True\<rbrace>"
+  by (cases ep, simp_all add: hoare_vcg_prop)
+
+lemma P_bool_lift:
+  assumes t: "\<lbrace>Q\<rbrace> f \<lbrace>\<lambda>r. Q\<rbrace>"
+  assumes f: "\<lbrace>\<lambda>s. \<not>Q s\<rbrace> f \<lbrace>\<lambda>r s. \<not>Q s\<rbrace>"
+  shows "\<lbrace>\<lambda>s. P (Q s)\<rbrace> f \<lbrace>\<lambda>r s. P (Q s)\<rbrace>"
+  apply (clarsimp simp: valid_def)
+  apply (subgoal_tac "Q b = Q s")
+   apply simp
+  apply (rule iffI)
+   apply (rule classical)
+   apply (drule (1) use_valid [OF _ f])
+   apply simp
+  apply (erule (1) use_valid [OF _ t])
+  done
+
+lemmas fail_inv = hoare_fail_any[where Q="\<lambda>_. P" and P=P for P]
+
+lemma gets_sp: "\<lbrace>P\<rbrace> gets f \<lbrace>\<lambda>rv. P and (\<lambda>s. f s = rv)\<rbrace>"
+  by (wp, simp)
+
+lemma post_by_hoare2:
+  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; (r, s') \<in> mres (f s); P s \<rbrakk> \<Longrightarrow> Q r s'"
+  by (rule post_by_hoare, assumption+)
+
+lemma hoare_Ball_helper:
+  assumes x: "\<And>x. \<lbrace>P x\<rbrace> f \<lbrace>Q x\<rbrace>"
+  assumes y: "\<And>P. \<lbrace>\<lambda>s. P (S s)\<rbrace> f \<lbrace>\<lambda>rv s. P (S s)\<rbrace>"
+  shows "\<lbrace>\<lambda>s. \<forall>x \<in> S s. P x s\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x \<in> S s. Q x rv s\<rbrace>"
+  apply (clarsimp simp: valid_def)
+  apply (subgoal_tac "S b = S s")
+   apply (erule post_by_hoare2 [OF x])
+   apply (clarsimp simp: Ball_def)
+  apply (erule_tac P1="\<lambda>x. x = S s" in post_by_hoare2 [OF y])
+  apply (rule refl)
+  done
+
+lemma handy_prop_divs:
+  assumes x: "\<And>P. \<lbrace>\<lambda>s. P (Q s) \<and> S s\<rbrace> f \<lbrace>\<lambda>rv s. P (Q' rv s)\<rbrace>"
+             "\<And>P. \<lbrace>\<lambda>s. P (R s) \<and> S s\<rbrace> f \<lbrace>\<lambda>rv s. P (R' rv s)\<rbrace>"
+  shows      "\<lbrace>\<lambda>s. P (Q s \<and> R s) \<and> S s\<rbrace> f \<lbrace>\<lambda>rv s. P (Q' rv s \<and> R' rv s)\<rbrace>"
+             "\<lbrace>\<lambda>s. P (Q s \<or> R s) \<and> S s\<rbrace> f \<lbrace>\<lambda>rv s. P (Q' rv s \<or> R' rv s)\<rbrace>"
+   apply (clarsimp simp: valid_def
+                  elim!: subst[rotated, where P=P])
+   apply (rule use_valid [OF _ x(1)], assumption)
+   apply (rule use_valid [OF _ x(2)], assumption)
+   apply simp
+  apply (clarsimp simp: valid_def
+                 elim!: subst[rotated, where P=P])
+  apply (rule use_valid [OF _ x(1)], assumption)
+  apply (rule use_valid [OF _ x(2)], assumption)
+  apply simp
+  done
+
+lemma hoare_as_subst:
+  "\<lbrakk> \<And>P. \<lbrace>\<lambda>s. P (fn s)\<rbrace> f \<lbrace>\<lambda>rv s. P (fn s)\<rbrace>;
+     \<And>v :: 'a. \<lbrace>P v\<rbrace> f \<lbrace>Q v\<rbrace> \<rbrakk> \<Longrightarrow>
+   \<lbrace>\<lambda>s. P (fn s) s\<rbrace> f \<lbrace>\<lambda>rv s. Q (fn s) rv s\<rbrace>"
+  by (rule hoare_lift_Pf3)
+
+lemmas hoare_vcg_ball_lift = hoare_vcg_const_Ball_lift
+
+lemma hoare_set_preserved:
+  assumes x: "\<And>x. \<lbrace>fn' x\<rbrace> m \<lbrace>\<lambda>rv. fn x\<rbrace>"
+  shows      "\<lbrace>\<lambda>s. set xs \<subseteq> {x. fn' x s}\<rbrace> m \<lbrace>\<lambda>rv s. set xs \<subseteq> {x. fn x s}\<rbrace>"
+  apply (induct xs)
+   apply simp
+   apply wp
+  apply simp
+  apply (rule hoare_vcg_conj_lift)
+   apply (rule x)
+  apply assumption
+  done
+
+lemma hoare_ex_pre: (* safe, unlike hoare_vcg_ex_lift *)
+  "(\<And>x. \<lbrace>P x\<rbrace> f \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>\<lambda>s. \<exists>x. P x s\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (fastforce simp: valid_def)
+
+lemma hoare_ex_pre_conj:
+  "\<lbrakk>\<And>x. \<lbrace>\<lambda>s. P x s \<and> P' s\<rbrace> f \<lbrace>Q\<rbrace>\<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. (\<exists>x. P x s) \<and> P' s\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (fastforce simp: valid_def)
+
+lemma hoare_conj_lift_inv:
+  "\<lbrakk>\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>\<lambda>s. P' s \<and> I s\<rbrace> f \<lbrace>\<lambda>rv. I\<rbrace>;
+    \<And>s. P s \<Longrightarrow> P' s\<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> I s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> I s\<rbrace>"
+   by (fastforce simp: valid_def)
+
+lemma hoare_in_monad_post:
+  assumes x: "\<And>P. \<lbrace>P\<rbrace> f \<lbrace>\<lambda>x. P\<rbrace>"
+  shows      "\<lbrace>\<top>\<rbrace> f \<lbrace>\<lambda>rv s. (rv, s) \<in> mres (f s)\<rbrace>"
+  apply (clarsimp simp: valid_def)
+  apply (subgoal_tac "s = b", simp)
+  apply (simp add: state_unchanged [OF x])
+  done
+
+lemma list_case_throw_validE_R:
+  "\<lbrakk> \<And>y ys. xs = y # ys \<Longrightarrow> \<lbrace>P\<rbrace> f y ys \<lbrace>Q\<rbrace>,- \<rbrakk> \<Longrightarrow>
+   \<lbrace>P\<rbrace> case xs of [] \<Rightarrow> throwError e | x # xs \<Rightarrow> f x xs \<lbrace>Q\<rbrace>,-"
+  apply (case_tac xs, simp_all)
+  apply wp
+  done
+
+lemma validE_R_sp:
+  assumes x: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-"
+  assumes y: "\<And>x. \<lbrace>Q x\<rbrace> g x \<lbrace>R\<rbrace>,-"
+  shows "\<lbrace>P\<rbrace> f >>=E (\<lambda>x. g x) \<lbrace>R\<rbrace>,-"
+  by (rule hoare_pre, wp x y, simp)
+
+lemma valid_set_take_helper:
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x \<in> set (xs rv s). Q x rv s\<rbrace>
+   \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x \<in> set (take (n rv s) (xs rv s)). Q x rv s\<rbrace>"
+  apply (erule hoare_strengthen_post)
+  apply (clarsimp dest!: in_set_takeD)
+  done
+
+lemma whenE_throwError_sp:
+  "\<lbrace>P\<rbrace> whenE Q (throwError e) \<lbrace>\<lambda>rv s. \<not> Q \<and> P s\<rbrace>, -"
+  apply (simp add: whenE_def validE_R_def)
+  apply (intro conjI impI; wp)
+  done
+
+lemma weaker_hoare_ifE:
+  assumes x: "\<lbrace>P \<rbrace> a \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
+  assumes y: "\<lbrace>P'\<rbrace> b \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
+  shows      "\<lbrace>P and P'\<rbrace> if test then a else b \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
+  apply (rule hoare_vcg_precond_impE)
+   apply (wp x y)
+  apply simp
+  done
+
+lemma wp_split_const_if:
+  assumes x: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
+  assumes y: "\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>"
+  shows "\<lbrace>\<lambda>s. (G \<longrightarrow> P s) \<and> (\<not> G \<longrightarrow> P' s)\<rbrace> f \<lbrace>\<lambda>rv s. (G \<longrightarrow> Q rv s) \<and> (\<not> G \<longrightarrow> Q' rv s)\<rbrace>"
+  by (case_tac G, simp_all add: x y)
+
+lemma wp_split_const_if_R:
+  assumes x: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-"
+  assumes y: "\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>,-"
+  shows "\<lbrace>\<lambda>s. (G \<longrightarrow> P s) \<and> (\<not> G \<longrightarrow> P' s)\<rbrace> f \<lbrace>\<lambda>rv s. (G \<longrightarrow> Q rv s) \<and> (\<not> G \<longrightarrow> Q' rv s)\<rbrace>,-"
+  by (case_tac G, simp_all add: x y)
+
+lemma hoare_disj_division:
+  "\<lbrakk> P \<or> Q; P \<Longrightarrow> \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace>; Q \<Longrightarrow> \<lbrace>T\<rbrace> f \<lbrace>S\<rbrace> \<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. (P \<longrightarrow> R s) \<and> (Q \<longrightarrow> T s)\<rbrace> f \<lbrace>S\<rbrace>"
+  apply safe
+   apply (rule hoare_pre_imp)
+    prefer 2
+    apply simp
+   apply simp
+  apply (rule hoare_pre_imp)
+   prefer 2
+   apply simp
+  apply simp
+  done
+
+lemma hoare_grab_asm:
+  "\<lbrakk> G \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. G \<and> P s\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (cases G, simp+)
+
+lemma hoare_grab_asm2:
+  "\<lbrakk>P' \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> R s\<rbrace> f \<lbrace>Q\<rbrace>\<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> P' \<and> R s\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (fastforce simp: valid_def)
+
+lemma hoare_grab_exs:
+  assumes x: "\<And>x. P x \<Longrightarrow> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>"
+  shows      "\<lbrace>\<lambda>s. \<exists>x. P x \<and> P' s\<rbrace> f \<lbrace>Q\<rbrace>"
+  apply (clarsimp simp: valid_def)
+  apply (erule(2) use_valid [OF _ x])
+  done
+
+lemma hoare_prop_E: "\<lbrace>\<lambda>rv. P\<rbrace> f -,\<lbrace>\<lambda>rv s. P\<rbrace>"
+  unfolding validE_E_def
+  by (rule hoare_pre, wp, simp)
+
+lemma hoare_vcg_conj_lift_R:
+  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-; \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace>,- \<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> R s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> S rv s\<rbrace>,-"
+  apply (simp add: validE_R_def validE_def)
+  apply (drule(1) hoare_vcg_conj_lift)
+  apply (erule hoare_strengthen_post)
+  apply (clarsimp split: sum.splits)
+  done
+
+lemma hoare_walk_assmsE:
+  assumes x: "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv. P\<rbrace>" and y: "\<And>s. P s \<Longrightarrow> Q s" and z: "\<lbrace>P\<rbrace> g \<lbrace>\<lambda>rv. Q\<rbrace>"
+  shows      "\<lbrace>P\<rbrace> doE x \<leftarrow> f; g odE \<lbrace>\<lambda>rv. Q\<rbrace>"
+  apply (wp z)
+   apply (simp add: validE_def)
+   apply (rule hoare_strengthen_post [OF x])
+   apply (auto simp: y split: sum.splits)
+  done
+
+lemma univ_wp:
+  "\<lbrace>\<lambda>s. \<forall>(rv, s') \<in> mres (f s). Q rv s'\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (simp add: valid_def)
+
+lemma univ_get_wp:
+  assumes x: "\<And>P. \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv. P\<rbrace>"
+  shows "\<lbrace>\<lambda>s. \<forall>(rv, s') \<in> mres (f s). s = s' \<longrightarrow> Q rv s'\<rbrace> f \<lbrace>Q\<rbrace>"
+  apply (rule hoare_pre_imp [OF _ univ_wp])
+  apply clarsimp
+  apply (drule bspec, assumption, simp)
+  apply (subgoal_tac "s = b", simp)
+  apply (simp add: state_unchanged [OF x])
+  done
+
+lemma other_hoare_in_monad_post:
+  assumes x: "\<And>P. \<lbrace>P\<rbrace> fn \<lbrace>\<lambda>rv. P\<rbrace>"
+  shows "\<lbrace>\<lambda>s. \<forall>(v, s) \<in> mres (fn s). F v = v\<rbrace> fn \<lbrace>\<lambda>v s'. (F v, s') \<in> mres (fn s')\<rbrace>"
+  proof -
+  have P: "\<And>v s. (F v = v) \<and> (v, s) \<in> mres (fn s) \<Longrightarrow> (F v, s) \<in> mres (fn s)"
+    by simp
+  show ?thesis
+  apply (rule hoare_post_imp [OF P], assumption)
+  apply (rule hoare_pre_imp)
+  defer
+   apply (rule hoare_vcg_conj_lift)
+    apply (rule univ_get_wp [OF x])
+   apply (rule hoare_in_monad_post [OF x])
+  apply clarsimp
+  apply (drule bspec, assumption, simp)
+  done
+  qed
+
+lemma weak_if_wp:
+  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace> \<rbrakk> \<Longrightarrow>
+   \<lbrace>P and P'\<rbrace> f \<lbrace>\<lambda>r. if C r then Q r else Q' r\<rbrace>"
+  by (auto simp add: valid_def split_def)
+
+lemma weak_if_wp':
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>r. Q r and Q' r\<rbrace> \<Longrightarrow>
+   \<lbrace>P\<rbrace> f \<lbrace>\<lambda>r. if C r then Q r else Q' r\<rbrace>"
+  by (auto simp add: valid_def split_def)
+
+lemma bindE_split_recursive_asm:
+  assumes x: "\<And>x s'. \<lbrakk> (Inr x, s') \<in> mres (f s) \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. B x s \<and> s = s'\<rbrace> g x \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>"
+  shows      "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>, \<lbrace>E\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>st. A st \<and> st = s\<rbrace> f >>=E g \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>"
+  apply (clarsimp simp: validE_def valid_def bindE_def in_bind lift_def)
+  apply (erule allE, erule(1) impE)
+  apply (drule(1) bspec, simp)
+  apply (case_tac x, simp_all add: in_throwError)
+  apply (drule x)
+  apply (clarsimp simp: validE_def valid_def)
+  apply (drule(1) bspec, simp)
+  done
+
+lemma validE_R_abstract_rv:
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>rv'. Q rv' s\<rbrace>,- \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-"
+  by (erule hoare_post_imp_R, simp)
+
+lemma validE_cases_valid:
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q (Inr rv) s\<rbrace>,\<lbrace>\<lambda>rv s. Q (Inl rv) s\<rbrace>
+   \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
+  apply (simp add: validE_def)
+  apply (erule hoare_strengthen_post)
+  apply (simp split: sum.split_asm)
+  done
+
+lemma liftM_pre:
+  assumes rl: "\<lbrace>\<lambda>s. \<not> P s \<rbrace> a \<lbrace> \<lambda>_ _. False \<rbrace>"
+  shows "\<lbrace>\<lambda>s. \<not> P s \<rbrace> liftM f a \<lbrace> \<lambda>_ _. False \<rbrace>"
+  unfolding liftM_def
+  apply (rule seq)
+  apply (rule rl)
+  apply wp
+  apply simp
+  done
+
+lemma hoare_gen_asm':
+  "(P \<Longrightarrow> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>P' and (\<lambda>_. P)\<rbrace> f \<lbrace>Q\<rbrace>"
+  apply (auto intro: hoare_assume_pre)
+  done
+
+lemma hoare_gen_asm_conj:
+  "(P \<Longrightarrow> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>\<lambda>s. P' s \<and> P\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (fastforce simp: valid_def)
+
+lemma hoare_add_K:
+  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> I\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> I\<rbrace>"
+  by (fastforce simp: valid_def)
+
+lemma valid_rv_lift:
+  "\<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. rv \<longrightarrow> Q rv s\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>s. P \<and> P' s\<rbrace> f \<lbrace>\<lambda>rv s. rv \<longrightarrow> P \<and> Q rv s\<rbrace>"
+  by (fastforce simp: valid_def)
+
+lemma valid_imp_ex:
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. \<exists>x. rv \<longrightarrow> Q rv s x\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. rv \<longrightarrow> (\<exists>x. Q rv s x)\<rbrace>"
+  by (fastforce simp: valid_def)
+
+lemma valid_rv_split:
+  "\<lbrakk>\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. rv \<longrightarrow> Q s\<rbrace>; \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. \<not>rv \<longrightarrow> Q' s\<rbrace>\<rbrakk>
+   \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. if rv then Q s else Q' s\<rbrace>"
+  by (fastforce simp: valid_def)
+
+lemma hoare_rv_split:
+  "\<lbrakk>\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. rv \<longrightarrow> (Q rv s)\<rbrace>; \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. (\<not>rv) \<longrightarrow> (Q rv s)\<rbrace>\<rbrakk>
+   \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
+  apply (clarsimp simp: valid_def)
+  apply (case_tac a, fastforce+)
+  done
+
+lemma combine_validE:
+  "\<lbrakk> \<lbrace> P \<rbrace> x \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>; \<lbrace> P' \<rbrace> x \<lbrace> Q' \<rbrace>,\<lbrace> E' \<rbrace> \<rbrakk>
+   \<Longrightarrow> \<lbrace> P and P' \<rbrace> x \<lbrace> \<lambda>r. (Q r) and (Q' r) \<rbrace>,\<lbrace>\<lambda>r. (E r) and (E' r) \<rbrace>"
+  apply (clarsimp simp: validE_def valid_def split: sum.splits)
+  apply (erule allE, erule (1) impE)+
+  apply (drule (1) bspec)+
+  apply clarsimp
+  done
+
+lemma valid_case_prod:
+  "\<lbrakk> \<And>x y. valid (P x y) (f x y) Q \<rbrakk> \<Longrightarrow> valid (case_prod P v) (case_prod (\<lambda>x y. f x y) v) Q"
+  by (simp add: split_def)
+
+lemma validE_case_prod:
+  "\<lbrakk> \<And>x y. validE (P x y) (f x y) Q E \<rbrakk> \<Longrightarrow> validE (case_prod P v) (case_prod (\<lambda>x y. f x y) v) Q E"
+  by (simp add: split_def)
+
+lemma valid_pre_satisfies_post:
+  "\<lbrakk> \<And>s r' s'. P s \<Longrightarrow> Q r' s' \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> m \<lbrace> Q \<rbrace>"
+  by (clarsimp simp: valid_def)
+
+lemma validE_pre_satisfies_post:
+  "\<lbrakk> \<And>s r' s'. P s \<Longrightarrow> Q r' s'; \<And>s r' s'. P s \<Longrightarrow> R r' s' \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> m \<lbrace> Q \<rbrace>,\<lbrace> R \<rbrace>"
+  by (clarsimp simp: validE_def2 split: sum.splits)
+
+lemma hoare_validE_R_conjI:
+  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, - ; \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>, - \<rbrakk>  \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>, -"
+  apply (clarsimp simp: Ball_def validE_R_def validE_def valid_def)
+  by (case_tac a; fastforce)
+
+lemma hoare_validE_E_conjI:
+  "\<lbrakk> \<lbrace>P\<rbrace> f -, \<lbrace>Q\<rbrace> ; \<lbrace>P\<rbrace> f -, \<lbrace>Q'\<rbrace> \<rbrakk>  \<Longrightarrow> \<lbrace>P\<rbrace> f -, \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>"
+  apply (clarsimp simp: Ball_def validE_E_def validE_def valid_def)
+  by (case_tac a; fastforce)
+
+lemma validE_R_post_conjD1:
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. Q r s \<and> R r s\<rbrace>,- \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-"
+  apply (clarsimp simp: validE_R_def validE_def valid_def)
+  by (case_tac a; fastforce)
+
+lemma validE_R_post_conjD2:
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. Q r s \<and> R r s\<rbrace>,- \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>,-"
+  apply (clarsimp simp: validE_R_def validE_def valid_def)
+  by (case_tac a; fastforce)
+
+lemma throw_opt_wp[wp]:
+  "\<lbrace>if v = None then E ex else Q (the v)\<rbrace> throw_opt ex v \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
+  unfolding throw_opt_def by wpsimp auto
+
+lemma hoare_name_pre_state2:
+  "(\<And>s. \<lbrace>P and ((=) s)\<rbrace> f \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (auto simp: valid_def intro: hoare_name_pre_state)
+
+lemma returnOk_E': "\<lbrace>P\<rbrace> returnOk r -,\<lbrace>E\<rbrace>"
+  by wpsimp
+
+lemma throwError_R': "\<lbrace>P\<rbrace> throwError e \<lbrace>Q\<rbrace>,-"
+  by wpsimp
+
 end

lib/Monads/trace/Trace_No_Fail.thy

@@ -42,6 +42,11 @@ subsection \<open>Bundles\<close>
 
 bundle no_pre = hoare_pre [wp_pre del] no_fail_pre [wp_pre del]
 
+bundle classic_wp_pre =
+  hoare_pre [wp_pre del]
+  all_classic_wp_combs[wp_comb del]
+  all_classic_wp_combs[wp_comb]
+
 
 subsection \<open>Lemmas\<close>
 
@@ -126,7 +131,7 @@ lemma no_fail_returnOK[simp, wp]:
 
 lemma no_fail_bind[wp]:
   "\<lbrakk> no_fail P f; \<And>x. no_fail (R x) (g x); \<lbrace>Q\<rbrace> f \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow> no_fail (P and Q) (f >>= (\<lambda>rv. g rv))"
-  apply (simp add: no_fail_def bind_def2 image_Un image_image
+  apply (simp add: no_fail_def bind_def' image_Un image_image
                    in_image_constant)
   apply (intro allI conjI impI)
    apply (fastforce simp: image_def)
@@ -135,8 +140,92 @@ lemma no_fail_bind[wp]:
   apply (fastforce simp: image_def)
   done
 
+lemma no_fail_assume_pre:
+  "(\<And>s. P s \<Longrightarrow> no_fail P f) \<Longrightarrow> no_fail P f"
+  by (simp add: no_fail_def)
+
+\<comment> \<open>lemma no_fail_liftM_eq[simp]:
+  "no_fail P (liftM f m) = no_fail P m"
+  by (auto simp: liftM_def no_fail_def bind_def return_def)\<close>
+
+lemma no_fail_liftM[wp]:
+  "no_fail P m \<Longrightarrow> no_fail P (liftM f m)"
+  unfolding liftM_def
+  by wpsimp
+
+lemma no_fail_pre_and:
+  "no_fail P f \<Longrightarrow> no_fail (P and Q) f"
+  by (erule no_fail_pre) simp
+
+lemma no_fail_spec:
+  "\<lbrakk> \<And>s. no_fail (((=) s) and P) f \<rbrakk> \<Longrightarrow> no_fail P f"
+  by (simp add: no_fail_def)
+
+lemma no_fail_assertE[wp]:
+  "no_fail (\<lambda>_. P) (assertE P)"
+  by (simp add: assertE_def split: if_split)
+
+lemma no_fail_spec_pre:
+  "\<lbrakk> no_fail (((=) s) and P') f; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> no_fail (((=) s) and P) f"
+  by (erule no_fail_pre, simp)
+
+lemma no_fail_whenE[wp]:
+  "\<lbrakk> G \<Longrightarrow> no_fail P f \<rbrakk> \<Longrightarrow> no_fail (\<lambda>s. G \<longrightarrow> P s) (whenE G f)"
+  by (simp add: whenE_def split: if_split)
+
+lemma no_fail_unlessE[wp]:
+  "\<lbrakk> \<not> G \<Longrightarrow> no_fail P f \<rbrakk> \<Longrightarrow> no_fail (\<lambda>s. \<not> G \<longrightarrow> P s) (unlessE G f)"
+  by (simp add: unlessE_def split: if_split)
+
+lemma no_fail_throwError[wp]:
+  "no_fail \<top> (throwError e)"
+  by (simp add: throwError_def)
+
+lemma no_fail_liftE[wp]:
+  "no_fail P f \<Longrightarrow> no_fail P (liftE f)"
+  unfolding liftE_def by wpsimp
+
+lemma no_fail_gets_the[wp]:
+  "no_fail (\<lambda>s. f s \<noteq> None) (gets_the f)"
+  unfolding gets_the_def
+  by wpsimp
+
+lemma no_fail_lift:
+  "(\<And>y. x = Inr y \<Longrightarrow> no_fail P (f y)) \<Longrightarrow> no_fail (\<lambda>s. \<not>isl x \<longrightarrow> P s) (lift f x)"
+  unfolding lift_def
+  by (wpsimp wp: no_fail_throwError split: sum.splits | assumption)+
+
+lemma validE_R_valid_eq:
+  "\<lbrace>Q\<rbrace> f \<lbrace>R\<rbrace>, - = \<lbrace>Q\<rbrace> f \<lbrace>\<lambda>rv s. \<not> isl rv \<longrightarrow> R (projr rv) s\<rbrace>"
+  unfolding validE_R_def validE_def valid_def
+  by (fastforce split: sum.splits prod.split)
+
+lemma no_fail_bindE[wp]:
+  "\<lbrakk> no_fail P f; \<And>rv. no_fail (R rv) (g rv); \<lbrace>Q\<rbrace> f \<lbrace>R\<rbrace>,- \<rbrakk>
+     \<Longrightarrow> no_fail (P and Q) (f >>=E g)"
+  unfolding bindE_def
+  by (wpsimp wp: no_fail_lift simp: validE_R_valid_eq | assumption)+
+
+lemma no_fail_False[simp]:
+  "no_fail (\<lambda>_. False) X"
+  by (clarsimp simp: no_fail_def)
+
+lemma no_fail_gets_map[wp]:
+  "no_fail (\<lambda>s. f s p \<noteq> None) (gets_map f p)"
+  unfolding gets_map_def by wpsimp
+
 lemma no_fail_or:
   "\<lbrakk>no_fail P a; no_fail Q a\<rbrakk> \<Longrightarrow> no_fail (P or Q) a"
   by (clarsimp simp: no_fail_def)
 
+lemma no_fail_state_assert[wp]:
+  "no_fail P (state_assert P)"
+  unfolding state_assert_def
+  by wpsimp
+
+lemma no_fail_condition:
+  "\<lbrakk>no_fail Q A; no_fail R B\<rbrakk> \<Longrightarrow> no_fail (\<lambda>s. (C s \<longrightarrow> Q s) \<and> (\<not> C s \<longrightarrow> R s)) (condition C A B)"
+  unfolding condition_def no_fail_def
+  by clarsimp
+
 end

lib/Monads/trace/Trace_No_Throw.thy

@@ -25,4 +25,78 @@ definition no_throw :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'e + 'a) tmon
 definition no_return :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b + 'c) tmonad \<Rightarrow> bool" where
   "no_return P A \<equiv> \<lbrace> P \<rbrace> A \<lbrace>\<lambda>_ _. False\<rbrace>,\<lbrace>\<lambda>_ _. True \<rbrace>"
 
+(* Alternative definition of no_throw; easier to work with than unfolding validE. *)
+lemma no_throw_def':
+  "no_throw P A = (\<forall>s. P s \<longrightarrow> (\<forall>(r, t) \<in> mres (A s). (\<exists>x. r = Inr x)))"
+  by (clarsimp simp: no_throw_def validE_def2 split_def split: sum.splits)
+
+
+subsection \<open>no_throw rules\<close>
+
+lemma no_throw_returnOk[simp]:
+  "no_throw P (returnOk a)"
+  unfolding no_throw_def
+  by wp
+
+lemma no_throw_liftE[simp]:
+  "no_throw P (liftE x)"
+  by (wpsimp simp: liftE_def no_throw_def validE_def)
+
+lemma no_throw_bindE:
+  "\<lbrakk> no_throw A X; \<And>a. no_throw B (Y a); \<lbrace> A \<rbrace> X \<lbrace> \<lambda>_. B \<rbrace>,\<lbrace> \<lambda>_ _. True \<rbrace> \<rbrakk>
+   \<Longrightarrow> no_throw A (X >>=E Y)"
+  unfolding no_throw_def
+  using hoare_validE_cases seqE by blast
+
+lemma no_throw_bindE_simple:
+  "\<lbrakk> no_throw \<top> L; \<And>x. no_throw \<top> (R x) \<rbrakk> \<Longrightarrow> no_throw \<top> (L >>=E R)"
+  using hoareE_TrueI no_throw_bindE by blast
+
+lemma no_throw_handleE_simple:
+  "\<lbrakk> \<And>x. no_throw \<top> L \<or> no_throw \<top> (R x) \<rbrakk> \<Longrightarrow> no_throw \<top> (L <handle> R)"
+  by (fastforce simp: no_throw_def' handleE_def handleE'_def validE_def valid_def bind_def return_def
+                      mres_def image_def
+                split: sum.splits tmres.splits)
+
+lemma no_throw_handle2:
+  "\<lbrakk> \<And>a. no_throw Y (B a); \<lbrace> X \<rbrace> A \<lbrace> \<lambda>_ _. True \<rbrace>,\<lbrace> \<lambda>_. Y \<rbrace> \<rbrakk> \<Longrightarrow> no_throw X (A <handle2> B)"
+  by (fastforce simp: no_throw_def' handleE'_def validE_def valid_def bind_def return_def mres_def
+                      image_def
+                split: sum.splits tmres.splits)
+
+lemma no_throw_handle:
+  "\<lbrakk> \<And>a. no_throw Y (B a); \<lbrace> X \<rbrace> A \<lbrace> \<lambda>_ _. True \<rbrace>,\<lbrace> \<lambda>_. Y \<rbrace> \<rbrakk> \<Longrightarrow> no_throw X (A <handle> B)"
+  unfolding handleE_def
+  by (rule no_throw_handle2)
+
+lemma no_throw_fail[simp]:
+  "no_throw P fail"
+  by (clarsimp simp: no_throw_def)
+
+lemma handleE'_nothrow_lhs:
+  "no_throw \<top> L \<Longrightarrow> no_throw \<top> (L <handle2> R)"
+  unfolding no_throw_def
+  using handleE'_wp[rotated] by fastforce
+
+lemma handleE'_nothrow_rhs:
+  "\<lbrakk> \<And>x. no_throw \<top> (R x) \<rbrakk> \<Longrightarrow> no_throw \<top> (L <handle2> R)"
+  unfolding no_throw_def
+  by (metis hoareE_TrueI no_throw_def no_throw_handle2)
+
+lemma handleE_nothrow_lhs:
+  "no_throw \<top> L \<Longrightarrow> no_throw \<top> (L <handle> R)"
+  by (metis handleE'_nothrow_lhs handleE_def)
+
+lemma handleE_nothrow_rhs:
+  "\<lbrakk> \<And>x. no_throw \<top> (R x) \<rbrakk> \<Longrightarrow> no_throw \<top> (L <handle> R)"
+  by (metis no_throw_handleE_simple)
+
+lemma condition_nothrow:
+  "\<lbrakk> no_throw \<top> L; no_throw \<top> R \<rbrakk> \<Longrightarrow> no_throw \<top> (condition C L R)"
+  by (clarsimp simp: condition_def no_throw_def validE_def2)
+
+lemma no_throw_Inr:
+  "\<lbrakk> x \<in> mres (A s); no_throw P A; P s \<rbrakk> \<Longrightarrow> \<exists>y. fst x = Inr y"
+  by (fastforce simp: no_throw_def' split: sum.splits)
+
 end

lib/Monads/trace/Trace_RG.thy

@@ -69,7 +69,7 @@ abbreviation(input)
   "\<bottom>\<bottom>\<bottom> \<equiv> \<lambda>_ _ _. False"
 
 text \<open>
-  Test whether the enironment steps in @{text tr} satisfy the rely condition @{text R},
+  Test whether the environment steps in @{text tr} satisfy the rely condition @{text R},
   assuming that @{text s0s} was the initial state before the first step in the trace.\<close>
 definition rely_cond :: "'s rg_pred \<Rightarrow> 's \<Rightarrow> (tmid \<times> 's) list \<Rightarrow> bool" where
   "rely_cond R s0s tr = (\<forall>(ident, s0, s) \<in> trace_steps (rev tr) s0s. ident = Env \<longrightarrow> R s0 s)"
@@ -235,6 +235,14 @@ lemma last_st_tr_Cons[simp]:
   "last_st_tr (x # xs) s = snd x"
   by (simp add: last_st_tr_def)
 
+lemma no_trace_last_st_tr:
+  "\<lbrakk>no_trace f; (tr, res) \<in> f s\<rbrakk> \<Longrightarrow> last_st_tr tr s0 = s0"
+  by (fastforce simp: no_trace_def)
+
+lemma no_trace_rely_cond:
+  "\<lbrakk>no_trace f; (tr, res) \<in> f s\<rbrakk> \<Longrightarrow> rely_cond R s0 tr"
+  by (fastforce simp: no_trace_def rely_cond_def)
+
 lemma bind_twp[wp_split]:
   "\<lbrakk> \<And>r. \<lbrace>Q' r\<rbrace>,\<lbrace>R\<rbrace> g r \<lbrace>G\<rbrace>,\<lbrace>Q\<rbrace>; \<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>G\<rbrace>,\<lbrace>Q'\<rbrace> \<rbrakk>
    \<Longrightarrow> \<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f >>= (\<lambda>r. g r) \<lbrace>G\<rbrace>,\<lbrace>Q\<rbrace>"
@@ -532,11 +540,19 @@ lemma no_trace_prefix_closed:
   "no_trace f \<Longrightarrow> prefix_closed f"
   by (auto simp add: prefix_closed_def dest: no_trace_emp)
 
+lemma validI_valid_no_trace_eq:
+  "no_trace f \<Longrightarrow> \<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>G\<rbrace>,\<lbrace>Q\<rbrace> = (\<forall>s0. \<lbrace>P s0\<rbrace> f \<lbrace>\<lambda>v. Q v s0\<rbrace>)"
+  apply (rule iffI)
+   apply (fastforce simp: rely_def validI_def valid_def mres_def
+                    dest: no_trace_emp)
+  apply (clarsimp simp: rely_def validI_def valid_def mres_def no_trace_prefix_closed)
+  apply (fastforce simp: eq_snd_iff dest: no_trace_emp)
+  done
+
 lemma valid_validI_wp[wp_comb]:
   "\<lbrakk>no_trace f; \<And>s0. \<lbrace>P s0\<rbrace> f \<lbrace>\<lambda>v. Q v s0 \<rbrace>\<rbrakk>
    \<Longrightarrow> \<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>G\<rbrace>,\<lbrace>Q\<rbrace>"
-  by (fastforce simp: rely_def validI_def valid_def mres_def no_trace_prefix_closed dest: no_trace_emp
-    elim: image_eqI[rotated])
+  by (clarsimp simp: validI_valid_no_trace_eq)
 
 
 lemma env_steps_twp[wp]:
@@ -725,4 +741,21 @@ lemma repeat_prefix_closed[intro!]:
   apply (auto intro: prefix_closed_bind)
   done
 
+lemma rely_cond_True[simp]:
+  "rely_cond \<top>\<top> s0 tr = True"
+  by (clarsimp simp: rely_cond_def)
+
+lemma guar_cond_True[simp]:
+  "guar_cond \<top>\<top> s0 tr = True"
+  by (clarsimp simp: guar_cond_def)
+
+lemma validI_valid_wp:
+  "\<lbrakk>\<lbrace>P\<rbrace>,\<lbrace>\<top>\<top>\<rbrace> f \<lbrace>G\<rbrace>,\<lbrace>\<lambda>rv _ s. Q rv s\<rbrace>\<rbrakk>
+   \<Longrightarrow> \<lbrace>P s0\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (auto simp: rely_def validI_def valid_def mres_def)
+
+lemma validI_triv_valid_eq:
+  "prefix_closed f \<Longrightarrow> \<lbrace>P\<rbrace>,\<lbrace>\<top>\<top>\<rbrace> f \<lbrace>\<top>\<top>\<rbrace>,\<lbrace>\<lambda>rv _ s. Q rv s\<rbrace> = (\<forall>s0. \<lbrace>\<lambda>s. P s0 s\<rbrace> f \<lbrace>Q\<rbrace>)"
+  by (fastforce simp: rely_def validI_def valid_def mres_def image_def)
+
 end

lib/Monads/trace/Trace_Sat.thy

@@ -17,7 +17,8 @@ text \<open>
   The dual to validity: an existential instead of a universal quantifier for the post condition.
   In refinement, it is often sufficient to know that there is one state that satisfies a condition.\<close>
 definition exs_valid ::
-  "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) tmonad \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<exists>\<lbrace>_\<rbrace>") where
+  "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) tmonad \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
+  ("\<lbrace>_\<rbrace> _ \<exists>\<lbrace>_\<rbrace>") where
   "\<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (\<exists>(rv, s') \<in> mres (f s). Q rv s')"
 
 text \<open>The above for the exception monad\<close>
@@ -26,6 +27,30 @@ definition ex_exs_validE ::
   ("\<lbrace>_\<rbrace> _ \<exists>\<lbrace>_\<rbrace>, \<lbrace>_\<rbrace>") where
   "\<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace> \<equiv> \<lbrace>P\<rbrace> f  \<exists>\<lbrace>\<lambda>rv. case rv of Inl e \<Rightarrow> E e | Inr v \<Rightarrow> Q v\<rbrace>"
 
+text \<open>
+  Seen as predicate transformer, @{const exs_valid} is the so-called conjugate wp in the literature,
+  i.e. with
+  @{term "wp f Q \<equiv> \<lambda>s. mres (f s) \<subseteq> {(rv,s). Q rv s}"} and
+  @{term "cwp f Q \<equiv> not (wp f (not Q))"}, we get
+  @{prop "valid P f Q = (\<forall>s. P s \<longrightarrow> wp f Q s)"} and
+  @{prop "exs_valid P f Q = (\<forall>s. P s \<longrightarrow> cwp f Q s)"}.
+
+  See also "Predicate Calculus and Program Semantics" by E. W. Dijkstra and C. S. Scholten.\<close>
+experiment
+begin
+
+definition
+  "wp f Q \<equiv> \<lambda>s. mres (f s) \<subseteq> {(rv,s). Q rv s}"
+
+definition
+  "cwp f Q \<equiv> not (wp f (not Q))"
+
+lemma
+  "exs_valid P f Q = (\<forall>s. P s \<longrightarrow> cwp f Q s)"
+  unfolding exs_valid_def cwp_def wp_def by auto
+
+end
+
 
 subsection \<open>Set up for @{method wp}\<close>
 
@@ -62,7 +87,7 @@ lemma exs_valid_assume_pre:
 lemma exs_valid_bind[wp_split]:
   "\<lbrakk> \<And>rv. \<lbrace>B rv\<rbrace> g rv \<exists>\<lbrace>C\<rbrace>; \<lbrace>A\<rbrace> f \<exists>\<lbrace>B\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> f >>= (\<lambda>rv. g rv) \<exists>\<lbrace>C\<rbrace>"
   apply atomize
-  apply (clarsimp simp: exs_valid_def bind_def2 mres_def)
+  apply (clarsimp simp: exs_valid_def bind_def' mres_def)
   apply (drule spec, drule(1) mp, clarsimp)
   apply (drule spec2, drule(1) mp, clarsimp)
   apply (simp add: image_def bex_Un)
@@ -76,9 +101,11 @@ lemma exs_valid_return[wp]:
 
 lemma exs_valid_select[wp]:
   "\<lbrace>\<lambda>s. \<exists>r \<in> S. Q r s\<rbrace> select S \<exists>\<lbrace>Q\<rbrace>"
-  apply (clarsimp simp: exs_valid_def select_def mres_def)
-  apply (auto simp add: image_def)
-  done
+  by (auto simp: exs_valid_def select_def mres_def image_def)
+
+lemma exs_valid_alt[wp]:
+  "\<lbrakk> \<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace>; \<lbrace>P'\<rbrace> g \<exists>\<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P or P'\<rbrace> f \<sqinter> g \<exists>\<lbrace>Q\<rbrace>"
+  by (fastforce simp: exs_valid_def alternative_def mres_def image_def)
 
 lemma exs_valid_get[wp]:
   "\<lbrace>\<lambda>s. Q s s\<rbrace> get \<exists>\<lbrace> Q \<rbrace>"
@@ -97,10 +124,15 @@ lemma exs_valid_fail[wp]:
   unfolding fail_def exs_valid_def
   by simp
 
+lemma exs_valid_assert[wp]:
+  "\<lbrace>\<lambda>s. Q () s \<and> G\<rbrace> assert G \<exists>\<lbrace>Q\<rbrace>"
+  unfolding assert_def
+  by (wpsimp | rule conjI)+
+
 lemma exs_valid_state_assert[wp]:
-    "\<lbrace> \<lambda>s. Q () s \<and> G s \<rbrace> state_assert G \<exists>\<lbrace> Q \<rbrace>"
-  by (clarsimp simp: state_assert_def exs_valid_def get_def
-           assert_def bind_def2 return_def mres_def)
+  "\<lbrace>\<lambda>s. Q () s \<and> G s\<rbrace> state_assert G \<exists>\<lbrace>Q\<rbrace>"
+  unfolding state_assert_def
+  by wp
 
 lemmas exs_valid_guard = exs_valid_state_assert
 
@@ -108,4 +140,16 @@ lemma exs_valid_condition[wp]:
   "\<lbrakk> \<lbrace>P\<rbrace> l \<exists>\<lbrace>Q\<rbrace>; \<lbrace>P'\<rbrace> r \<exists>\<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. (C s \<and> P s) \<or> (\<not> C s \<and> P' s)\<rbrace> condition C l r \<exists>\<lbrace>Q\<rbrace>"
   by (clarsimp simp: condition_def exs_valid_def split: sum.splits)
 
+lemma gets_exs_valid:
+  "\<lbrace>(=) s\<rbrace> gets f \<exists>\<lbrace>\<lambda>r. (=) s\<rbrace>"
+  by (rule exs_valid_gets)
+
+lemma exs_valid_assert_opt[wp]:
+  "\<lbrace>\<lambda>s. \<exists>x. G = Some x \<and> Q x s\<rbrace> assert_opt G \<exists>\<lbrace>Q\<rbrace>"
+  by (clarsimp simp: assert_opt_def exs_valid_def return_def mres_def)
+
+lemma gets_the_exs_valid[wp]:
+  "\<lbrace>\<lambda>s. \<exists>x. h s = Some x \<and> Q x s\<rbrace> gets_the h \<exists>\<lbrace>Q\<rbrace>"
+  by (wpsimp simp: gets_the_def)
+
 end

lib/Monads/trace/Trace_Strengthen_Setup.thy

@@ -41,6 +41,42 @@ lemma strengthen_validI[strg]:
    \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace>,\<lbrace>G\<rbrace> f \<lbrace>R\<rbrace>,\<lbrace>Q\<rbrace>) (\<lbrace>P\<rbrace>,\<lbrace>G\<rbrace> f \<lbrace>R\<rbrace>,\<lbrace>Q'\<rbrace>)"
   by (cases F, auto elim: validI_strengthen_post)
 
+lemma wpfix_strengthen_hoare:
+  "\<lbrakk>\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s); \<And>r s. st F (\<longrightarrow>) (Q r s) (Q' r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>) (\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>)"
+  by (cases F, auto elim: hoare_chain)
+
+lemma wpfix_strengthen_validE_R_cong:
+  "\<lbrakk>\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s); \<And>r s. st F (\<longrightarrow>) (Q r s) (Q' r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, -) (\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>, -)"
+  by (cases F, auto elim: hoare_chainE simp: validE_R_def)
+
+lemma wpfix_strengthen_validE_cong:
+  "\<lbrakk>\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s); \<And>r s. st F (\<longrightarrow>) (Q r s) (R r s);
+    \<And>r s. st F (\<longrightarrow>) (S r s) (T r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>S\<rbrace>) (\<lbrace>P'\<rbrace> f \<lbrace>R\<rbrace>, \<lbrace>T\<rbrace>)"
+  by (cases F, auto elim: hoare_chainE)
+
+lemma wpfix_strengthen_validE_E_cong:
+  "\<lbrakk>\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s); \<And>r s. st F (\<longrightarrow>) (S r s) (T r s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (\<lbrace>P\<rbrace> f -, \<lbrace>S\<rbrace>) (\<lbrace>P'\<rbrace> f -, \<lbrace>T\<rbrace>)"
+  by (cases F, auto elim: hoare_chainE simp: validE_E_def)
+
+lemma wpfix_no_fail_cong:
+  "\<lbrakk>\<And>s. st (\<not> F) (\<longrightarrow>) (P s) (P' s)\<rbrakk>
+   \<Longrightarrow> st F (\<longrightarrow>) (no_fail P f) (no_fail P' f)"
+  by (cases F, auto elim: no_fail_pre)
+
+lemmas nondet_wpfix_strgs =
+    wpfix_strengthen_validE_R_cong
+    wpfix_strengthen_validE_E_cong
+    wpfix_strengthen_validE_cong
+    wpfix_strengthen_hoare
+    wpfix_no_fail_cong
+
 end
 
+lemmas nondet_wpfix_strgs[wp_fix_strgs]
+    = strengthen_implementation.nondet_wpfix_strgs
+
 end

lib/Monads/trace/Trace_Total.thy

@@ -20,7 +20,8 @@ text \<open>
   is often similar. The following definitions allow such reasoning to take place.\<close>
 
 definition validNF ::
-  "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) tmonad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!") where
+  "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) tmonad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
+  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!") where
   "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>! \<equiv> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<and> no_fail P f"
 
 lemma validNF_alt_def:
@@ -49,19 +50,44 @@ wpc_setup "\<lambda>m. \<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace>!" wpc_helper_va
 
 subsection \<open>Basic @{const validNF} theorems\<close>
 
+lemma validNF_make_schematic_post:
+  "(\<forall>s0. \<lbrace> \<lambda>s. P s0 s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 rv s \<rbrace>!) \<Longrightarrow>
+   \<lbrace> \<lambda>s. \<exists>s0. P s0 s \<and> (\<forall>rv s'. Q s0 rv s' \<longrightarrow> Q' rv s') \<rbrace> f \<lbrace> Q' \<rbrace>!"
+  by (fastforce simp: valid_def validNF_def no_fail_def mres_def image_def
+               split: prod.splits)
+
+lemma validE_NF_make_schematic_post:
+  "(\<forall>s0. \<lbrace> \<lambda>s. P s0 s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 rv s \<rbrace>, \<lbrace> \<lambda>rv s. E s0 rv s \<rbrace>!) \<Longrightarrow>
+   \<lbrace> \<lambda>s. \<exists>s0. P s0 s \<and> (\<forall>rv s'. Q s0 rv s' \<longrightarrow> Q' rv s')
+        \<and> (\<forall>rv s'. E s0 rv s' \<longrightarrow> E' rv s') \<rbrace> f \<lbrace> Q' \<rbrace>, \<lbrace> E' \<rbrace>!"
+  by (fastforce simp: validE_NF_def validE_def valid_def no_fail_def mres_def image_def
+               split: prod.splits sum.splits)
+
+lemma validNF_conjD1:
+  "\<lbrace> P \<rbrace> f \<lbrace> \<lambda>rv s. Q rv s \<and> Q' rv s \<rbrace>! \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>!"
+  by (fastforce simp: validNF_def valid_def no_fail_def)
+
+lemma validNF_conjD2:
+  "\<lbrace> P \<rbrace> f \<lbrace> \<lambda>rv s. Q rv s \<and> Q' rv s \<rbrace>! \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q' \<rbrace>!"
+  by (fastforce simp: validNF_def valid_def no_fail_def)
+
 lemma validNF[intro?]: (* FIXME lib: should be validNFI *)
   "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>; no_fail P f \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>!"
   by (clarsimp simp: validNF_def)
 
+lemma validNFE:
+  "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>!; \<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>; no_fail P f \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
+  by (clarsimp simp: validNF_def)
+
 lemma validNF_valid:
   "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
-  by (clarsimp simp: validNF_def)
+  by (erule validNFE)
 
 lemma validNF_no_fail:
   "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>! \<rbrakk> \<Longrightarrow> no_fail P f"
-  by (clarsimp simp: validNF_def)
+  by (erule validNFE)
 
-lemma snd_validNF:
+lemma validNF_not_failed:
   "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>!; P s \<rbrakk> \<Longrightarrow> Failed \<notin> snd ` (f s)"
   by (clarsimp simp: validNF_def no_fail_def)
 
@@ -163,60 +189,45 @@ subsection "validNF compound rules"
 
 lemma validNF_state_assert[wp]:
   "\<lbrace> \<lambda>s. P () s \<and> G s  \<rbrace> state_assert G \<lbrace> P \<rbrace>!"
-  apply (rule validNF)
-  apply wpsimp
-  apply (clarsimp simp: no_fail_def state_assert_def
-              bind_def2 assert_def return_def get_def)
-  done
+  by (rule validNF; wpsimp)
 
 lemma validNF_modify[wp]:
   "\<lbrace> \<lambda>s. P () (f s) \<rbrace> modify f \<lbrace> P \<rbrace>!"
-  apply (clarsimp simp: modify_def)
-  apply wp
-  done
+  by (rule validNF; wpsimp)
 
 lemma validNF_gets[wp]:
   "\<lbrace>\<lambda>s. P (f s) s\<rbrace> gets f \<lbrace>P\<rbrace>!"
-  apply (clarsimp simp: gets_def)
-  apply wp
-  done
+  by (rule validNF; wpsimp)
 
 lemma validNF_condition[wp]:
   "\<lbrakk> \<lbrace> Q \<rbrace> A \<lbrace>P\<rbrace>!; \<lbrace> R \<rbrace> B \<lbrace>P\<rbrace>!\<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. if C s then Q s else R s\<rbrace> condition C A B \<lbrace>P\<rbrace>!"
-  apply rule
-   apply (drule validNF_valid)+
-   apply (erule (1) condition_wp)
-  apply (drule validNF_no_fail)+
-  apply (clarsimp simp: no_fail_def condition_def)
-  done
+  by (erule validNFE)+
+     (rule validNF; wpsimp wp: no_fail_condition)
 
 lemma validNF_assert[wp]:
-    "\<lbrace> (\<lambda>s. P) and (R ()) \<rbrace> assert P \<lbrace> R \<rbrace>!"
-  apply (rule validNF)
-   apply (clarsimp simp: valid_def in_return)
-  apply (clarsimp simp: no_fail_def return_def)
-  done
+  "\<lbrace> (\<lambda>s. P) and (R ()) \<rbrace> assert P \<lbrace> R \<rbrace>!"
+  by (rule validNF; wpsimp)
 
 lemma validNF_false_pre:
   "\<lbrace> \<lambda>_. False \<rbrace> P \<lbrace> Q \<rbrace>!"
-  by (clarsimp simp: validNF_def no_fail_def)
+  by (rule validNF; wpsimp)
 
 lemma validNF_chain:
    "\<lbrakk>\<lbrace>P'\<rbrace> a \<lbrace>R'\<rbrace>!; \<And>s. P s \<Longrightarrow> P' s; \<And>r s. R' r s \<Longrightarrow> R r s\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>!"
   by (fastforce simp: validNF_def valid_def no_fail_def Ball_def)
 
 lemma validNF_case_prod[wp]:
-  "\<lbrakk> \<And>x y. validNF (P x y) (B x y) Q \<rbrakk> \<Longrightarrow> validNF (case_prod P v) (case_prod (\<lambda>x y. B x y) v) Q"
+  "\<lbrakk>\<And>x y. \<lbrace>P x y\<rbrace> B x y \<lbrace>Q\<rbrace>!\<rbrakk> \<Longrightarrow> \<lbrace>case v of (x, y) \<Rightarrow> P x y\<rbrace> case v of (x, y) \<Rightarrow> B x y \<lbrace>Q\<rbrace>!"
   by (metis prod.exhaust split_conv)
 
 lemma validE_NF_case_prod[wp]:
-    "\<lbrakk> \<And>a b. \<lbrace>P a b\<rbrace> f a b \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>! \<rbrakk> \<Longrightarrow>
-          \<lbrace>case x of (a, b) \<Rightarrow> P a b\<rbrace> case x of (a, b) \<Rightarrow> f a b \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>!"
-  apply (clarsimp simp: validE_NF_alt_def)
-  apply (erule validNF_case_prod)
-  done
+  "\<lbrakk> \<And>a b. \<lbrace>P a b\<rbrace> f a b \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>! \<rbrakk> \<Longrightarrow>
+   \<lbrace>case x of (a, b) \<Rightarrow> P a b\<rbrace> case x of (a, b) \<Rightarrow> f a b \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>!"
+  unfolding validE_NF_alt_def
+  by (erule validNF_case_prod)
 
-lemma no_fail_is_validNF_True: "no_fail P s = (\<lbrace> P \<rbrace> s \<lbrace> \<lambda>_ _. True \<rbrace>!)"
+lemma no_fail_is_validNF_True:
+  "no_fail P s = (\<lbrace> P \<rbrace> s \<lbrace> \<lambda>_ _. True \<rbrace>!)"
   by (clarsimp simp: no_fail_def validNF_def valid_def)
 
 
@@ -226,13 +237,17 @@ lemma validE_NF[intro?]:
   "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>; no_fail P f \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>!"
   by (clarsimp simp: validE_NF_def)
 
+lemma validE_NFE:
+  "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>!; \<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>; no_fail P f \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
+  by (clarsimp simp: validE_NF_def)
+
 lemma validE_NF_valid:
   "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>"
-  by (clarsimp simp: validE_NF_def)
+  by (rule validE_NFE)
 
 lemma validE_NF_no_fail:
   "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>! \<rbrakk> \<Longrightarrow> no_fail P f"
-  by (clarsimp simp: validE_NF_def)
+  by (rule validE_NFE)
 
 lemma validE_NF_weaken_pre[wp_pre]:
   "\<lbrakk>\<lbrace>Q\<rbrace> a \<lbrace>R\<rbrace>,\<lbrace>E\<rbrace>!; \<And>s. P s \<Longrightarrow> Q s\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>,\<lbrace>E\<rbrace>!"
@@ -263,21 +278,13 @@ lemma validE_NF_chain:
 
 lemma validE_NF_bind_wp[wp]:
   "\<lbrakk>\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>!; \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>, \<lbrace>E\<rbrace>!\<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> f >>=E (\<lambda>x. g x) \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>!"
-  apply (unfold validE_NF_alt_def bindE_def)
-  apply (rule validNF_bind [rotated])
-   apply assumption
-  apply (clarsimp simp: lift_def throwError_def split: sum.splits)
-    apply wpsimp
-  done
+  by (blast intro: validE_NF hoare_vcg_seqE no_fail_pre no_fail_bindE validE_validE_R validE_weaken
+            elim!: validE_NFE)
 
 lemma validNF_catch[wp]:
   "\<lbrakk>\<And>x. \<lbrace>E x\<rbrace> handler x \<lbrace>Q\<rbrace>!; \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>!\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f <catch> (\<lambda>x. handler x) \<lbrace>Q\<rbrace>!"
-  apply (unfold validE_NF_alt_def catch_def)
-  apply (rule validNF_bind [rotated])
-   apply assumption
-  apply (clarsimp simp: lift_def throwError_def split: sum.splits)
-  apply wp
-  done
+  unfolding validE_NF_alt_def catch_def lift_def throwError_def
+  by (clarsimp simp: validNF_return split: sum.splits elim!: validNF_bind[rotated])
 
 lemma validNF_throwError[wp]:
   "\<lbrace>E e\<rbrace> throwError e \<lbrace>P\<rbrace>, \<lbrace>E\<rbrace>!"
@@ -285,20 +292,21 @@ lemma validNF_throwError[wp]:
 
 lemma validNF_returnOk[wp]:
   "\<lbrace>P e\<rbrace> returnOk e \<lbrace>P\<rbrace>, \<lbrace>E\<rbrace>!"
- by (clarsimp simp: validE_NF_alt_def returnOk_def) wpsimp
+  by (clarsimp simp: validE_NF_alt_def returnOk_def) wpsimp
 
 lemma validNF_whenE[wp]:
   "(P \<Longrightarrow> \<lbrace>Q\<rbrace> f \<lbrace>R\<rbrace>, \<lbrace>E\<rbrace>!) \<Longrightarrow> \<lbrace>if P then Q else R ()\<rbrace> whenE P f \<lbrace>R\<rbrace>, \<lbrace>E\<rbrace>!"
-  unfolding whenE_def by clarsimp wp
+  unfolding whenE_def by wpsimp
 
 lemma validNF_nobindE[wp]:
   "\<lbrakk> \<lbrace>B\<rbrace> g \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>!; \<lbrace>A\<rbrace> f \<lbrace>\<lambda>r s. B s\<rbrace>,\<lbrace>E\<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> doE f; g odE \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>!"
-  by clarsimp wp
+  by wpsimp
 
 text \<open>
   Set up triple rules for @{term validE_NF} so that we can use @{method wp} combinator rules.\<close>
 definition validE_NF_property ::
-  "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> ('s, 'c+'a) tmonad \<Rightarrow> bool" where
+  "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> ('s, 'c+'a) tmonad \<Rightarrow> bool"
+  where
   "validE_NF_property Q E s b \<equiv>
    Failed \<notin> snd ` (b s) \<and> (\<forall>(r', s') \<in> mres (b s). case r' of Inl x \<Rightarrow> E x s' | Inr x \<Rightarrow> Q x s')"
 
@@ -336,11 +344,10 @@ lemma validE_NF_handleE[wp]:
 lemma validE_NF_condition[wp]:
   "\<lbrakk> \<lbrace> Q \<rbrace> A \<lbrace>P\<rbrace>,\<lbrace> E \<rbrace>!; \<lbrace> R \<rbrace> B \<lbrace>P\<rbrace>,\<lbrace> E \<rbrace>!\<rbrakk> \<Longrightarrow>
    \<lbrace>\<lambda>s. if C s then Q s else R s\<rbrace> condition C A B \<lbrace>P\<rbrace>,\<lbrace> E \<rbrace>!"
-  apply rule
-   apply (drule validE_NF_valid)+
-   apply wp
-  apply (drule validE_NF_no_fail)+
-  apply (clarsimp simp: no_fail_def condition_def)
-  done
+  by (erule validE_NFE)+ (wpsimp wp: no_fail_condition validE_NF)
+
+lemma hoare_assume_preNF:
+  "(\<And>s. P s \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>!) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>!"
+  by (simp add: validNF_alt_def)
 
 end

lib/Monads/trace/Trace_VCG.thy

@@ -34,15 +34,15 @@ text \<open>
   @{term "assert P"} does not require us to prove that @{term P} holds, but
   rather allows us to assume @{term P}! Proving non-failure is done via a
   separate predicate and calculus (see Trace_No_Fail).\<close>
-definition valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) tmonad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
+definition valid ::
+  "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) tmonad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
   ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>") where
   "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (\<forall>(r,s') \<in> mres (f s). Q r s')"
 
 text \<open>
   We often reason about invariant predicates. The following provides shorthand syntax
   that avoids repeating potentially long predicates.\<close>
-abbreviation (input) invariant ::
-  "('s,'a) tmonad \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool" ("_ \<lbrace>_\<rbrace>" [59,0] 60) where
+abbreviation (input) invariant :: "('s,'a) tmonad \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool" ("_ \<lbrace>_\<rbrace>" [59,0] 60) where
   "invariant f P \<equiv> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"
 
 text \<open>
@@ -71,6 +71,18 @@ definition validE_E :: (* FIXME lib: this should be an abbreviation *)
   "('s \<Rightarrow> bool) \<Rightarrow>  ('s, 'e + 'a) tmonad \<Rightarrow> ('e \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace>/ _ /-, \<lbrace>_\<rbrace>") where
   "\<lbrace>P\<rbrace> f -,\<lbrace>Q\<rbrace> \<equiv> validE P f (\<lambda>x y. True) Q"
 
+(* These lemmas are useful to apply to rules to convert valid rules into a format suitable for wp. *)
+lemma valid_make_schematic_post:
+  "(\<forall>s0. \<lbrace> \<lambda>s. P s0 s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 rv s \<rbrace>) \<Longrightarrow>
+   \<lbrace> \<lambda>s. \<exists>s0. P s0 s \<and> (\<forall>rv s'. Q s0 rv s' \<longrightarrow> Q' rv s') \<rbrace> f \<lbrace> Q' \<rbrace>"
+  by (auto simp add: valid_def split: prod.splits)
+
+lemma validE_make_schematic_post:
+  "(\<forall>s0. \<lbrace> \<lambda>s. P s0 s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 rv s \<rbrace>, \<lbrace> \<lambda>rv s. E s0 rv s \<rbrace>) \<Longrightarrow>
+   \<lbrace> \<lambda>s. \<exists>s0. P s0 s \<and> (\<forall>rv s'. Q s0 rv s' \<longrightarrow> Q' rv s')
+        \<and> (\<forall>rv s'. E s0 rv s' \<longrightarrow> E' rv s') \<rbrace> f \<lbrace> Q' \<rbrace>, \<lbrace> E' \<rbrace>"
+  by (auto simp add: validE_def valid_def split: prod.splits sum.splits)
+
 
 section \<open>Lemmas\<close>
 
@@ -127,22 +139,11 @@ wpc_setup "\<lambda>m. \<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace>,-" wpc_helper_v
 wpc_setup "\<lambda>m. \<lbrace>P\<rbrace> m -,\<lbrace>E\<rbrace>" wpc_helper_validR_R
 
 
-subsection "Simplification Rules for Lifted And/Or"
-
-lemma bipred_disj_op_eq[simp]:
-  "reflp R \<Longrightarrow> ((=) or R) = R"
-  apply (rule ext, rule ext)
-  apply (auto simp: reflp_def)
-  done
-
-lemma bipred_le_true[simp]: "R \<le> \<top>\<top>"
-  by clarsimp
-
 subsection "Hoare Logic Rules"
 
 lemma bind_wp[wp_split]:
   "\<lbrakk> \<And>r. \<lbrace>Q' r\<rbrace> g r \<lbrace>Q\<rbrace>; \<lbrace>P\<rbrace>f \<lbrace>Q'\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f >>= (\<lambda>rv. g rv) \<lbrace>Q\<rbrace>"
-  by (fastforce simp: valid_def bind_def2 mres_def intro: image_eqI[rotated])
+  by (fastforce simp: valid_def bind_def' mres_def intro: image_eqI[rotated])
 
 lemma seq':
   "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>; \<forall>x. P x \<longrightarrow> \<lbrace>C\<rbrace> g x \<lbrace>D\<rbrace>; \<forall>x s. B x s \<longrightarrow> P x \<and> C s \<rbrakk> \<Longrightarrow>
@@ -166,7 +167,9 @@ lemma seq_ext':
    \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>C\<rbrace>"
   by (metis bind_wp)
 
-lemmas seq_ext = bind_wp[rotated]
+lemma seq_ext:
+  "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>; \<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>C\<rbrace>"
+  by (rule bind_wp)
 
 lemma seqE':
   "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>,\<lbrace>E\<rbrace>; \<forall>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow>
@@ -305,6 +308,12 @@ lemma use_valid:
 
 lemmas post_by_hoare = use_valid[rotated]
 
+lemma use_valid_inv:
+  assumes step: "(r, s') \<in> mres (f s)"
+  assumes pres: "\<And>N. \<lbrace>\<lambda>s. N (P s) \<and> E s\<rbrace> f \<lbrace>\<lambda>rv s. N (P s)\<rbrace>"
+  shows "E s \<Longrightarrow> P s = P s'"
+  using use_valid[where f=f, OF step pres[where N="\<lambda>p. p = P s"]] by simp
+
 lemma use_validE_norm:
   "\<lbrakk> (Inr r', s') \<in> mres (B s); \<lbrace>P\<rbrace> B \<lbrace>Q\<rbrace>,\<lbrace> E \<rbrace>; P s \<rbrakk> \<Longrightarrow> Q r' s'"
   unfolding validE_def valid_def by force
@@ -328,6 +337,22 @@ lemma hoare_gen_asm:
   "(P \<Longrightarrow> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>P' and K P\<rbrace> f \<lbrace>Q\<rbrace>"
   by (fastforce simp add: valid_def)
 
+lemmas hoare_gen_asm_single = hoare_gen_asm[where P'="\<top>", simplified pred_conj_def simp_thms]
+
+lemma hoare_gen_asm_lk:
+  "(P \<Longrightarrow> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>K P and P'\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (fastforce simp add: valid_def)
+
+\<comment> \<open>Useful for forward reasoning, when P is known.
+    The first version allows weakening the precondition.\<close>
+lemma hoare_gen_asm_spec':
+  "\<lbrakk> \<And>s. P s \<Longrightarrow> S \<and> R s; S \<Longrightarrow> \<lbrace>R\<rbrace> f \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (fastforce simp: valid_def)
+
+lemma hoare_gen_asm_spec:
+  "\<lbrakk> \<And>s. P s \<Longrightarrow> S; S \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
+  by (rule hoare_gen_asm_spec'[where S=S and R=P]) simp
+
 lemma hoare_conjI:
   "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>P\<rbrace> f \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. Q r s \<and> R r s\<rbrace>"
   unfolding valid_def by blast
@@ -374,10 +399,24 @@ lemma hoare_case_option_wp:
   \<Longrightarrow> \<lbrace>case_option P P' v\<rbrace> f v \<lbrace>\<lambda>rv. case v of None \<Rightarrow> Q rv | Some x \<Rightarrow> Q' x rv\<rbrace>"
   by (cases v) auto
 
+lemma hoare_case_option_wp2:
+  "\<lbrakk> \<lbrace>P\<rbrace> f None \<lbrace>Q\<rbrace>; \<And>x.  \<lbrace>P' x\<rbrace> f (Some x) \<lbrace>Q' x\<rbrace> \<rbrakk>
+   \<Longrightarrow> \<lbrace>case_option P P' v\<rbrace> f v \<lbrace>\<lambda>rv s. case v of None \<Rightarrow> Q rv s | Some x \<Rightarrow> Q' x rv s\<rbrace>"
+  by (cases v) auto
+
+(* Might be useful for forward reasoning, when P is known. *)
+lemma hoare_when_cases:
+  "\<lbrakk>\<And>s. \<lbrakk>\<not>B; P s\<rbrakk> \<Longrightarrow> Q s; B \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. Q\<rbrace>\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> when B f \<lbrace>\<lambda>_. Q\<rbrace>"
+  by (cases B; simp add: valid_def return_def mres_def)
+
 lemma hoare_vcg_prop:
   "\<lbrace>\<lambda>s. P\<rbrace> f \<lbrace>\<lambda>rv s. P\<rbrace>"
   by (simp add: valid_def)
 
+lemma validE_eq_valid:
+  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv. Q\<rbrace>,\<lbrace>\<lambda>rv. Q\<rbrace> = \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv. Q\<rbrace>"
+  by (simp add: validE_def)
+
 
 subsection \<open>@{const valid} and @{const validE}, @{const validE_R}, @{const validE_E}\<close>
 
@@ -428,7 +467,7 @@ lemma in_image_constant:
 
 lemma hoare_liftM_subst:
   "\<lbrace>P\<rbrace> liftM f m \<lbrace>Q\<rbrace> = \<lbrace>P\<rbrace> m \<lbrace>Q \<circ> f\<rbrace>"
-  apply (simp add: liftM_def bind_def2 return_def split_def)
+  apply (simp add: liftM_def bind_def' return_def split_def)
   apply (simp add: valid_def Ball_def mres_def image_Un)
   apply (simp add: image_image in_image_constant)
   apply force
@@ -489,7 +528,7 @@ lemma hoare_seq_ext_nobindE:
   "\<lbrakk> \<lbrace>B\<rbrace> g \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>; \<lbrace>A\<rbrace> f \<lbrace>\<lambda>_. B\<rbrace>, \<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> doE f; g odE \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>"
   by (erule seqE) (clarsimp simp: validE_def)
 
-lemmas hoare_seq_ext_skip' = hoare_seq_ext[where Q'=Q and Q=Q for Q]
+lemmas hoare_seq_ext_skip' = hoare_seq_ext[where B=C and C=C for C]
 
 lemma hoare_chain:
   "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<And>s. R s \<Longrightarrow> P s; \<And>rv s. Q rv s \<Longrightarrow> S rv s \<rbrakk> \<Longrightarrow> \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace>"
@@ -507,11 +546,23 @@ lemma hoare_vcg_conj_lift:
   unfolding valid_def
   by fastforce
 
+\<comment> \<open>A variant which works nicely with subgoals that do not contain schematics\<close>
+lemmas hoare_vcg_conj_lift_pre_fix = hoare_vcg_conj_lift[where P=R and P'=R for R, simplified]
+
 lemma hoare_vcg_conj_liftE1:
   "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-; \<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>,\<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P and P'\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>,\<lbrace>E\<rbrace>"
   unfolding valid_def validE_R_def validE_def
   by (fastforce simp: split_def split: sum.splits)
 
+lemma hoare_vcg_conj_liftE_weaker:
+  assumes "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>"
+  assumes "\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>, \<lbrace>E\<rbrace>"
+  shows "\<lbrace>\<lambda>s. P s \<and> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>, \<lbrace>E\<rbrace>"
+  apply (rule hoare_pre)
+   apply (fastforce intro: assms hoare_vcg_conj_liftE1 validE_validE_R hoare_post_impErr)
+  apply simp
+  done
+
 lemma hoare_vcg_disj_lift:
   "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P s \<or> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<or> Q' rv s\<rbrace>"
   unfolding valid_def
@@ -535,10 +586,51 @@ lemma hoare_vcg_all_lift_R:
   "(\<And>x. \<lbrace>P x\<rbrace> f \<lbrace>Q x\<rbrace>, -) \<Longrightarrow> \<lbrace>\<lambda>s. \<forall>x. P x s\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x. Q x rv s\<rbrace>, -"
   by (rule hoare_vcg_const_Ball_lift_R[where S=UNIV, simplified])
 
+lemma hoare_vcg_imp_lift:
+  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P' s \<or> Q' s\<rbrace> f \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>"
+  by (simp only: imp_conv_disj) (rule hoare_vcg_disj_lift)
+
+lemma hoare_vcg_imp_lift':
+  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<not> P' s \<longrightarrow> Q' s\<rbrace> f \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>"
+  by (wpsimp wp: hoare_vcg_imp_lift)
+
+lemma hoare_vcg_imp_liftE:
+  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>, \<lbrace>A\<rbrace>; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>A\<rbrace> \<rbrakk>
+   \<Longrightarrow> \<lbrace>\<lambda>s. \<not> P' s \<longrightarrow> Q' s\<rbrace> f \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>, \<lbrace>A\<rbrace>"
+  by (fastforce simp: validE_def valid_def split: sum.splits)
+
+lemma hoare_vcg_imp_lift_R:
+  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>, -; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace>, - \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P' s \<or> Q' s\<rbrace> f \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>, -"
+  by (auto simp add: valid_def validE_R_def validE_def split_def split: sum.splits)
+
+lemma hoare_vcg_imp_lift_R':
+  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>, -; \<lbrace>Q'\<rbrace> f \<lbrace>Q\<rbrace>, - \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<not>P' s \<longrightarrow> Q' s\<rbrace> f \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>, -"
+  by (auto simp add: valid_def validE_R_def validE_def split_def split: sum.splits)
+
+lemma hoare_vcg_imp_conj_lift[wp_comb]:
+  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<longrightarrow> Q' rv s\<rbrace>; \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. (Q rv s \<longrightarrow> Q'' rv s) \<and> Q''' rv s\<rbrace> \<rbrakk> \<Longrightarrow>
+   \<lbrace>P and P'\<rbrace> f \<lbrace>\<lambda>rv s. (Q rv s \<longrightarrow> Q' rv s \<and> Q'' rv s) \<and> Q''' rv s\<rbrace>"
+  by (auto simp: valid_def)
+
+lemmas hoare_vcg_imp_conj_lift'[wp_unsafe] = hoare_vcg_imp_conj_lift[where Q'''="\<top>\<top>", simplified]
+
+lemma hoare_absorb_imp:
+  "\<lbrace> P \<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> R rv s\<rbrace> \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<longrightarrow> R rv s\<rbrace>"
+  by (erule hoare_post_imp[rotated], blast)
+
+lemma hoare_weaken_imp:
+  "\<lbrakk> \<And>rv s. Q rv s \<Longrightarrow> Q' rv s ;  \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q' rv s \<longrightarrow> R rv s\<rbrace> \<rbrakk>
+    \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<longrightarrow> R rv s\<rbrace>"
+  by (clarsimp simp: valid_def split_def)
+
 lemma hoare_vcg_const_imp_lift:
   "\<lbrakk> P \<Longrightarrow> \<lbrace>Q\<rbrace> m \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> m \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>"
   by (cases P, simp_all add: hoare_vcg_prop)
 
+lemma hoare_vcg_const_imp_lift_E:
+  "(P \<Longrightarrow> \<lbrace>Q\<rbrace> f -, \<lbrace>R\<rbrace>) \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> f -, \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>"
+  by (fastforce simp: validE_E_def validE_def valid_def split_def split: sum.splits)
+
 lemma hoare_vcg_const_imp_lift_R:
   "(P \<Longrightarrow> \<lbrace>Q\<rbrace> m \<lbrace>R\<rbrace>,-) \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> m \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>,-"
   by (fastforce simp: validE_R_def validE_def valid_def split_def split: sum.splits)
@@ -547,6 +639,16 @@ lemma hoare_weak_lift_imp:
   "\<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> P' s\<rbrace> f \<lbrace>\<lambda>rv s. P \<longrightarrow> Q rv s\<rbrace>"
   by (auto simp add: valid_def split_def)
 
+lemma hoare_weak_lift_impE:
+  "\<lbrace>Q\<rbrace> m \<lbrace>R\<rbrace>,\<lbrace>E\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> m \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>,\<lbrace>\<lambda>rv s. P \<longrightarrow> E rv s\<rbrace>"
+  by (cases P; simp add: validE_def hoare_vcg_prop)
+
+lemma hoare_weak_lift_imp_R:
+  "\<lbrace>Q\<rbrace> m \<lbrace>R\<rbrace>,- \<Longrightarrow> \<lbrace>\<lambda>s. P \<longrightarrow> Q s\<rbrace> m \<lbrace>\<lambda>rv s. P \<longrightarrow> R rv s\<rbrace>,-"
+  by (cases P, simp_all)
+
+lemmas hoare_vcg_weaken_imp = hoare_weaken_imp  (* FIXME lib: eliminate *)
+
 lemma hoare_vcg_ex_lift:
   "\<lbrakk> \<And>x. \<lbrace>P x\<rbrace> f \<lbrace>Q x\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<exists>x. P x s\<rbrace> f \<lbrace>\<lambda>rv s. \<exists>x. Q x rv s\<rbrace>"
   by (clarsimp simp: valid_def, blast)
@@ -555,6 +657,17 @@ lemma hoare_vcg_ex_lift_R1:
   "(\<And>x. \<lbrace>P x\<rbrace> f \<lbrace>Q\<rbrace>, -) \<Longrightarrow> \<lbrace>\<lambda>s. \<exists>x. P x s\<rbrace> f \<lbrace>Q\<rbrace>, -"
   by (fastforce simp: valid_def validE_R_def validE_def split: sum.splits)
 
+lemma hoare_liftP_ext:
+  assumes "\<And>P x. m \<lbrace>\<lambda>s. P (f s x)\<rbrace>"
+  shows "m \<lbrace>\<lambda>s. P (f s)\<rbrace>"
+  unfolding valid_def
+  apply clarsimp
+  apply (erule subst[rotated, where P=P])
+  apply (rule ext)
+  apply (drule use_valid, rule assms, rule refl)
+  apply simp
+  done
+
 (* for instantiations *)
 lemma hoare_triv:    "\<lbrace>P\<rbrace>f\<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace>f\<lbrace>Q\<rbrace>" .
 lemma hoare_trivE:   "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>" .
@@ -575,15 +688,104 @@ lemma hoare_vcg_R_conj:
   unfolding validE_R_def validE_def
   by (rule hoare_post_imp[OF _ hoare_vcg_conj_lift]; simp split: sum.splits)
 
+lemma hoare_lift_Pf_E_R:
+  "\<lbrakk> \<And>x. \<lbrace>P x\<rbrace> m \<lbrace>\<lambda>_. P x\<rbrace>, -; \<And>P. \<lbrace>\<lambda>s. P (f s)\<rbrace> m \<lbrace>\<lambda>_ s. P (f s)\<rbrace>, - \<rbrakk> \<Longrightarrow>
+   \<lbrace>\<lambda>s. P (f s) s\<rbrace> m \<lbrace>\<lambda>_ s. P (f s) s\<rbrace>, -"
+  by (fastforce simp: validE_R_def validE_def valid_def split: sum.splits)
+
+lemma hoare_lift_Pf_E_E:
+  "\<lbrakk> \<And>x. \<lbrace>P x\<rbrace> m -, \<lbrace>\<lambda>_. P x\<rbrace>; \<And>P. \<lbrace>\<lambda>s. P (f s)\<rbrace> m -, \<lbrace>\<lambda>_ s. P (f s)\<rbrace> \<rbrakk> \<Longrightarrow>
+  \<lbrace>\<lambda>s. P (f s) s\<rbrace> m -, \<lbrace>\<lambda>_ s. P (f s) s\<rbrace>"
+  by (fastforce simp: validE_E_def validE_def valid_def split: sum.splits)
+
+lemma hoare_vcg_const_Ball_lift_E_E:
+ "(\<And>x. x \<in> S \<Longrightarrow> \<lbrace>P x\<rbrace> f -,\<lbrace>Q x\<rbrace>) \<Longrightarrow> \<lbrace>\<lambda>s. \<forall>x \<in> S. P x s\<rbrace> f -,\<lbrace>\<lambda>rv s. \<forall>x \<in> S. Q x rv s\<rbrace>"
+  unfolding validE_E_def validE_def valid_def
+  by (fastforce split: sum.splits)
+
+lemma hoare_vcg_all_liftE_E:
+  "(\<And>x. \<lbrace>P x\<rbrace> f -, \<lbrace>Q x\<rbrace>) \<Longrightarrow> \<lbrace>\<lambda>s. \<forall>x. P x s\<rbrace> f -,\<lbrace>\<lambda>rv s. \<forall>x. Q x rv s\<rbrace>"
+  by (rule hoare_vcg_const_Ball_lift_E_E[where S=UNIV, simplified])
+
+lemma hoare_vcg_imp_liftE_E:
+  "\<lbrakk>\<lbrace>P'\<rbrace> f -, \<lbrace>\<lambda>rv s. \<not> P rv s\<rbrace>; \<lbrace>Q'\<rbrace> f -, \<lbrace>Q\<rbrace>\<rbrakk> \<Longrightarrow>
+   \<lbrace>\<lambda>s. \<not> P' s \<longrightarrow> Q' s\<rbrace> f -, \<lbrace>\<lambda>rv s. P rv s \<longrightarrow> Q rv s\<rbrace>"
+  by (auto simp add: valid_def validE_E_def validE_def split_def split: sum.splits)
+
+lemma hoare_vcg_ex_liftE:
+  "\<lbrakk> \<And>x. \<lbrace>P x\<rbrace> f \<lbrace>Q x\<rbrace>,\<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<exists>x. P x s\<rbrace> f \<lbrace>\<lambda>rv s. \<exists>x. Q x rv s\<rbrace>,\<lbrace>E\<rbrace>"
+  by (fastforce simp: validE_def valid_def split: sum.splits)
+
+lemma hoare_vcg_ex_liftE_E:
+  "\<lbrakk> \<And>x. \<lbrace>P x\<rbrace> f -,\<lbrace>E x\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<exists>x. P x s\<rbrace> f -,\<lbrace>\<lambda>rv s. \<exists>x. E x rv s\<rbrace>"
+  by (fastforce simp: validE_E_def validE_def valid_def split: sum.splits)
+
 lemma hoare_post_imp_R:
   "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>,-; \<And>rv s. Q' rv s \<Longrightarrow> Q rv s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-"
   unfolding validE_R_def
   by (erule hoare_post_impErr)
 
+lemma hoare_post_imp_E:
+  "\<lbrakk> \<lbrace>P\<rbrace> f -,\<lbrace>Q'\<rbrace>; \<And>rv s. Q' rv s \<Longrightarrow> Q rv s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f -,\<lbrace>Q\<rbrace>"
+  unfolding validE_E_def
+  by (rule hoare_post_impErr)
+
 lemma hoare_post_comb_imp_conj:
   "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>"
   by (wpsimp wp: hoare_vcg_conj_lift)
 
+lemma hoare_vcg_if_lift:
+  "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P \<longrightarrow> X rv s) \<and> (\<not>P \<longrightarrow> Y rv s)\<rbrace> \<Longrightarrow>
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. if P then X rv s else Y rv s\<rbrace>"
+
+  "\<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv s. (P \<longrightarrow> X rv s) \<and> (\<not>P \<longrightarrow> Y rv s)\<rbrace> \<Longrightarrow>
+   \<lbrace>R\<rbrace> f \<lbrace>\<lambda>rv. if P then X rv else Y rv\<rbrace>"
+  by (auto simp: valid_def split_def)
+
+lemma hoare_vcg_disj_lift_R:
+  assumes x: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-"
+  assumes y: "\<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>,-"
+  shows      "\<lbrace>\<lambda>s. P s \<or> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<or> Q' rv s\<rbrace>,-"
+  using assms
+  by (fastforce simp: validE_R_def validE_def valid_def split: sum.splits)
+
+lemma hoare_vcg_all_liftE:
+  "\<lbrakk> \<And>x. \<lbrace>P x\<rbrace> f \<lbrace>Q x\<rbrace>,\<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<forall>x. P x s\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x. Q x rv s\<rbrace>,\<lbrace>E\<rbrace>"
+  by (fastforce simp: validE_def valid_def split: sum.splits)
+
+lemma hoare_vcg_const_Ball_liftE:
+  "\<lbrakk> \<And>x. x \<in> S \<Longrightarrow> \<lbrace>P x\<rbrace> f \<lbrace>Q x\<rbrace>,\<lbrace>E\<rbrace>; \<lbrace>\<lambda>s. True\<rbrace> f \<lbrace>\<lambda>r s. True\<rbrace>, \<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<forall>x\<in>S. P x s\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x\<in>S. Q x rv s\<rbrace>,\<lbrace>E\<rbrace>"
+  by (fastforce simp: validE_def valid_def split: sum.splits)
+
+lemma hoare_vcg_split_lift[wp]:
+  "\<lbrace>P\<rbrace> f x y \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> case (x, y) of (a, b) \<Rightarrow> f a b \<lbrace>Q\<rbrace>"
+  by simp
+
+named_theorems hoare_vcg_op_lift
+lemmas [hoare_vcg_op_lift] =
+  hoare_vcg_const_imp_lift
+  hoare_vcg_const_imp_lift_E
+  hoare_vcg_const_imp_lift_R
+  (* leaving out hoare_vcg_conj_lift*, because that is built into wp *)
+  hoare_vcg_disj_lift
+  hoare_vcg_disj_lift_R
+  hoare_vcg_ex_lift
+  hoare_vcg_ex_liftE
+  hoare_vcg_ex_liftE_E
+  hoare_vcg_all_lift
+  hoare_vcg_all_liftE
+  hoare_vcg_all_liftE_E
+  hoare_vcg_all_lift_R
+  hoare_vcg_const_Ball_lift
+  hoare_vcg_const_Ball_lift_R
+  hoare_vcg_const_Ball_lift_E_E
+  hoare_vcg_split_lift
+  hoare_vcg_if_lift
+  hoare_vcg_imp_lift'
+  hoare_vcg_imp_liftE
+  hoare_vcg_imp_lift_R
+  hoare_vcg_imp_liftE_E
+
 
 subsection \<open>Weakest Precondition Rules\<close>
 
@@ -596,8 +798,8 @@ lemma return_wp:
   by(simp add: valid_def return_def mres_def)
 
 lemma get_wp:
-  "\<lbrace>\<lambda>s. Q s s\<rbrace> get \<lbrace>Q\<rbrace>"
-  by (simp add: get_def valid_def mres_def)
+  "\<lbrace>\<lambda>s. P s s\<rbrace> get \<lbrace>P\<rbrace>"
+  by (simp add: valid_def get_def mres_def)
 
 lemma gets_wp:
   "\<lbrace>\<lambda>s. P (f s) s\<rbrace> gets f \<lbrace>P\<rbrace>"
@@ -708,12 +910,9 @@ lemma select_wp:
   by (simp add: select_def valid_def mres_def image_def)
 
 lemma state_select_wp:
-  "\<lbrace> \<lambda>s. \<forall>t. (s, t) \<in> f \<longrightarrow> P () t \<rbrace> state_select f \<lbrace>P\<rbrace>"
-  apply (clarsimp simp: state_select_def assert_def)
-  apply (rule hoare_weaken_pre)
-   apply (wp put_wp select_wp hoare_vcg_if_split return_wp fail_wp get_wp)
-  apply simp
-  done
+  "\<lbrace>\<lambda>s. \<forall>t. (s, t) \<in> f \<longrightarrow> P () t\<rbrace> state_select f \<lbrace>P\<rbrace>"
+  unfolding state_select_def2
+  by (wpsimp wp: put_wp select_wp return_wp get_wp assert_wp)
 
 lemma condition_wp:
   "\<lbrakk> \<lbrace>Q\<rbrace> A \<lbrace>P\<rbrace>;  \<lbrace>R\<rbrace> B \<lbrace>P\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. if C s then Q s else R s\<rbrace> condition C A B \<lbrace>P\<rbrace>"
@@ -740,10 +939,53 @@ lemma whenE_wp:
   "(P \<Longrightarrow> \<lbrace>Q\<rbrace> f \<lbrace>R\<rbrace>, \<lbrace>E\<rbrace>) \<Longrightarrow> \<lbrace>if P then Q else R ()\<rbrace> whenE P f \<lbrace>R\<rbrace>, \<lbrace>E\<rbrace>"
   unfolding whenE_def by clarsimp (wp returnOk_wp)
 
+lemma unlessE_wp:
+  "(\<not> P \<Longrightarrow> \<lbrace>Q\<rbrace> f \<lbrace>R\<rbrace>, \<lbrace>E\<rbrace>) \<Longrightarrow> \<lbrace>if P then R () else Q\<rbrace> unlessE P f \<lbrace>R\<rbrace>, \<lbrace>E\<rbrace>"
+  unfolding unlessE_def
+  by (wpsimp wp: returnOk_wp)
+
+lemma maybeM_wp:
+  "(\<And>x. y = Some x \<Longrightarrow> \<lbrace>P x\<rbrace> m x \<lbrace>Q\<rbrace>) \<Longrightarrow>
+   \<lbrace>\<lambda>s. (\<forall>x. y = Some x \<longrightarrow> P x s) \<and> (y = None \<longrightarrow> Q () s)\<rbrace> maybeM m y \<lbrace>Q\<rbrace>"
+  unfolding maybeM_def by (wpsimp wp: return_wp) auto
+
+lemma notM_wp:
+  "\<lbrace>P\<rbrace> m \<lbrace>\<lambda>c. Q (\<not> c)\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> notM m \<lbrace>Q\<rbrace>"
+  unfolding notM_def by (wpsimp wp: return_wp)
+
+lemma ifM_wp:
+  assumes [wp]: "\<lbrace>Q\<rbrace> f \<lbrace>S\<rbrace>" "\<lbrace>R\<rbrace> g \<lbrace>S\<rbrace>"
+  assumes [wp]: "\<lbrace>A\<rbrace> P \<lbrace>\<lambda>c s. c \<longrightarrow> Q s\<rbrace>" "\<lbrace>B\<rbrace> P \<lbrace>\<lambda>c s. \<not>c \<longrightarrow> R s\<rbrace>"
+  shows "\<lbrace>A and B\<rbrace> ifM P f g \<lbrace>S\<rbrace>"
+  unfolding ifM_def
+  by (wpsimp wp: hoare_vcg_if_split hoare_vcg_conj_lift)
+
+lemma andM_wp:
+  assumes [wp]: "\<lbrace>Q'\<rbrace> B \<lbrace>Q\<rbrace>"
+  assumes [wp]: "\<lbrace>P\<rbrace> A \<lbrace>\<lambda>c s. c \<longrightarrow> Q' s\<rbrace>" "\<lbrace>P'\<rbrace> A \<lbrace>\<lambda>c s. \<not> c \<longrightarrow> Q False s\<rbrace>"
+  shows "\<lbrace>P and P'\<rbrace> andM A B \<lbrace>Q\<rbrace>"
+  unfolding andM_def by (wp ifM_wp return_wp)
+
+lemma orM_wp:
+  assumes [wp]: "\<lbrace>Q'\<rbrace> B \<lbrace>Q\<rbrace>"
+  assumes [wp]: "\<lbrace>P\<rbrace> A \<lbrace>\<lambda>c s. c \<longrightarrow> Q True s\<rbrace>" "\<lbrace>P'\<rbrace> A \<lbrace>\<lambda>c s. \<not> c \<longrightarrow> Q' s\<rbrace>"
+  shows "\<lbrace>P and P'\<rbrace> orM A B \<lbrace>Q\<rbrace>"
+  unfolding orM_def by (wp ifM_wp return_wp)
+
+lemma whenM_wp:
+  assumes [wp]: "\<lbrace>Q\<rbrace> f \<lbrace>S\<rbrace>"
+  assumes [wp]: "\<lbrace>A\<rbrace> P \<lbrace>\<lambda>c s. c \<longrightarrow> Q s\<rbrace>" "\<lbrace>B\<rbrace> P \<lbrace>\<lambda>c s. \<not>c \<longrightarrow> S () s\<rbrace>"
+  shows "\<lbrace>A and B\<rbrace> whenM P f \<lbrace>S\<rbrace>"
+  unfolding whenM_def by (wp ifM_wp return_wp)
+
 lemma hoare_K_bind[wp_split]:
   "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> K_bind f x \<lbrace>Q\<rbrace>"
   by simp
 
+lemma validE_K_bind[wp_split]:
+  "\<lbrace> P \<rbrace> x \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace> \<Longrightarrow> \<lbrace> P \<rbrace> K_bind x f \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace>"
+  by simp
+
 lemma hoare_fun_app_wp:
   "\<lbrace>P\<rbrace> f' x \<lbrace>Q'\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f' $ x \<lbrace>Q'\<rbrace>"
   "\<lbrace>P\<rbrace> f x \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f $ x \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
@@ -771,6 +1013,31 @@ lemma case_option_wpE:
 
 lemmas liftME_E_E_wp[wp_split] = validE_validE_E [OF liftME_wp, simplified, OF validE_E_validE]
 
+lemma assert_opt_wp:
+  "\<lbrace>\<lambda>s. x \<noteq> None \<longrightarrow> Q (the x) s\<rbrace> assert_opt x \<lbrace>Q\<rbrace>"
+  unfolding assert_opt_def
+  by (case_tac x; wpsimp wp: fail_wp return_wp)
+
+lemma gets_the_wp:
+  "\<lbrace>\<lambda>s. (f s \<noteq> None) \<longrightarrow> Q (the (f s)) s\<rbrace> gets_the f \<lbrace>Q\<rbrace>"
+  unfolding gets_the_def
+  by (wp seq_ext gets_wp assert_opt_wp)
+
+lemma gets_the_wp': (* FIXME: should prefer this one in [wp] *)
+  "\<lbrace>\<lambda>s. \<forall>rv. f s = Some rv \<longrightarrow> Q rv s\<rbrace> gets_the f \<lbrace>Q\<rbrace>"
+  unfolding gets_the_def
+  by (wpsimp wp: seq_ext gets_wp assert_opt_wp)
+
+lemma gets_map_wp:
+  "\<lbrace>\<lambda>s. f s p \<noteq> None \<longrightarrow> Q (the (f s p)) s\<rbrace> gets_map f p \<lbrace>Q\<rbrace>"
+  unfolding gets_map_def
+  by (wpsimp wp: seq_ext gets_wp assert_opt_wp)
+
+lemma gets_map_wp':
+  "\<lbrace>\<lambda>s. \<forall>rv. f s p = Some rv \<longrightarrow> Q rv s\<rbrace> gets_map f p \<lbrace>Q\<rbrace>"
+  unfolding gets_map_def
+  by (wpsimp wp: seq_ext gets_wp assert_opt_wp)
+
 (* FIXME: make wp *)
 lemma whenE_throwError_wp:
   "\<lbrace>\<lambda>s. \<not>Q \<longrightarrow> P s\<rbrace> whenE Q (throwError e) \<lbrace>\<lambda>rv. P\<rbrace>, -"
@@ -864,6 +1131,9 @@ lemmas [wp] = hoare_vcg_prop
               failE_wp
               assert_wp
               state_assert_wp
+              assert_opt_wp
+              gets_the_wp
+              gets_map_wp'
               liftE_wp
               alternative_wp
               alternativeE_R_wp
@@ -873,6 +1143,7 @@ lemmas [wp] = hoare_vcg_prop
               state_select_wp
               condition_wp
               conditionE_wp
+              maybeM_wp notM_wp ifM_wp andM_wp orM_wp whenM_wp
 
 lemmas [wp_trip] = valid_is_triple validE_is_triple validE_E_is_triple validE_R_is_triple
 
@@ -965,8 +1236,20 @@ lemmas hoare_wp_pred_conj_elims =
   hoare_elim_pred_conjE2 hoare_elim_pred_conjE_R
 
 
+subsection \<open>Bundles\<close>
+
+bundle no_pre = hoare_pre [wp_pre del]
+
+bundle classic_wp_pre = hoare_pre [wp_pre del]
+    all_classic_wp_combs[wp_comb del] all_classic_wp_combs[wp_comb]
+
+
 text \<open>Miscellaneous lemmas on hoare triples\<close>
 
+lemma hoare_pre_cases:
+  "\<lbrakk> \<lbrace>\<lambda>s. R s \<and> P s\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>\<lambda>s. \<not>R s \<and> P' s\<rbrace> f \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P and P'\<rbrace> f \<lbrace>Q\<rbrace>"
+  unfolding valid_def by fastforce
+
 lemma hoare_vcg_mp:
   "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. Q r s \<longrightarrow> Q' r s\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>"
   by (auto simp: valid_def split_def)
@@ -988,6 +1271,12 @@ lemma hoare_list_case:
    \<lbrace>case xs of [] \<Rightarrow> P1 | y#ys \<Rightarrow> P2 y ys\<rbrace> f (case xs of [] \<Rightarrow> f1 | y#ys \<Rightarrow> f2 y ys) \<lbrace>Q\<rbrace>"
   by (cases xs; simp)
 
+lemmas whenE_wps[wp_split] =
+  whenE_wp whenE_wp[THEN validE_validE_R] whenE_wp[THEN validE_validE_E]
+
+lemmas unlessE_wps[wp_split] =
+  unlessE_wp unlessE_wp[THEN validE_validE_R] unlessE_wp[THEN validE_validE_E]
+
 lemma hoare_use_eq:
   assumes "\<And>P. \<lbrace>\<lambda>s. P (f s)\<rbrace> m \<lbrace>\<lambda>_ s. P (f s)\<rbrace>"
   assumes "\<And>f. \<lbrace>\<lambda>s. P f s\<rbrace> m \<lbrace>\<lambda>_ s. Q f s\<rbrace>"
@@ -1043,12 +1332,58 @@ lemma hoare_drop_impE_E:
 
 lemmas hoare_drop_imps = hoare_drop_imp hoare_drop_impE_R hoare_drop_impE_E
 
+(*This is unsafe, but can be very useful when supplied as a comb rule.*)
+lemma hoare_drop_imp_conj[wp_unsafe]:
+  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>; \<lbrace>P'\<rbrace> f \<lbrace>\<lambda>rv s. (Q rv s \<longrightarrow> Q'' rv s) \<and> Q''' rv s\<rbrace> \<rbrakk> \<Longrightarrow>
+   \<lbrace>P and P'\<rbrace> f \<lbrace>\<lambda>rv s. (Q rv s \<longrightarrow> Q' rv s \<and> Q'' rv s) \<and> Q''' rv s\<rbrace>"
+  by (auto simp: valid_def)
+
+lemmas hoare_drop_imp_conj'[wp_unsafe] = hoare_drop_imp_conj[where Q'''="\<top>\<top>", simplified]
+
 lemmas bindE_E_wp[wp_split] = validE_validE_E[OF hoare_vcg_seqE [OF validE_E_validE]]
 
 lemma True_E_E[wp]:
   "\<lbrace>\<top>\<rbrace> f -,\<lbrace>\<top>\<top>\<rbrace>"
   by (auto simp: validE_E_def validE_def valid_def split: sum.splits)
 
+lemma hoare_vcg_set_pred_lift:
+  assumes "\<And>P x. m \<lbrace> \<lambda>s. P (f x s) \<rbrace>"
+  shows "m \<lbrace> \<lambda>s. P {x. f x s} \<rbrace>"
+  using assms[where P="\<lambda>x . x"] assms[where P=Not] use_valid
+  by (fastforce simp: valid_def elim!: subst[rotated, where P=P])
+
+lemma hoare_vcg_set_pred_lift_mono:
+  assumes f: "\<And>x. m \<lbrace> f x \<rbrace>"
+  assumes mono: "\<And>A B. A \<subseteq> B \<Longrightarrow> P A \<Longrightarrow> P B"
+  shows "m \<lbrace> \<lambda>s. P {x. f x s} \<rbrace>"
+  by (fastforce simp: valid_def elim!: mono[rotated] dest: use_valid[OF _ f])
+
+text \<open>If a function contains an @{term assert}, or equivalent, then it might be
+      possible to strengthen the precondition of an already-proven hoare triple
+      @{text pos}, by additionally proving a side condition @{text neg}, that
+      violating some condition causes failure. The stronger hoare triple produced
+      by this theorem allows the precondition to assume that the condition is
+      satisfied.\<close>
+lemma hoare_strengthen_pre_via_assert_forward:
+  assumes pos: "\<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
+  assumes rel: "\<And>s. S s \<longrightarrow> P s \<or> N s"
+  assumes neg: "\<lbrace> N \<rbrace> f \<lbrace> \<bottom>\<bottom> \<rbrace>"
+  shows "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
+  apply (rule hoare_weaken_pre)
+   apply (rule hoare_strengthen_post)
+    apply (rule hoare_vcg_disj_lift[OF pos neg])
+   by (auto simp: rel)
+
+text \<open>Like @{thm hoare_strengthen_pre_via_assert_forward}, strengthen a precondition
+      by proving a side condition that the negation of that condition would cause
+      failure. This version is intended for backward reasoning. Apply it to a goal to
+      obtain a stronger precondition after proving the side condition.\<close>
+lemma hoare_strengthen_pre_via_assert_backward:
+  assumes neg: "\<lbrace> Not \<circ> E \<rbrace> f \<lbrace> \<bottom>\<bottom> \<rbrace>"
+  assumes pos: "\<lbrace> P and E \<rbrace> f \<lbrace> Q \<rbrace>"
+  shows "\<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
+  by (rule hoare_strengthen_pre_via_assert_forward[OF pos _ neg], simp)
+
 
 subsection \<open>Strongest postcondition rules\<close>
 
@@ -1080,4 +1415,44 @@ lemma hoare_returnOk_sp:
   "\<lbrace>P\<rbrace> returnOk x \<lbrace>\<lambda>rv s. rv = x \<and> P s\<rbrace>, \<lbrace>Q\<rbrace>"
   by (simp add: valid_def validE_def returnOk_def return_def mres_def)
 
+\<comment> \<open>For forward reasoning in Hoare proofs, these lemmas allow us to step over the
+    left-hand-side of monadic bind, while keeping the same precondition.\<close>
+
+named_theorems forward_inv_step_rules
+
+lemmas hoare_forward_inv_step_nobind[forward_inv_step_rules] =
+  hoare_seq_ext_nobind[where B=A and A=A for A, rotated]
+
+lemmas hoare_seq_ext_skip[forward_inv_step_rules] =
+  hoare_seq_ext[where B="\<lambda>_. A" and A=A for A, rotated]
+
+lemmas hoare_forward_inv_step_nobindE_valid[forward_inv_step_rules] =
+  hoare_seq_ext_nobindE[where B=A and A=A and E="\<lambda>_. C" and C="\<lambda>_. C" for A C,
+                        simplified validE_eq_valid, rotated]
+
+lemmas hoare_forward_inv_step_valid[forward_inv_step_rules] =
+  hoare_vcg_seqE[where B="\<lambda>_. A" and A=A and E="\<lambda>_. C" and C="\<lambda>_. C" for A C,
+                 simplified validE_eq_valid, rotated]
+
+lemmas hoare_forward_inv_step_nobindE[forward_inv_step_rules] =
+  hoare_seq_ext_nobindE[where B=A and A=A for A, rotated]
+
+lemmas hoare_seq_ext_skipE[forward_inv_step_rules] =
+  hoare_vcg_seqE[where B="\<lambda>_. A" and A=A for A, rotated]
+
+lemmas hoare_forward_inv_step_nobindE_validE_E[forward_inv_step_rules] =
+  hoare_forward_inv_step_nobindE[where C="\<top>\<top>", simplified validE_E_def[symmetric]]
+
+lemmas hoare_forward_inv_step_validE_E[forward_inv_step_rules] =
+  hoare_seq_ext_skipE[where C="\<top>\<top>", simplified validE_E_def[symmetric]]
+
+lemmas hoare_forward_inv_step_nobindE_validE_R[forward_inv_step_rules] =
+  hoare_forward_inv_step_nobindE[where E="\<top>\<top>", simplified validE_R_def[symmetric]]
+
+lemmas hoare_forward_inv_step_validE_R[forward_inv_step_rules] =
+  hoare_seq_ext_skipE[where E="\<top>\<top>", simplified validE_R_def[symmetric]]
+
+method forward_inv_step uses wp simp =
+  rule forward_inv_step_rules, solves \<open>wpsimp wp: wp simp: simp\<close>
+
 end

lib/Monads/wp/WPBang.thy

@@ -20,7 +20,7 @@ ML \<open>
 structure WP_Safe = struct
 
 fun check_has_frees_tac Ps (_ : int) thm = let
-    val fs = Term.add_frees (Thm.prop_of thm) [] |> filter (member (=) Ps)
+    val fs = Term.add_frees (Thm.prop_of thm) [] |> filter (member (op =) Ps)
   in if null fs then Seq.empty else Seq.single thm end
 
 fun wp_bang wp_safe_rules ctxt = let

lib/Qualify.thy

@@ -110,7 +110,7 @@ val _ =
           Toplevel.theory (set_global_qualify {name = str, target_name = case target of SOME (nm, _) => nm | _ => str})));
 
 fun syntax_alias global_alias local_alias b name =
-  Local_Theory.declaration {syntax = true, pervasive = true} (fn phi =>
+  Local_Theory.declaration {syntax = true, pos = Position.none, pervasive = true} (fn phi =>
     let val b' = Morphism.binding phi b
     in Context.mapping (global_alias b' name) (local_alias b' name) end);
 

lib/Requalify.thy

@@ -49,7 +49,7 @@ in
 end
 
 fun syntax_alias global_alias local_alias b (name : string) =
-  Local_Theory.declaration {syntax = false, pervasive = true} (fn phi =>
+  Local_Theory.declaration {syntax = false, pos = Position.none, pervasive = true} (fn phi =>
     let val b' = Morphism.binding phi b
     in Context.mapping (global_alias b' name) (local_alias b' name) end);
 

lib/Word_Lib/Bitwise.thy

@@ -365,7 +365,7 @@ lemma upt_eq_list_intros:
   by (simp_all add: upt_eq_Cons_conv)
 
 
-subsection \<open>Tactic definition\<close>
+text \<open>Tactic definition\<close>
 
 lemma if_bool_simps:
   "If p True y = (p \<or> y) \<and> If p False y = (\<not> p \<and> y) \<and>

lib/Word_Lib/More_Word.thy

@@ -1872,14 +1872,14 @@ lemma nth_0: "\<not> bit (0 :: 'a::len word) n"
 lemma nth_minus1: "bit (-1 :: 'a::len word) n \<longleftrightarrow> n < LENGTH('a)"
   by transfer simp
 
-lemma nth_ucast:
+lemma nth_ucast_weak:
   "bit (ucast w::'a::len word) n = (bit w n \<and> n < LENGTH('a))"
   by transfer (simp add: bit_take_bit_iff ac_simps)
 
-lemma drop_bit_numeral_bit0_1 [simp]:
-  \<open>drop_bit (Suc 0) (numeral k) =
-    (word_of_int (drop_bit (Suc 0) (take_bit LENGTH('a) (numeral k))) :: 'a::len word)\<close>
-  by (metis Word_eq_word_of_int drop_bit_word.abs_eq of_int_numeral)
+lemma nth_ucast:
+  "bit (ucast (w::'a::len word)::'b::len word) n =
+   (bit w n \<and> n < min LENGTH('a) LENGTH('b))"
+  by (auto simp: not_le nth_ucast_weak dest: bit_imp_le_length)
 
 lemma nth_mask:
   \<open>bit (mask n :: 'a::len word) i \<longleftrightarrow> i < n \<and> i < size (mask n :: 'a word)\<close>

lib/Word_Lib/More_Word_Operations.thy

@@ -302,13 +302,21 @@ lemma alignUp_not_aligned_eq:
   and     sz: "n < LENGTH('a)"
   shows   "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
 proof -
+  from \<open>n < LENGTH('a)\<close> have \<open>(2::int) ^ n < 2 ^ LENGTH('a)\<close>
+    by simp
+  with take_bit_int_less_exp [of n]
+    have *: \<open>take_bit n k < 2 ^ LENGTH('a)\<close> for k :: int
+    by (rule less_trans)
   have anz: "a mod 2 ^ n \<noteq> 0"
     by (rule not_aligned_mod_nz) fact+
-
-  then have um: "unat (a mod 2 ^ n - 1) div 2 ^ n = 0" using sz
-    by (meson div_eq_0_iff le_m1_iff_lt measure_unat order_less_trans
-              unat_less_power word_less_sub_le word_mod_less_divisor)
-
+  then have um: "unat (a mod 2 ^ n - 1) div 2 ^ n = 0"
+    apply (transfer fixing: n) using sz
+    apply (simp flip: take_bit_eq_mod add: div_eq_0_iff)
+    apply (subst take_bit_int_eq_self)
+    using *
+     apply (auto simp add: diff_less_eq intro: less_imp_le)
+    apply (simp add: less_le)
+    done
   have "a + 2 ^ n - 1 = (a div 2 ^ n) * 2 ^ n + (a mod 2 ^ n) + 2 ^ n - 1"
     by (simp add: word_mod_div_equality)
   also have "\<dots> = (a mod 2 ^ n - 1) + (a div 2 ^ n + 1) * 2 ^ n"

lib/Word_Lib/Signed_Division_Word.thy

@@ -10,6 +10,12 @@ theory Signed_Division_Word
   imports "HOL-Library.Signed_Division" "HOL-Library.Word"
 begin
 
+text \<open>
+  The following specification of division follows ISO C99, which in turn adopted the typical
+  behavior of hardware modern in the beginning of the 1990ies.
+  The underlying integer division is named ``T-division'' in \cite{leijen01}.
+\<close>
+
 instantiation word :: (len) signed_division
 begin
 

lib/Word_Lib/Word_Lemmas.thy

@@ -153,8 +153,8 @@ lemma sshiftr_n1: "-1 >>> n = -1"
 
 lemma nth_sshiftr:
   "bit (w >>> m) n = (n < size w \<and> (if n + m \<ge> size w then bit w (size w - 1) else bit w (n + m)))"
-  apply (clarsimp simp add: bit_simps word_size ac_simps not_less)
-  apply (metis add.commute bit_imp_le_length bit_shiftr_word_iff le_diff_conv not_le)
+  apply (auto simp add: bit_simps word_size ac_simps not_less)
+  apply (meson bit_imp_le_length bit_shiftr_word_iff leD)
   done
 
 lemma sshiftr_numeral:
@@ -508,8 +508,9 @@ next
       also have \<open>\<dots> \<longleftrightarrow> unat x < 2 ^ n div 2 ^ y\<close>
         using * by (simp add: less_le)
       finally show ?thesis
-      using that \<open>x \<noteq> 0\<close> by (simp flip: push_bit_eq_mult drop_bit_eq_div
-        add: shiftr_def shiftl_def unat_drop_bit_eq word_less_iff_unsigned [where ?'a = nat])
+        using that \<open>x \<noteq> 0\<close>
+        by (simp flip: push_bit_eq_mult drop_bit_eq_div
+                 add: shiftr_def shiftl_def unat_drop_bit_eq word_less_iff_unsigned [where ?'a = nat])
     qed
   qed
 qed
@@ -716,7 +717,8 @@ lemma word_and_notzeroD:
 lemma shiftr_le_0:
   "unat (w::'a::len word) < 2 ^ n \<Longrightarrow> w >> n = (0::'a::len word)"
   by (auto simp add: take_bit_word_eq_self_iff word_less_nat_alt shiftr_def
-           simp flip: take_bit_eq_self_iff_drop_bit_eq_0 intro: ccontr)
+           simp flip: take_bit_eq_self_iff_drop_bit_eq_0
+           intro: ccontr)
 
 lemma of_nat_shiftl:
   "(of_nat x << n) = (of_nat (x * 2 ^ n) :: ('a::len) word)"
@@ -1466,9 +1468,9 @@ lemma mask_shift_sum:
   "\<lbrakk> a \<ge> b; unat n = unat (p AND mask b) \<rbrakk>
    \<Longrightarrow> (p AND NOT(mask a)) + (p AND mask a >> b) * (1 << b) + n = (p :: 'a :: len word)"
   apply (simp add: shiftl_def shiftr_def flip: push_bit_eq_mult take_bit_eq_mask word_unat_eq_iff)
-  apply (subst disjunctive_add, clarsimp simp add: bit_simps)+
+  apply (subst disjunctive_add, fastforce simp: bit_simps)+
   apply (rule bit_word_eqI)
-  apply (auto simp add: bit_simps)
+  apply (fastforce simp: bit_simps)[1]
   done
 
 lemma is_up_compose:
@@ -1583,10 +1585,7 @@ next
     apply (rule impI)
     apply (subst bit_eq_iff)
     apply (simp add: bit_take_bit_iff bit_signed_take_bit_iff min_def)
-    apply (auto simp add: Suc_le_eq)
-    using less_imp_le_nat apply blast
-    using less_imp_le_nat apply blast
-    done
+    by (auto simp add: Suc_le_eq) (meson dual_order.strict_iff_not)+
 qed
 
 lemma scast_ucast_mask_compare:
@@ -1820,11 +1819,7 @@ proof (rule classical)
      apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
      apply (clarsimp simp: word_size)
     apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
-    apply auto
-    apply (cases \<open>size a\<close>)
-     apply simp_all
-    apply (smt (z3) One_nat_def diff_Suc_1 signed_word_eqI sint_int_min sint_range_size wsst_TYs(3))
-    done
+    by (smt (verit, best) One_nat_def signed_word_eqI sint_greater_eq sint_int_min sint_less wsst_TYs(3))
 
   have result_range_simple: "(sint a sdiv sint b \<in> ?range) \<Longrightarrow> ?thesis"
     apply (insert sdiv_int_range [where a="sint a" and b="sint b"])

lib/Word_Lib/Word_Lemmas_Internal.thy

@@ -738,4 +738,11 @@ lemma aligned_mask_le_mask_minus:
   by (metis and_mask_less' is_aligned_after_mask is_aligned_neg_mask_eq'
            mask_2pm1 mask_sub neg_mask_mono_le word_less_sub_le)
 
+lemma shiftr_anti_mono:
+  "m \<le> n \<Longrightarrow> w >> n \<le> w >> m" for w :: "'a::len word"
+  apply transfer
+  apply (simp add: take_bit_drop_bit)
+  apply (simp add: drop_bit_eq_div zdiv_mono2)
+  done
+
 end

lib/Word_Lib/Word_Lib_Sumo.thy

@@ -131,10 +131,4 @@ notation (input)
 
 lemmas cast_simps = cast_simps ucast_down_bl
 
-(* shadows the slightly weaker Word.nth_ucast *)
-lemma nth_ucast:
-  "(ucast (w::'a::len word)::'b::len word) !! n =
-   (w !! n \<and> n < min LENGTH('a) LENGTH('b))"
-  by (auto simp: not_le dest: bit_imp_le_length)
-
 end

lib/clib/CCorresLemmas.thy

@@ -518,7 +518,7 @@ lemma lift_t_super_update:
   and    eu: "export_uinfo s = typ_uinfo_t TYPE('b)"
   and    lp: "lift_t g (h, d) p = Some v'"
   shows "lift_t g (heap_update (Ptr &(p\<rightarrow>f)) v h, d)
-  = lift_t g (h, d)(p \<mapsto> field_update (field_desc s) (to_bytes_p v) v')"
+         = (lift_t g (h, d)) (p \<mapsto> field_update (field_desc s) (to_bytes_p v) v')"
   using fl eu lp
   apply -
   apply (rule trans [OF lift_t_super_field_update super_field_update_lookup])

lib/concurrency/Triv_Refinement.thy

@@ -23,7 +23,7 @@ lemma triv_refinement_mono_bind:
   "(\<forall>x. triv_refinement (b x) (d x)) \<Longrightarrow> triv_refinement (a >>= b) (a >>= d)"
    apply (simp add: triv_refinement_def bind_def)
    apply (intro allI UN_mono; simp)
-  apply (simp only: triv_refinement_def bind_def2 split_def)
+  apply (simp only: triv_refinement_def bind_def' split_def)
   apply (intro Un_mono allI order_refl UN_mono image_mono)
   apply simp
   done

lib/defs.ML

@@ -29,7 +29,7 @@ val opt_unchecked_overloaded =
       @{keyword "overloaded"} >> K (false, true)) --| @{keyword ")"})) (false, false);
 
 fun syntax_alias global_alias local_alias b name =
-  Local_Theory.declaration {syntax = true, pervasive = true} (fn phi =>
+  Local_Theory.declaration {syntax = true, pos = Position.none, pervasive = true} (fn phi =>
     let val b' = Morphism.binding phi b
     in Context.mapping (global_alias b' name) (local_alias b' name) end);
 

misc/jedit/macros/goto-error.bsh

@@ -25,8 +25,8 @@ import isabelle.jedit.*;
 msg(s) { Macros.message(view, s); }
 
 // isabelle setup
-model = Document_Model.get(textArea.getBuffer());
-snapshot = model.get().snapshot();
+model = Document_Model.get_model(textArea.getBuffer());
+snapshot = Document_Model.snapshot(model.get());
 
 class FirstError {
     public int first_error_pos = -1;

proof/access-control/ARM/ArchAccess.thy

@@ -196,10 +196,10 @@ lemmas integrity_asids_kh_upds =
 declare integrity_asids_def[simp]
 
 lemma integrity_asids_kh_upds':
-  "integrity_asids aag subjects x a (s\<lparr>kheap := kheap s(p \<mapsto> CNode sz cs)\<rparr>) s"
-  "integrity_asids aag subjects x a (s\<lparr>kheap := kheap s(p \<mapsto> TCB tcb)\<rparr>) s"
-  "integrity_asids aag subjects x a (s\<lparr>kheap := kheap s(p \<mapsto> Endpoint ep)\<rparr>) s"
-  "integrity_asids aag subjects x a (s\<lparr>kheap := kheap s(p \<mapsto> Notification ntfn)\<rparr>) s"
+  "integrity_asids aag subjects x a (s\<lparr>kheap := (kheap s)(p \<mapsto> CNode sz cs)\<rparr>) s"
+  "integrity_asids aag subjects x a (s\<lparr>kheap := (kheap s)(p \<mapsto> TCB tcb)\<rparr>) s"
+  "integrity_asids aag subjects x a (s\<lparr>kheap := (kheap s)(p \<mapsto> Endpoint ep)\<rparr>) s"
+  "integrity_asids aag subjects x a (s\<lparr>kheap := (kheap s)(p \<mapsto> Notification ntfn)\<rparr>) s"
   by auto
 
 lemma integrity_asids_kh_update:

proof/access-control/ARM/ArchAccess_AC.thy

@@ -91,7 +91,7 @@ lemma integrity_asids_refl[Access_AC_assms, simp]:
 
 lemma integrity_asids_update_autarch[Access_AC_assms]:
   "\<lbrakk> \<forall>x a. integrity_asids aag subjects x a st s; is_subject aag ptr \<rbrakk>
-     \<Longrightarrow> \<forall>x a. integrity_asids aag subjects x a st (s\<lparr>kheap := kheap s(ptr \<mapsto> obj)\<rparr>)"
+     \<Longrightarrow> \<forall>x a. integrity_asids aag subjects x a st (s\<lparr>kheap := (kheap s)(ptr \<mapsto> obj)\<rparr>)"
   by simp
 
 end

proof/access-control/ARM/ArchArch_AC.thy

@@ -549,7 +549,7 @@ lemma perform_asid_control_invocation_respects:
   apply (rule hoare_pre)
    apply (wpc, simp)
    apply (wpsimp wp: set_cap_integrity_autarch cap_insert_integrity_autarch
-                     retype_region_integrity[where sz=12] static_imp_wp)
+                     retype_region_integrity[where sz=12] hoare_weak_lift_imp)
   apply (clarsimp simp: authorised_asid_control_inv_def
                         ptr_range_def page_bits_def add.commute
                         range_cover_def obj_bits_api_def default_arch_object_def
@@ -576,12 +576,12 @@ lemma perform_asid_control_invocation_pas_refined [wp]:
    \<lbrace>\<lambda>_. pas_refined aag\<rbrace>"
   apply (simp add: perform_asid_control_invocation_def)
   apply (rule hoare_pre)
-   apply (wp cap_insert_pas_refined' static_imp_wp
+   apply (wp cap_insert_pas_refined' hoare_weak_lift_imp
           | strengthen pas_refined_set_asid_strg
           | wpc
           | simp add: delete_objects_def2 fun_upd_def[symmetric])+
       apply (wp retype_region_pas_refined'[where sz=pageBits]
-                hoare_vcg_ex_lift hoare_vcg_all_lift static_imp_wp hoare_wp_combs hoare_drop_imp
+                hoare_vcg_ex_lift hoare_vcg_all_lift hoare_weak_lift_imp hoare_wp_combs hoare_drop_imp
                 retype_region_invs_extras(1)[where sz = pageBits]
                 retype_region_invs_extras(4)[where sz = pageBits]
                 retype_region_invs_extras(6)[where sz = pageBits]
@@ -591,7 +591,7 @@ lemma perform_asid_control_invocation_pas_refined [wp]:
                 max_index_upd_invs_simple max_index_upd_caps_overlap_reserved
                 hoare_vcg_ex_lift set_cap_cte_wp_at hoare_vcg_disj_lift set_free_index_valid_pspace
                 set_cap_descendants_range_in set_cap_no_overlap get_cap_wp set_cap_caps_no_overlap
-                hoare_vcg_all_lift static_imp_wp retype_region_invs_extras
+                hoare_vcg_all_lift hoare_weak_lift_imp retype_region_invs_extras
                 set_cap_pas_refined_not_transferable
              | simp add: do_machine_op_def split_def cte_wp_at_neg2 region_in_kernel_window_def)+
    apply (rename_tac frame slot parent base cap)

proof/access-control/ARM/ArchCNode_AC.thy

@@ -78,14 +78,14 @@ crunches prepare_thread_delete, arch_finalise_cap
   (wp: crunch_wps hoare_vcg_if_lift2 simp: unless_def)
 
 lemma state_vrefs_tcb_upd[CNode_AC_assms]:
-  "tcb_at t s \<Longrightarrow> state_vrefs (s\<lparr>kheap := kheap s(t \<mapsto> TCB tcb)\<rparr>) = state_vrefs s"
+  "tcb_at t s \<Longrightarrow> state_vrefs (s\<lparr>kheap := (kheap s)(t \<mapsto> TCB tcb)\<rparr>) = state_vrefs s"
   apply (rule ext)
   apply (auto simp: state_vrefs_def vs_refs_no_global_pts_def tcb_at_def dest!: get_tcb_SomeD)
   done
 
 lemma state_vrefs_simple_type_upd[CNode_AC_assms]:
   "\<lbrakk> ko_at ko ptr s; is_simple_type ko; a_type ko = a_type (f val) \<rbrakk>
-     \<Longrightarrow> state_vrefs (s\<lparr>kheap := kheap s(ptr \<mapsto> f val)\<rparr>) = state_vrefs s"
+     \<Longrightarrow> state_vrefs (s\<lparr>kheap := (kheap s)(ptr \<mapsto> f val)\<rparr>) = state_vrefs s"
   apply (rule ext)
   apply (auto simp: state_vrefs_def vs_refs_no_global_pts_def obj_at_def partial_inv_def a_type_def
              split: kernel_object.splits arch_kernel_obj.splits if_splits)

proof/access-control/ARM/ArchDomainSepInv.thy

@@ -49,7 +49,7 @@ lemma perform_page_invocation_domain_sep_inv:
    \<lbrace>\<lambda>_. domain_sep_inv irqs st\<rbrace>"
   apply (rule hoare_pre)
    apply (wp mapM_wp[OF _ subset_refl] set_cap_domain_sep_inv mapM_x_wp[OF _ subset_refl]
-             perform_page_invocation_domain_sep_inv_get_cap_helper static_imp_wp
+             perform_page_invocation_domain_sep_inv_get_cap_helper hoare_weak_lift_imp
           | simp add: perform_page_invocation_def o_def | wpc)+
   apply (clarsimp simp: valid_page_inv_def)
   apply (case_tac xa, simp_all add: domain_sep_inv_cap_def is_pg_cap_def)
@@ -79,7 +79,7 @@ lemma perform_asid_control_invocation_domain_sep_inv:
   unfolding perform_asid_control_invocation_def
   apply (rule hoare_pre)
   apply (wp modify_wp cap_insert_domain_sep_inv' set_cap_domain_sep_inv
-            get_cap_domain_sep_inv_cap[where st=st] static_imp_wp
+            get_cap_domain_sep_inv_cap[where st=st] hoare_weak_lift_imp
          | wpc | simp )+
   done
 

proof/access-control/ARM/ArchFinalise_AC.thy

@@ -93,7 +93,7 @@ proof (induct rule: cap_revoke.induct[where ?a1.0=s])
 qed
 
 lemma finalise_cap_caps_of_state_nullinv[Finalise_AC_assms]:
-  "\<lbrace>\<lambda>s. P (caps_of_state s) \<and> (\<forall>p. P (caps_of_state s(p \<mapsto> NullCap)))\<rbrace>
+  "\<lbrace>\<lambda>s. P (caps_of_state s) \<and> (\<forall>p. P ((caps_of_state s)(p \<mapsto> NullCap)))\<rbrace>
    finalise_cap cap final
    \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
   by (cases cap;

proof/access-control/ARM/ArchIpc_AC.thy

@@ -175,7 +175,7 @@ lemma handle_arch_fault_reply_respects[Ipc_AC_assms]:
 lemma auth_ipc_buffers_kheap_update[Ipc_AC_assms]:
   "\<lbrakk> x \<in> auth_ipc_buffers st thread; kheap st thread = Some (TCB tcb);
      kheap s thread = Some (TCB tcb'); tcb_ipcframe tcb = tcb_ipcframe tcb' \<rbrakk>
-     \<Longrightarrow> x \<in> auth_ipc_buffers (s\<lparr>kheap := kheap s(thread \<mapsto> TCB tcb)\<rparr>) thread"
+     \<Longrightarrow> x \<in> auth_ipc_buffers (s\<lparr>kheap := (kheap s)(thread \<mapsto> TCB tcb)\<rparr>) thread"
   by (clarsimp simp: auth_ipc_buffers_member_def get_tcb_def caps_of_state_tcb)
 
 lemma auth_ipc_buffers_machine_state_update[Ipc_AC_assms, simp]:

proof/access-control/ARM/ArchTcb_AC.thy

@@ -45,7 +45,7 @@ lemma invoke_tcb_tc_respects_aag[Tcb_AC_assms]:
           | wp restart_integrity_autarch set_mcpriority_integrity_autarch
                as_user_integrity_autarch thread_set_integrity_autarch
                option_update_thread_integrity_autarch
-               opt_update_thread_valid_sched static_imp_wp
+               opt_update_thread_valid_sched hoare_weak_lift_imp
                cap_insert_integrity_autarch checked_insert_pas_refined
                cap_delete_respects' cap_delete_pas_refined'
                check_cap_inv2[where Q="\<lambda>_. integrity aag X st"]

proof/access-control/Access_AC.thy

@@ -208,17 +208,17 @@ lemmas state_objs_to_policy_cases
 
 lemma tcb_states_of_state_preserved:
   "\<lbrakk> get_tcb thread s = Some tcb; tcb_state tcb' = tcb_state tcb \<rbrakk>
-     \<Longrightarrow> tcb_states_of_state (s\<lparr>kheap := kheap s(thread \<mapsto> TCB tcb')\<rparr>) = tcb_states_of_state s"
+     \<Longrightarrow> tcb_states_of_state (s\<lparr>kheap := (kheap s)(thread \<mapsto> TCB tcb')\<rparr>) = tcb_states_of_state s"
   by (auto split: option.splits simp: tcb_states_of_state_def get_tcb_def)
 
 lemma thread_st_auth_preserved:
   "\<lbrakk> get_tcb thread s = Some tcb; tcb_state tcb' = tcb_state tcb \<rbrakk>
-     \<Longrightarrow> thread_st_auth (s\<lparr>kheap := kheap s(thread \<mapsto> TCB tcb')\<rparr>) = thread_st_auth s"
+     \<Longrightarrow> thread_st_auth (s\<lparr>kheap := (kheap s)(thread \<mapsto> TCB tcb')\<rparr>) = thread_st_auth s"
   by (simp add: tcb_states_of_state_preserved thread_st_auth_def)
 
 lemma thread_bound_ntfns_preserved:
   "\<lbrakk> get_tcb thread s = Some tcb; tcb_bound_notification tcb' = tcb_bound_notification tcb \<rbrakk>
-     \<Longrightarrow> thread_bound_ntfns (s\<lparr>kheap := kheap s(thread \<mapsto> TCB tcb')\<rparr>) = thread_bound_ntfns s"
+     \<Longrightarrow> thread_bound_ntfns (s\<lparr>kheap := (kheap s)(thread \<mapsto> TCB tcb')\<rparr>) = thread_bound_ntfns s"
   by (auto simp: thread_bound_ntfns_def get_tcb_def split: option.splits)
 
 lemma is_transferable_null_filter[simp]:
@@ -865,7 +865,7 @@ locale Access_AC_2 = Access_AC_1 +
        \<Longrightarrow> (\<forall>x a. integrity_asids aag subjects x a s s'')"
   and integrity_asids_update_autarch:
     "\<lbrakk> \<forall>x a. integrity_asids aag {pasSubject aag} x a s s'; is_subject aag ptr \<rbrakk>
-       \<Longrightarrow> \<forall>x a. integrity_asids aag {pasSubject aag} x a s (s'\<lparr>kheap := kheap s'(ptr \<mapsto> obj)\<rparr>)"
+       \<Longrightarrow> \<forall>x a. integrity_asids aag {pasSubject aag} x a s (s'\<lparr>kheap := (kheap s')(ptr \<mapsto> obj)\<rparr>)"
 begin
 
 section \<open>Generic AC stuff\<close>
@@ -980,7 +980,7 @@ lemma integrity_refl [simp]:
 
 lemma integrity_update_autarch:
   "\<lbrakk> integrity aag X st s; is_subject aag ptr \<rbrakk>
-     \<Longrightarrow> integrity aag X st (s\<lparr>kheap := kheap s(ptr \<mapsto> obj)\<rparr>)"
+     \<Longrightarrow> integrity aag X st (s\<lparr>kheap := (kheap s)(ptr \<mapsto> obj)\<rparr>)"
   unfolding integrity_subjects_def
   apply (intro conjI,simp_all)
     apply clarsimp

proof/access-control/CNode_AC.thy

@@ -56,11 +56,11 @@ locale CNode_AC_1 =
        \<Longrightarrow> state_asids_to_policy_arch aag (caps(ptr \<mapsto> cap, ptr' \<mapsto> cap')) as vrefs \<subseteq> pasPolicy aag"
   and state_vrefs_tcb_upd:
     "\<lbrakk> pspace_aligned s; valid_vspace_objs s; valid_arch_state s; tcb_at tptr s \<rbrakk>
-       \<Longrightarrow> state_vrefs (s\<lparr>kheap := kheap s(tptr \<mapsto> TCB tcb)\<rparr>) = state_vrefs s"
+       \<Longrightarrow> state_vrefs (s\<lparr>kheap := (kheap s)(tptr \<mapsto> TCB tcb)\<rparr>) = state_vrefs s"
   and state_vrefs_simple_type_upd:
     "\<lbrakk> pspace_aligned s; valid_vspace_objs s; valid_arch_state s;
        ko_at ko p s; is_simple_type ko; a_type ko = a_type (f (val :: 'b)) \<rbrakk>
-       \<Longrightarrow> state_vrefs (s\<lparr>kheap := kheap s(p \<mapsto> f val)\<rparr>) = state_vrefs s"
+       \<Longrightarrow> state_vrefs (s\<lparr>kheap := (kheap s)(p \<mapsto> f val)\<rparr>) = state_vrefs s"
   and a_type_arch_object_not_tcb[simp]:
     "a_type (ArchObj arch_kernel_obj) \<noteq> ATCB"
   and set_cap_state_vrefs:
@@ -969,10 +969,10 @@ lemma set_untyped_cap_as_full_is_transferable[wp]:
   using untyped_not_transferable max_free_index_update_preserve_untyped by simp
 
 lemma set_untyped_cap_as_full_is_transferable':
-  "\<lbrace>\<lambda>s. is_transferable ((caps_of_state s(slot2 \<mapsto> new_cap)) slot3) \<and>
+  "\<lbrace>\<lambda>s. is_transferable (((caps_of_state s)(slot2 \<mapsto> new_cap)) slot3) \<and>
         Some src_cap = (caps_of_state s slot)\<rbrace>
    set_untyped_cap_as_full src_cap new_cap slot
-   \<lbrace>\<lambda>_ s. is_transferable ((caps_of_state s(slot2 \<mapsto> new_cap)) slot3)\<rbrace>"
+   \<lbrace>\<lambda>_ s. is_transferable (((caps_of_state s)(slot2 \<mapsto> new_cap)) slot3)\<rbrace>"
   apply (clarsimp simp: set_untyped_cap_as_full_def)
   apply safe
   apply (wp,fastforce)+

proof/access-control/DomainSepInv.thy

@@ -133,7 +133,7 @@ crunch domain_sep_inv[wp]: set_extra_badge "domain_sep_inv irqs st"
 lemma set_cap_neg_cte_wp_at_other_helper':
   "\<lbrakk> oslot \<noteq> slot; ko_at (TCB x) (fst oslot) s;
      tcb_cap_cases (snd oslot) = Some (ogetF, osetF, orestr);
-     kheap (s\<lparr>kheap := kheap s(fst oslot \<mapsto> TCB (osetF (\<lambda> x. cap) x))\<rparr>) (fst slot) = Some (TCB tcb);
+     kheap (s\<lparr>kheap := (kheap s)(fst oslot \<mapsto> TCB (osetF (\<lambda> x. cap) x))\<rparr>) (fst slot) = Some (TCB tcb);
      tcb_cap_cases (snd slot) = Some (getF, setF, restr); P (getF tcb) \<rbrakk>
      \<Longrightarrow> cte_wp_at P slot s"
   apply (case_tac "fst oslot = fst slot")
@@ -150,7 +150,7 @@ lemma set_cap_neg_cte_wp_at_other_helper':
 lemma set_cap_neg_cte_wp_at_other_helper:
   "\<lbrakk> \<not> cte_wp_at P slot s; oslot \<noteq> slot; ko_at (TCB x) (fst oslot) s;
      tcb_cap_cases (snd oslot) = Some (getF, setF, restr) \<rbrakk>
-     \<Longrightarrow> \<not> cte_wp_at P slot (s\<lparr>kheap := kheap s(fst oslot \<mapsto> TCB (setF (\<lambda> x. cap) x))\<rparr>)"
+     \<Longrightarrow> \<not> cte_wp_at P slot (s\<lparr>kheap := (kheap s)(fst oslot \<mapsto> TCB (setF (\<lambda> x. cap) x))\<rparr>)"
   apply (rule notI)
   apply (erule cte_wp_atE)
    apply (fastforce elim: notE intro: cte_wp_at_cteI split: if_splits)
@@ -336,7 +336,7 @@ lemma empty_slot_domain_sep_inv:
    \<lbrace>\<lambda>_ s. domain_sep_inv irqs (st :: 'state_ext state) (s :: det_ext state)\<rbrace>"
   unfolding empty_slot_def post_cap_deletion_def
   by (wpsimp wp: get_cap_wp set_cap_domain_sep_inv set_original_wp dxo_wp_weak
-                 static_imp_wp deleted_irq_handler_domain_sep_inv)
+                 hoare_weak_lift_imp deleted_irq_handler_domain_sep_inv)
 
 end
 
@@ -568,7 +568,7 @@ lemma cap_move_cte_wp_at_other:
    cap_move cap src_slot dest_slot
    \<lbrace>\<lambda>_. cte_wp_at P slot\<rbrace>"
   unfolding cap_move_def
-  by (wpsimp wp: set_cdt_cte_wp_at set_cap_cte_wp_at' dxo_wp_weak static_imp_wp set_original_wp)
+  by (wpsimp wp: set_cdt_cte_wp_at set_cap_cte_wp_at' dxo_wp_weak hoare_weak_lift_imp set_original_wp)
 
 lemma cte_wp_at_weak_derived_ReplyCap:
   "cte_wp_at ((=) (ReplyCap x False R)) slot s
@@ -1042,7 +1042,7 @@ lemma invoke_tcb_domain_sep_inv:
     apply (simp add: split_def cong: option.case_cong)
     apply (wp checked_cap_insert_domain_sep_inv hoare_vcg_all_lift_R hoare_vcg_all_lift
               hoare_vcg_const_imp_lift_R cap_delete_domain_sep_inv cap_delete_deletes
-              dxo_wp_weak cap_delete_valid_cap cap_delete_cte_at static_imp_wp
+              dxo_wp_weak cap_delete_valid_cap cap_delete_cte_at hoare_weak_lift_imp
            | wpc | strengthen
            | simp add: option_update_thread_def emptyable_def tcb_cap_cases_def
                        tcb_cap_valid_def tcb_at_st_tcb_at

proof/access-control/Finalise_AC.thy

@@ -533,7 +533,7 @@ lemma reply_cancel_ipc_respects[wp]:
    apply (rule hoare_lift_Pf2[where f="cdt"])
     apply (wpsimp wp: hoare_vcg_const_Ball_lift thread_set_integrity_autarch
                       thread_set_invs_trivial[OF ball_tcb_cap_casesI] thread_set_tcb_state_trivial
-                      thread_set_not_state_valid_sched static_imp_wp thread_set_cte_wp_at_trivial
+                      thread_set_not_state_valid_sched hoare_weak_lift_imp thread_set_cte_wp_at_trivial
                       thread_set_pas_refined
                 simp: ran_tcb_cap_cases)+
   apply (strengthen invs_psp_aligned invs_vspace_objs invs_arch_state, clarsimp)
@@ -799,7 +799,7 @@ proof (induct arbitrary: st rule: rec_del.induct, simp_all only: rec_del_fails)
     apply (simp only: split_def)
     apply (rule hoare_pre_spec_validE)
      apply (rule split_spec_bindE)
-      apply (wp static_imp_wp)
+      apply (wp hoare_weak_lift_imp)
      apply (rule spec_strengthen_postE)
       apply (rule spec_valid_conj_liftE1)
        apply (rule valid_validE_R, rule rec_del_valid_list, rule preemption_point_inv';
@@ -816,7 +816,7 @@ next
     apply (subst rec_del.simps)
     apply (simp only: split_def)
     apply (rule hoare_pre_spec_validE)
-     apply (wp set_cap_integrity_autarch set_cap_pas_refined_not_transferable "2.hyps" static_imp_wp)
+     apply (wp set_cap_integrity_autarch set_cap_pas_refined_not_transferable "2.hyps" hoare_weak_lift_imp)
           apply ((wp preemption_point_inv' | simp add: integrity_subjects_def pas_refined_def)+)[1]
          apply (simp(no_asm))
          apply (rule spec_strengthen_postE)
@@ -833,7 +833,7 @@ next
         apply (simp add: conj_comms)
         apply (wp set_cap_integrity_autarch  set_cap_pas_refined_not_transferable replace_cap_invs
                   final_cap_same_objrefs set_cap_cte_cap_wp_to
-                  set_cap_cte_wp_at hoare_vcg_const_Ball_lift static_imp_wp
+                  set_cap_cte_wp_at hoare_vcg_const_Ball_lift hoare_weak_lift_imp
                        | rule finalise_cap_not_reply_master
                        | simp add: in_monad)+
        apply (rule hoare_strengthen_post)
@@ -848,7 +848,7 @@ next
          apply (wp finalise_cap_invs[where slot=slot]
                    finalise_cap_replaceable[where sl=slot]
                    finalise_cap_makes_halted[where slot=slot]
-                   finalise_cap_auth' static_imp_wp)[1]
+                   finalise_cap_auth' hoare_weak_lift_imp)[1]
         apply (rule finalise_cap_cases[where slot=slot])
        apply (clarsimp simp: cte_wp_at_caps_of_state)
        apply (erule disjE)
@@ -871,7 +871,7 @@ next
   case (3 ptr bits n slot s)
   show ?case
     apply (simp add: spec_validE_def)
-    apply (wp static_imp_wp)
+    apply (wp hoare_weak_lift_imp)
     apply clarsimp
     done
 next
@@ -889,7 +889,7 @@ next
         apply (wpsimp wp: rec_del_invs)
        apply (rule "4.hyps", assumption+)
       apply (wpsimp wp: set_cap_integrity_autarch set_cap_pas_refined_not_transferable
-                        get_cap_wp static_imp_wp)+
+                        get_cap_wp hoare_weak_lift_imp)+
       apply (clarsimp simp: invs_psp_aligned invs_vspace_objs invs_arch_state
                             cte_wp_at_caps_of_state clas_no_asid cli_no_irqs aag_cap_auth_def)
       apply (drule_tac auth=auth in sta_caps, simp+)
@@ -958,13 +958,13 @@ lemma rec_del_respects_CTEDelete_transferable':
    apply (wp rec_del_respects'')
    apply (solves \<open>simp\<close>)
   apply (subst rec_del.simps[abs_def])
-  apply (wp add: hoare_K_bind without_preemption_wp static_imp_wp wp_transferable
+  apply (wp add: hoare_K_bind without_preemption_wp hoare_weak_lift_imp wp_transferable
                  rec_del_Finalise_transferable
             del: wp_not_transferable
          | wpc)+
     apply (rule hoare_post_impErr,rule rec_del_Finalise_transferable)
      apply simp apply (elim conjE) apply simp apply simp
-   apply (wp add: hoare_K_bind without_preemption_wp static_imp_wp wp_transferable
+   apply (wp add: hoare_K_bind without_preemption_wp hoare_weak_lift_imp wp_transferable
                   rec_del_Finalise_transferable
              del: wp_not_transferable
           | wpc)+
@@ -1085,7 +1085,7 @@ lemma empty_slot_cte_wp_at:
   by (wpsimp wp: empty_slot_caps_of_state)
 
 lemma deleting_irq_handler_caps_of_state_nullinv:
-  "\<lbrace>\<lambda>s. \<forall>p. P (caps_of_state s(p \<mapsto> NullCap))\<rbrace>
+  "\<lbrace>\<lambda>s. \<forall>p. P ((caps_of_state s)(p \<mapsto> NullCap))\<rbrace>
      deleting_irq_handler irq
    \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
   unfolding deleting_irq_handler_def
@@ -1104,7 +1104,7 @@ locale Finalise_AC_2 = Finalise_AC_1 +
        \<lbrace>\<lambda>_. (\<lambda>s. trp \<longrightarrow> integrity aag X st s) and pas_refined aag\<rbrace>,
        \<lbrace>\<lambda>_. (\<lambda>s. trp \<longrightarrow> integrity aag X st s) and pas_refined aag\<rbrace>"
   and finalise_cap_caps_of_state_nullinv:
-    "\<And>P. \<lbrace>\<lambda>s :: det_ext state. P (caps_of_state s) \<and> (\<forall>p. P (caps_of_state s(p \<mapsto> NullCap)))\<rbrace>
+    "\<And>P. \<lbrace>\<lambda>s :: det_ext state. P (caps_of_state s) \<and> (\<forall>p. P ((caps_of_state s)(p \<mapsto> NullCap)))\<rbrace>
           finalise_cap cap final
           \<lbrace>\<lambda>rv s. P (caps_of_state s)\<rbrace>"
   and finalise_cap_fst_ret:
@@ -1144,7 +1144,7 @@ proof (induct rule: rec_del.induct, simp_all only: rec_del_fails)
     apply (insert P_Null)
     apply (subst rec_del.simps)
     apply (simp only: split_def)
-    apply (wp static_imp_wp | simp)+
+    apply (wp hoare_weak_lift_imp | simp)+
     apply (wp empty_slot_cte_wp_at)[1]
     apply (rule spec_strengthen_postE)
     apply (rule hoare_pre_spec_validE)
@@ -1160,7 +1160,7 @@ next
     apply (subst rec_del.simps)
     apply (simp only: split_def without_preemption_def
                       rec_del_call.simps)
-    apply (wp static_imp_wp)
+    apply (wp hoare_weak_lift_imp)
     apply (wp set_cap_cte_wp_at')[1]
     apply (wp "2.hyps"[simplified without_preemption_def rec_del_call.simps])
          apply ((wp preemption_point_inv | simp)+)[1]
@@ -1172,7 +1172,7 @@ next
       apply (rule_tac Q = "\<lambda>rv' s. (slot \<noteq> p \<or> exposed \<longrightarrow> cte_wp_at P p s) \<and> P (fst rv')
                              \<and> cte_at slot s" in hoare_post_imp)
        apply (clarsimp simp: cte_wp_at_caps_of_state)
-      apply (wp static_imp_wp set_cap_cte_wp_at' finalise_cap_cte_wp_at_nullinv
+      apply (wp hoare_weak_lift_imp set_cap_cte_wp_at' finalise_cap_cte_wp_at_nullinv
                 finalise_cap_fst_ret get_cap_wp
              | simp add: is_final_cap_def)+
     apply (clarsimp simp add: P_Zombie is_cap_simps cte_wp_at_caps_of_state)+

proof/access-control/Ipc_AC.thy

@@ -31,7 +31,7 @@ lemma send_signal_caps_of_state[wp]:
   "send_signal ntfnptr badge \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace>"
   apply (clarsimp simp: send_signal_def)
   apply (rule hoare_seq_ext[OF _ get_simple_ko_sp])
-   apply (wpsimp wp: dxo_wp_weak cancel_ipc_receive_blocked_caps_of_state gts_wp static_imp_wp
+   apply (wpsimp wp: dxo_wp_weak cancel_ipc_receive_blocked_caps_of_state gts_wp hoare_weak_lift_imp
                simp: update_waiting_ntfn_def)
   apply (clarsimp simp: fun_upd_def[symmetric] st_tcb_def2)
   done
@@ -178,8 +178,8 @@ lemma send_upd_ctxintegrity:
      integrity aag X st s; st_tcb_at ((=) Running) thread s;
      get_tcb thread st = Some tcb; get_tcb thread s = Some tcb'\<rbrakk>
      \<Longrightarrow> integrity aag X st
-                   (s\<lparr>kheap := kheap s(thread \<mapsto>
-                                       TCB (tcb'\<lparr>tcb_arch := arch_tcb_context_set c' (tcb_arch tcb')\<rparr>))\<rparr>)"
+                   (s\<lparr>kheap := (kheap s)
+                               (thread \<mapsto> TCB (tcb'\<lparr>tcb_arch := arch_tcb_context_set c' (tcb_arch tcb')\<rparr>))\<rparr>)"
   apply (clarsimp simp: integrity_def tcb_states_of_state_preserved st_tcb_def2)
   apply (rule conjI)
    prefer 2
@@ -423,7 +423,7 @@ lemma send_signal_respects:
    apply (rule hoare_pre)
     apply (wp set_notification_respects[where auth=Notify]
                  as_user_set_register_respects_indirect[where ntfnptr=ntfnptr]
-                 set_thread_state_integrity' sts_st_tcb_at' static_imp_wp
+                 set_thread_state_integrity' sts_st_tcb_at' hoare_weak_lift_imp
                  cancel_ipc_receive_blocked_respects[where ntfnptr=ntfnptr]
                  gts_wp
                | wpc | simp)+
@@ -451,7 +451,7 @@ lemma send_signal_respects:
                sts_st_tcb_at' as_user_set_register_respects
                set_thread_state_pas_refined set_simple_ko_pas_refined
                set_thread_state_respects_in_signalling [where ntfnptr = ntfnptr]
-               set_ntfn_valid_objs_at hoare_vcg_disj_lift static_imp_wp
+               set_ntfn_valid_objs_at hoare_vcg_disj_lift hoare_weak_lift_imp
           | wpc
           | simp add: update_waiting_ntfn_def)+
   apply clarsimp
@@ -756,10 +756,10 @@ lemma transfer_caps_loop_presM_extended:
   apply (clarsimp simp add: Let_def split_def whenE_def
                       cong: if_cong list.case_cong split del: if_split)
   apply (rule hoare_pre)
-   apply (wp eb hoare_vcg_const_imp_lift hoare_vcg_const_Ball_lift static_imp_wp
+   apply (wp eb hoare_vcg_const_imp_lift hoare_vcg_const_Ball_lift hoare_weak_lift_imp
           | assumption | simp split del: if_split)+
       apply (rule cap_insert_assume_null)
-      apply (wp x hoare_vcg_const_Ball_lift cap_insert_cte_wp_at static_imp_wp)+
+      apply (wp x hoare_vcg_const_Ball_lift cap_insert_cte_wp_at hoare_weak_lift_imp)+
     apply (rule hoare_vcg_conj_liftE_R)
      apply (rule derive_cap_is_derived_foo')
     apply (rule_tac Q' ="\<lambda>cap' s. (vo \<longrightarrow> cap'\<noteq> NullCap \<longrightarrow>
@@ -1061,7 +1061,7 @@ lemma send_ipc_pas_refined:
                                       (pasObjectAbs aag x21, Reply, pasSubject aag) \<in> pasPolicy aag)"
                     in hoare_strengthen_post[rotated])
         apply simp
-       apply (wp set_thread_state_pas_refined do_ipc_transfer_pas_refined static_imp_wp gts_wp
+       apply (wp set_thread_state_pas_refined do_ipc_transfer_pas_refined hoare_weak_lift_imp gts_wp
               | wpc
               | simp add: hoare_if_r_and)+
    apply (wp hoare_vcg_all_lift hoare_imp_lift_something | simp add: st_tcb_at_tcb_states_of_state_eq)+
@@ -1206,7 +1206,7 @@ lemma receive_ipc_base_pas_refined:
                                   aag_has_auth_to aag Reply (hd list))"
                      in hoare_strengthen_post[rotated])
          apply (fastforce simp: pas_refined_refl)
-        apply (wp static_imp_wp do_ipc_transfer_pas_refined set_simple_ko_pas_refined
+        apply (wp hoare_weak_lift_imp do_ipc_transfer_pas_refined set_simple_ko_pas_refined
                   set_thread_state_pas_refined get_simple_ko_wp hoare_vcg_all_lift
                   hoare_vcg_imp_lift [OF set_simple_ko_get_tcb, unfolded disj_not1]
                | wpc
@@ -1365,7 +1365,7 @@ lemma do_normal_transfer_send_integrity_autarch:
   by (wpsimp wp: as_user_integrity_autarch set_message_info_integrity_autarch
                  copy_mrs_pas_refined copy_mrs_integrity_autarch transfer_caps_integrity_autarch
                  lookup_extra_caps_authorised lookup_extra_caps_length get_mi_length get_mi_valid'
-                 static_imp_wp hoare_vcg_conj_lift hoare_vcg_ball_lift lec_valid_cap')
+                 hoare_weak_lift_imp hoare_vcg_conj_lift hoare_vcg_ball_lift lec_valid_cap')
 
 
 crunch integrity_autarch: setup_caller_cap "integrity aag X st"
@@ -1742,7 +1742,7 @@ locale Ipc_AC_2 = Ipc_AC_1 +
   and auth_ipc_buffers_kheap_update:
     "\<lbrakk> x \<in> auth_ipc_buffers st thread; kheap st thread = Some (TCB tcb);
        kheap s thread = Some (TCB tcb'); tcb_ipcframe tcb = tcb_ipcframe tcb' \<rbrakk>
-       \<Longrightarrow> x \<in> auth_ipc_buffers (s\<lparr>kheap := kheap s(thread \<mapsto> TCB tcb)\<rparr>) thread"
+       \<Longrightarrow> x \<in> auth_ipc_buffers (s\<lparr>kheap := (kheap s)(thread \<mapsto> TCB tcb)\<rparr>) thread"
   and auth_ipc_buffers_machine_state_update[simp]:
     "auth_ipc_buffers (machine_state_update f s) = auth_ipc_buffers (s :: det_ext state)"
   and empty_slot_extended_list_integ_lift_in_ipc:
@@ -2365,7 +2365,7 @@ lemma send_ipc_integrity_autarch:
     apply (fastforce dest!: integrity_tcb_in_ipc_final elim!: integrity_trans)
    apply (wp setup_caller_cap_respects_in_ipc_reply
              set_thread_state_respects_in_ipc_autarch[where param_b = Inactive]
-             hoare_vcg_if_lift static_imp_wp possible_switch_to_respects_in_ipc_autarch
+             hoare_vcg_if_lift hoare_weak_lift_imp possible_switch_to_respects_in_ipc_autarch
              set_thread_state_running_respects_in_ipc do_ipc_transfer_respects_in_ipc thread_get_inv
              set_endpoint_integrity_in_ipc
           | wpc

proof/access-control/RISCV64/ArchAccess.thy

@@ -186,10 +186,10 @@ lemmas integrity_asids_kh_upds =
 declare integrity_asids_def[simp]
 
 lemma integrity_asids_kh_upds':
-  "integrity_asids aag subjects x a (s\<lparr>kheap := kheap s(p \<mapsto> CNode sz cs)\<rparr>) s"
-  "integrity_asids aag subjects x a (s\<lparr>kheap := kheap s(p \<mapsto> TCB tcb)\<rparr>) s"
-  "integrity_asids aag subjects x a (s\<lparr>kheap := kheap s(p \<mapsto> Endpoint ep)\<rparr>) s"
-  "integrity_asids aag subjects x a (s\<lparr>kheap := kheap s(p \<mapsto> Notification ntfn)\<rparr>) s"
+  "integrity_asids aag subjects x a (s\<lparr>kheap := (kheap s)(p \<mapsto> CNode sz cs)\<rparr>) s"
+  "integrity_asids aag subjects x a (s\<lparr>kheap := (kheap s)(p \<mapsto> TCB tcb)\<rparr>) s"
+  "integrity_asids aag subjects x a (s\<lparr>kheap := (kheap s)(p \<mapsto> Endpoint ep)\<rparr>) s"
+  "integrity_asids aag subjects x a (s\<lparr>kheap := (kheap s)(p \<mapsto> Notification ntfn)\<rparr>) s"
   by (auto simp: opt_map_def split: option.splits)
 
 lemma integrity_asids_kh_update:

proof/access-control/RISCV64/ArchAccess_AC.thy

@@ -82,7 +82,7 @@ lemma integrity_asids_refl[Access_AC_assms, simp]:
 
 lemma integrity_asids_update_autarch[Access_AC_assms]:
   "\<lbrakk> \<forall>x a. integrity_asids aag {pasSubject aag} x a st s; is_subject aag ptr \<rbrakk>
-     \<Longrightarrow> \<forall>x a. integrity_asids aag {pasSubject aag} x a st (s\<lparr>kheap := kheap s(ptr \<mapsto> obj)\<rparr>)"
+     \<Longrightarrow> \<forall>x a. integrity_asids aag {pasSubject aag} x a st (s\<lparr>kheap := (kheap s)(ptr \<mapsto> obj)\<rparr>)"
   by (auto simp: opt_map_def)
 
 end

proof/access-control/RISCV64/ArchArch_AC.thy

@@ -541,7 +541,7 @@ lemma perform_pt_inv_unmap_pas_refined:
 lemma vs_lookup_PageTablePTE:
   "\<lbrakk> vs_lookup_table level asid vref s' = Some (lvl', pt);
      pspace_aligned s; valid_vspace_objs s; valid_asid_table s;
-     invalid_pte_at p s; ptes_of s' = ptes_of s (p \<mapsto> pte); is_PageTablePTE pte;
+     invalid_pte_at p s; ptes_of s' = (ptes_of s)(p \<mapsto> pte); is_PageTablePTE pte;
      asid_pools_of s' = asid_pools_of s; asid_table s' = asid_table s;
      vref \<in> user_region;
      pts_of s (the (pte_ref pte)) = Some empty_pt; pt \<noteq> pptr_from_pte pte \<rbrakk>
@@ -584,7 +584,7 @@ lemma vs_lookup_PageTablePTE:
 lemma vs_lookup_PageTablePTE':
   "\<lbrakk> vs_lookup_table level asid vref s = Some (lvl', pt);
      pspace_aligned s; valid_vspace_objs s; valid_asid_table s;
-     invalid_pte_at p s; ptes_of s' = ptes_of s (p \<mapsto> pte); is_PageTablePTE pte;
+     invalid_pte_at p s; ptes_of s' = (ptes_of s)(p \<mapsto> pte); is_PageTablePTE pte;
      asid_pools_of s' = asid_pools_of s; asid_table s' = asid_table s; vref \<in> user_region  \<rbrakk>
      \<Longrightarrow> \<exists>level' \<ge> level. vs_lookup_table level' asid vref s' = Some (lvl', pt)"
   apply (induct level arbitrary: lvl' pt rule: bit0.from_top_full_induct[where y=max_pt_level])
@@ -915,7 +915,7 @@ lemma unmap_page_table_respects:
    unmap_page_table asid vaddr pt
    \<lbrace>\<lambda>_. integrity aag X st\<rbrace>"
   apply (simp add: unmap_page_table_def sfence_def)
-  apply (wpsimp wp: pt_lookup_from_level_is_subject dmo_mol_respects hoare_vcg_conj_liftE
+  apply (wpsimp wp: pt_lookup_from_level_is_subject dmo_mol_respects hoare_vcg_conj_liftE_weaker
                     store_pte_respects pt_lookup_from_level_wrp[where Q="\<lambda>_. integrity aag X st"]
          | wp (once) hoare_drop_imps hoare_vcg_E_elim)+
   apply (intro conjI; clarsimp)
@@ -1237,7 +1237,7 @@ lemma perform_asid_control_invocation_respects:
   apply (wpc, simp)
    apply (wpsimp wp: set_cap_integrity_autarch cap_insert_integrity_autarch
                      asid_table_entry_update_integrity retype_region_integrity[where sz=12]
-                     static_imp_wp delete_objects_valid_vspace_objs delete_objects_valid_arch_state)
+                     hoare_weak_lift_imp delete_objects_valid_vspace_objs delete_objects_valid_arch_state)
   apply (clarsimp simp: authorised_asid_control_inv_def ptr_range_def add.commute range_cover_def
                         obj_bits_api_def default_arch_object_def pageBits_def word_bits_def)
   apply (subst is_aligned_neg_mask_eq[THEN sym], assumption)
@@ -1318,9 +1318,9 @@ lemma perform_asid_control_invocation_pas_refined:
   apply (simp add: perform_asid_control_invocation_def )
   apply wpc
    apply (rule pas_refined_asid_control_helper hoare_seq_ext hoare_K_bind)+
-         apply (wp cap_insert_pas_refined' static_imp_wp | simp)+
+         apply (wp cap_insert_pas_refined' hoare_weak_lift_imp | simp)+
       apply ((wp retype_region_pas_refined'[where sz=pageBits]
-                 hoare_vcg_ex_lift hoare_vcg_all_lift static_imp_wp hoare_wp_combs hoare_drop_imp
+                 hoare_vcg_ex_lift hoare_vcg_all_lift hoare_weak_lift_imp hoare_wp_combs hoare_drop_imp
                  retype_region_invs_extras(1)[where sz = pageBits]
                  retype_region_invs_extras(4)[where sz = pageBits]
                  retype_region_invs_extras(6)[where sz = pageBits]
@@ -1329,7 +1329,7 @@ lemma perform_asid_control_invocation_pas_refined:
                  max_index_upd_invs_simple max_index_upd_caps_overlap_reserved
                  hoare_vcg_ex_lift set_cap_cte_wp_at hoare_vcg_disj_lift set_free_index_valid_pspace
                  set_cap_descendants_range_in set_cap_no_overlap get_cap_wp set_cap_caps_no_overlap
-                 hoare_vcg_all_lift static_imp_wp retype_region_invs_extras
+                 hoare_vcg_all_lift hoare_weak_lift_imp retype_region_invs_extras
                  set_cap_pas_refined_not_transferable arch_update_cap_valid_mdb
              | simp add: do_machine_op_def region_in_kernel_window_def cte_wp_at_neg2)+)[3]
    apply (rename_tac frame slot parent base )

proof/access-control/RISCV64/ArchCNode_AC.thy

@@ -101,14 +101,14 @@ crunches prepare_thread_delete, arch_finalise_cap
 
 lemma state_vrefs_tcb_upd[CNode_AC_assms]:
   "\<lbrakk> pspace_aligned s; valid_vspace_objs s; valid_arch_state s; tcb_at t s \<rbrakk>
-     \<Longrightarrow> state_vrefs (s\<lparr>kheap := kheap s(t \<mapsto> TCB tcb)\<rparr>) = state_vrefs s"
+     \<Longrightarrow> state_vrefs (s\<lparr>kheap := (kheap s)(t \<mapsto> TCB tcb)\<rparr>) = state_vrefs s"
   apply (rule state_vrefs_eqI)
   by (fastforce simp: opt_map_def obj_at_def is_obj_defs valid_arch_state_def)+
 
 lemma state_vrefs_simple_type_upd[CNode_AC_assms]:
   "\<lbrakk> pspace_aligned s; valid_vspace_objs s; valid_arch_state s;
      ko_at ko ptr s; is_simple_type ko; a_type ko = a_type (f val) \<rbrakk>
-     \<Longrightarrow> state_vrefs (s\<lparr>kheap := kheap s(ptr \<mapsto> f val)\<rparr>) = state_vrefs s"
+     \<Longrightarrow> state_vrefs (s\<lparr>kheap := (kheap s)(ptr \<mapsto> f val)\<rparr>) = state_vrefs s"
   apply (case_tac ko; case_tac "f val"; clarsimp)
   by (fastforce intro!: state_vrefs_eqI simp: opt_map_def obj_at_def is_obj_defs valid_arch_state_def)+
 

proof/access-control/RISCV64/ArchDomainSepInv.thy

@@ -52,7 +52,7 @@ lemma perform_page_invocation_domain_sep_inv:
    \<lbrace>\<lambda>_. domain_sep_inv irqs st\<rbrace>"
   apply (rule hoare_pre)
    apply (wp mapM_wp[OF _ subset_refl] set_cap_domain_sep_inv mapM_x_wp[OF _ subset_refl]
-             perform_page_invocation_domain_sep_inv_get_cap_helper static_imp_wp
+             perform_page_invocation_domain_sep_inv_get_cap_helper hoare_weak_lift_imp
           | simp add: perform_page_invocation_def o_def | wpc)+
   done
 
@@ -72,7 +72,7 @@ lemma perform_asid_control_invocation_domain_sep_inv:
   unfolding perform_asid_control_invocation_def
   apply (rule hoare_pre)
   apply (wp modify_wp cap_insert_domain_sep_inv' set_cap_domain_sep_inv
-            get_cap_domain_sep_inv_cap[where st=st] static_imp_wp
+            get_cap_domain_sep_inv_cap[where st=st] hoare_weak_lift_imp
          | wpc | simp )+
   done
 

proof/access-control/RISCV64/ArchFinalise_AC.thy

@@ -172,7 +172,7 @@ crunches set_asid_pool
 lemma set_asid_pool_tcb_states_of_state[wp]:
   "set_asid_pool p pool \<lbrace>\<lambda>s. P (tcb_states_of_state s)\<rbrace>"
   apply (wpsimp wp: set_object_wp_strong simp: obj_at_def  set_asid_pool_def)
-  apply (prop_tac "\<forall>x. get_tcb x (s\<lparr>kheap := kheap s(p \<mapsto> ArchObj (ASIDPool pool))\<rparr>) = get_tcb x s")
+  apply (prop_tac "\<forall>x. get_tcb x (s\<lparr>kheap := (kheap s)(p \<mapsto> ArchObj (ASIDPool pool))\<rparr>) = get_tcb x s")
    apply (auto simp: tcb_states_of_state_def get_tcb_def)
   done
 
@@ -266,7 +266,7 @@ proof (induct rule: cap_revoke.induct[where ?a1.0=s])
 qed
 
 lemma finalise_cap_caps_of_state_nullinv[Finalise_AC_assms]:
-  "\<lbrace>\<lambda>s. P (caps_of_state s) \<and> (\<forall>p. P (caps_of_state s(p \<mapsto> NullCap)))\<rbrace>
+  "\<lbrace>\<lambda>s. P (caps_of_state s) \<and> (\<forall>p. P ((caps_of_state s)(p \<mapsto> NullCap)))\<rbrace>
    finalise_cap cap final
    \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
   by (cases cap;

proof/access-control/RISCV64/ArchIpc_AC.thy

@@ -175,7 +175,7 @@ lemma handle_arch_fault_reply_respects[Ipc_AC_assms]:
 lemma auth_ipc_buffers_kheap_update[Ipc_AC_assms]:
   "\<lbrakk> x \<in> auth_ipc_buffers st thread; kheap st thread = Some (TCB tcb);
      kheap s thread = Some (TCB tcb'); tcb_ipcframe tcb = tcb_ipcframe tcb' \<rbrakk>
-     \<Longrightarrow> x \<in> auth_ipc_buffers (s\<lparr>kheap := kheap s(thread \<mapsto> TCB tcb)\<rparr>) thread"
+     \<Longrightarrow> x \<in> auth_ipc_buffers (s\<lparr>kheap := (kheap s)(thread \<mapsto> TCB tcb)\<rparr>) thread"
   by (clarsimp simp: auth_ipc_buffers_member_def get_tcb_def caps_of_state_tcb)
 
 lemma auth_ipc_buffers_machine_state_update[Ipc_AC_assms, simp]:

proof/access-control/RISCV64/ArchTcb_AC.thy

@@ -45,7 +45,7 @@ lemma invoke_tcb_tc_respects_aag[Tcb_AC_assms]:
          | wp restart_integrity_autarch set_mcpriority_integrity_autarch
               as_user_integrity_autarch thread_set_integrity_autarch
               option_update_thread_integrity_autarch
-              opt_update_thread_valid_sched static_imp_wp
+              opt_update_thread_valid_sched hoare_weak_lift_imp
               cap_insert_integrity_autarch checked_insert_pas_refined
               cap_delete_respects' cap_delete_pas_refined'
               check_cap_inv2[where Q="\<lambda>_. integrity aag X st"]

proof/access-control/Retype_AC.thy

@@ -970,7 +970,7 @@ lemma reset_untyped_cap_valid_vspace_objs:
    \<lbrace>\<lambda>_. valid_vspace_objs\<rbrace>"
   unfolding reset_untyped_cap_def
   apply (wpsimp wp: mapME_x_inv_wp preemption_point_inv)
-      apply (wp static_imp_wp delete_objects_valid_vspace_objs)
+      apply (wp hoare_weak_lift_imp delete_objects_valid_vspace_objs)
      apply (wpsimp wp: get_cap_wp)+
   apply (cases src_slot)
   apply (auto simp: cte_wp_at_caps_of_state)
@@ -1008,7 +1008,7 @@ lemma reset_untyped_cap_valid_arch_state:
    \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
   unfolding reset_untyped_cap_def
   apply (wpsimp wp: mapME_x_inv_wp preemption_point_inv)
-      apply (wp static_imp_wp delete_objects_valid_arch_state)
+      apply (wp hoare_weak_lift_imp delete_objects_valid_arch_state)
      apply (wpsimp wp: get_cap_wp)+
   apply (cases src_slot)
   apply (auto simp: cte_wp_at_caps_of_state)

proof/access-control/Tcb_AC.thy

@@ -60,7 +60,7 @@ lemmas itr_wps =
   restart_integrity_autarch as_user_integrity_autarch thread_set_integrity_autarch
   option_update_thread_integrity_autarch thread_set_pas_refined
   cap_insert_integrity_autarch cap_insert_pas_refined
-  hoare_vcg_all_liftE wp_throw_const_impE hoare_weak_lift_imp hoare_vcg_all_lift
+  hoare_vcg_all_liftE hoare_weak_lift_impE hoare_weak_lift_imp hoare_vcg_all_lift
   check_cap_inv[where P="valid_cap c" for c]
   check_cap_inv[where P="tcb_cap_valid c p" for c p]
   check_cap_inv[where P="cte_at p0" for p0]
@@ -322,7 +322,7 @@ subsubsection\<open>@{term "pas_refined"}\<close>
 
 lemmas ita_wps = as_user_pas_refined restart_pas_refined cap_insert_pas_refined
                  thread_set_pas_refined cap_delete_pas_refined' check_cap_inv2 hoare_vcg_all_liftE
-                 wp_throw_const_impE hoare_weak_lift_imp hoare_vcg_all_lift
+                 hoare_weak_lift_impE hoare_weak_lift_imp hoare_vcg_all_lift
 
 lemma hoare_st_refl:
   "\<lbrakk> \<And>st. \<lbrace>P st\<rbrace> f \<lbrace>Q st\<rbrace>; \<And>r s st. Q st r s \<Longrightarrow> Q' r s \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P s s\<rbrace> f \<lbrace>Q'\<rbrace>"

proof/capDL-api/Invocation_DP.thy

@@ -1142,13 +1142,13 @@ lemma sep_map_c_asid_reset:
    apply clarsimp
    apply (case_tac "\<not> has_slots obj")
     apply simp
-   apply (rule_tac x = "update_slots (object_slots obj(snd ptr \<mapsto> cap')) obj"
+   apply (rule_tac x = "update_slots ((object_slots obj)(snd ptr \<mapsto> cap')) obj"
      in exI)
    apply (simp add:sep_map_general_def object_to_sep_state_slot)
   apply clarsimp
   apply (case_tac "\<not> has_slots obj")
    apply simp
-  apply (rule_tac x = "update_slots (object_slots obj(snd ptr \<mapsto> cap)) obj"
+  apply (rule_tac x = "update_slots ((object_slots obj)(snd ptr \<mapsto> cap)) obj"
     in exI)
   apply (simp add:sep_map_general_def object_to_sep_state_slot)
   done

proof/crefine/ARM/CSpace_C.thy

@@ -1033,14 +1033,14 @@ lemma cteInsert_ccorres:
                   apply (rule ccorres_move_c_guard_cte)
                   apply (ctac ccorres:ccorres_updateMDB_set_mdbPrev)
                  apply (ctac ccorres: ccorres_updateMDB_skip)
-                apply (wp static_imp_wp)+
+                apply (wp hoare_weak_lift_imp)+
               apply (clarsimp simp: Collect_const_mem split del: if_split)
               apply vcg
-             apply (wp static_imp_wp)
+             apply (wp hoare_weak_lift_imp)
             apply (clarsimp simp: Collect_const_mem split del: if_split)
             apply vcg
            apply (clarsimp simp:cmdb_node_relation_mdbNext)
-           apply (wp setUntypedCapAsFull_cte_at_wp static_imp_wp)
+           apply (wp setUntypedCapAsFull_cte_at_wp hoare_weak_lift_imp)
           apply (clarsimp simp: Collect_const_mem split del: if_split)
           apply (vcg exspec=setUntypedCapAsFull_modifies)
          apply wp

proof/crefine/ARM/Delete_C.thy

@@ -826,7 +826,7 @@ lemma finaliseSlot_ccorres:
                apply (simp add: guard_is_UNIV_def)
               apply (simp add: conj_comms)
               apply (wp make_zombie_invs' updateCap_cte_wp_at_cases
-                        updateCap_cap_to' hoare_vcg_disj_lift static_imp_wp)+
+                        updateCap_cap_to' hoare_vcg_disj_lift hoare_weak_lift_imp)+
             apply (simp add: guard_is_UNIV_def)
            apply wp
           apply (simp add: guard_is_UNIV_def)
@@ -855,7 +855,7 @@ lemma finaliseSlot_ccorres:
         apply (erule(1) cmap_relationE1 [OF cmap_relation_cte])
         apply (frule valid_global_refsD_with_objSize, clarsimp)
         apply (auto simp: typ_heap_simps dest!: ccte_relation_ccap_relation)[1]
-       apply (wp isFinalCapability_inv static_imp_wp | wp (once) isFinal[where x=slot'])+
+       apply (wp isFinalCapability_inv hoare_weak_lift_imp | wp (once) isFinal[where x=slot'])+
       apply vcg
      apply (rule conseqPre, vcg)
      apply clarsimp

proof/crefine/ARM/Detype_C.thy

@@ -1434,7 +1434,7 @@ lemma deleteObjects_ccorres':
   apply (rule allI, rule conseqPre, vcg)
   apply (clarsimp simp: in_monad)
   apply (rule bexI [rotated])
-   apply (rule iffD2 [OF in_monad(20)])
+   apply (rule iffD2 [OF in_monad(21)])
    apply (rule conjI [OF refl refl])
   apply (clarsimp simp: simpler_modify_def)
 proof -

proof/crefine/ARM/Fastpath_Equiv.thy

@@ -1559,8 +1559,8 @@ lemma fastpath_callKernel_SysReplyRecv_corres:
                                       setThreadState_no_sch_change setThreadState_obj_at_unchanged
                                       sts_st_tcb_at'_cases sts_bound_tcb_at'
                                       fastpathBestSwitchCandidate_lift[where f="setThreadState s t" for s t]
-                                      static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift
-                                      static_imp_wp cnode_caps_gsCNodes_lift
+                                      hoare_weak_lift_imp hoare_vcg_all_lift hoare_vcg_imp_lift
+                                      hoare_weak_lift_imp cnode_caps_gsCNodes_lift
                                       hoare_vcg_ex_lift
                           | wps)+
                            apply (strengthen imp_consequent[where Q="tcb_at' t s" for t s])
@@ -1573,8 +1573,8 @@ lemma fastpath_callKernel_SysReplyRecv_corres:
                                       emptySlot_cnode_caps
                                       user_getreg_inv asUser_typ_ats
                                       asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp'
-                                      static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift
-                                      static_imp_wp cnode_caps_gsCNodes_lift
+                                      hoare_weak_lift_imp hoare_vcg_all_lift hoare_vcg_imp_lift
+                                      hoare_weak_lift_imp cnode_caps_gsCNodes_lift
                                       hoare_vcg_ex_lift
                                       fastpathBestSwitchCandidate_lift[where f="emptySlot a b" for a b]
                                    | simp del: comp_apply
@@ -1585,8 +1585,8 @@ lemma fastpath_callKernel_SysReplyRecv_corres:
                            apply (clarsimp cong: conj_cong)
                            apply ((wp user_getreg_inv asUser_typ_ats
                                       asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp'
-                                      static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift
-                                      static_imp_wp cnode_caps_gsCNodes_lift
+                                      hoare_weak_lift_imp hoare_vcg_all_lift hoare_vcg_imp_lift
+                                      hoare_weak_lift_imp cnode_caps_gsCNodes_lift
                                       hoare_vcg_ex_lift
                                    | clarsimp simp: obj_at'_weakenE[OF _ TrueI]
                                    | solves \<open>

proof/crefine/ARM/Invoke_C.thy

@@ -1238,7 +1238,7 @@ lemma decodeCNodeInvocation_ccorres:
                                             apply (rule ccorres_return_C_errorE, simp+)[1]
                                            apply wp
                                           apply (vcg exspec=invokeCNodeRotate_modifies)
-                                         apply (wp static_imp_wp)+
+                                         apply (wp hoare_weak_lift_imp)+
                                        apply (simp add: Collect_const_mem)
                                        apply (vcg exspec=setThreadState_modifies)
                                       apply (simp add: Collect_const_mem)
@@ -1302,16 +1302,16 @@ lemma decodeCNodeInvocation_ccorres:
                       apply wp
                      apply simp
                      apply (vcg exspec=getSyscallArg_modifies)
-                    apply (wp static_imp_wp)
+                    apply (wp hoare_weak_lift_imp)
                    apply simp
                    apply (vcg exspec=getSyscallArg_modifies)
                   apply wp
                  apply simp
                  apply (vcg exspec=getSyscallArg_modifies)
-                apply (wp static_imp_wp)
+                apply (wp hoare_weak_lift_imp)
                apply simp
                apply (vcg exspec=getSyscallArg_modifies)
-              apply (wp static_imp_wp)
+              apply (wp hoare_weak_lift_imp)
              apply simp
              apply (vcg exspec=getSyscallArg_modifies)
             apply wp
@@ -1326,7 +1326,7 @@ lemma decodeCNodeInvocation_ccorres:
          apply vcg
         apply simp
         apply (wp injection_wp_E[OF refl] hoare_vcg_const_imp_lift_R
-                  hoare_vcg_all_lift_R lsfco_cte_at' static_imp_wp
+                  hoare_vcg_all_lift_R lsfco_cte_at' hoare_weak_lift_imp
                 | simp add: hasCancelSendRights_not_Null ctes_of_valid_strengthen
                       cong: conj_cong
                 | wp (once) hoare_drop_imps)+

proof/crefine/ARM/IpcCancel_C.thy

@@ -2637,8 +2637,8 @@ lemma cpspace_relation_ep_update_an_ep:
   and     pal: "pspace_aligned' s" "pspace_distinct' s"
   and  others: "\<And>epptr' ep'. \<lbrakk> ko_at' ep' epptr' s; epptr' \<noteq> epptr; ep' \<noteq> IdleEP \<rbrakk>
                                  \<Longrightarrow> set (epQueue ep') \<inter> (ctcb_ptr_to_tcb_ptr ` S) = {}"
-  shows "cmap_relation (map_to_eps (ksPSpace s(epptr \<mapsto> KOEndpoint ep')))
-           (cslift t(Ptr epptr \<mapsto> endpoint)) Ptr (cendpoint_relation mp')"
+  shows "cmap_relation (map_to_eps ((ksPSpace s)(epptr \<mapsto> KOEndpoint ep')))
+           ((cslift t)(Ptr epptr \<mapsto> endpoint)) Ptr (cendpoint_relation mp')"
   using cp koat pal rel unfolding cmap_relation_def
   apply -
   apply (clarsimp elim!: obj_atE' simp: map_comp_update projectKO_opts_defs)
@@ -2660,8 +2660,8 @@ lemma cpspace_relation_ep_update_ep:
   and      cp: "cmap_relation (map_to_eps (ksPSpace s)) (cslift t) Ptr (cendpoint_relation mp)"
   and     rel: "cendpoint_relation mp' ep' endpoint"
   and    mpeq: "(mp' |` (- (tcb_ptr_to_ctcb_ptr ` qs))) = (mp |` (- (tcb_ptr_to_ctcb_ptr ` qs)))"
-  shows "cmap_relation (map_to_eps (ksPSpace s(epptr \<mapsto> KOEndpoint ep')))
-           (cslift t(Ptr epptr \<mapsto> endpoint)) Ptr (cendpoint_relation mp')"
+  shows "cmap_relation (map_to_eps ((ksPSpace s)(epptr \<mapsto> KOEndpoint ep')))
+           ((cslift t)(Ptr epptr \<mapsto> endpoint)) Ptr (cendpoint_relation mp')"
   using invs
   apply (intro cpspace_relation_ep_update_an_ep[OF koat cp rel mpeq])
     apply clarsimp+
@@ -2673,15 +2673,15 @@ lemma cpspace_relation_ep_update_ep':
   fixes ep :: "endpoint" and ep' :: "endpoint"
     and epptr :: "word32" and s :: "kernel_state"
   defines "qs \<equiv> if (isSendEP ep' \<or> isRecvEP ep') then set (epQueue ep') else {}"
-  defines "s' \<equiv> s\<lparr>ksPSpace := ksPSpace s(epptr \<mapsto> KOEndpoint ep')\<rparr>"
+  defines "s' \<equiv> s\<lparr>ksPSpace := (ksPSpace s)(epptr \<mapsto> KOEndpoint ep')\<rparr>"
   assumes koat: "ko_at' ep epptr s"
   and       vp: "valid_pspace' s"
   and      cp: "cmap_relation (map_to_eps (ksPSpace s)) (cslift t) Ptr (cendpoint_relation mp)"
   and      srs: "sym_refs (state_refs_of' s')"
   and     rel: "cendpoint_relation mp' ep' endpoint"
   and    mpeq: "(mp' |` (- (tcb_ptr_to_ctcb_ptr ` qs))) = (mp |` (- (tcb_ptr_to_ctcb_ptr ` qs)))"
-  shows "cmap_relation (map_to_eps (ksPSpace s(epptr \<mapsto> KOEndpoint ep')))
-           (cslift t(Ptr epptr \<mapsto> endpoint)) Ptr (cendpoint_relation mp')"
+  shows "cmap_relation (map_to_eps ((ksPSpace s)(epptr \<mapsto> KOEndpoint ep')))
+           ((cslift t)(Ptr epptr \<mapsto> endpoint)) Ptr (cendpoint_relation mp')"
 proof -
   from koat have koat': "ko_at' ep' epptr s'"
     by (clarsimp simp: obj_at'_def s'_def objBitsKO_def ps_clear_def projectKOs)

proof/crefine/ARM/Ipc_C.thy

@@ -3176,7 +3176,7 @@ proof -
        apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
        apply (clarsimp simp: seL4_MessageInfo_lift_def message_info_to_H_def mask_def
                              msgLengthBits_def word_bw_assocs)
-      apply (wp getMessageInfo_le3 getMessageInfo_msgLength[unfolded K_def] static_imp_wp
+      apply (wp getMessageInfo_le3 getMessageInfo_msgLength[unfolded K_def] hoare_weak_lift_imp
                   | simp)+
      apply (simp add: Collect_const_mem)
      apply (auto simp: excaps_in_mem_def valid_ipc_buffer_ptr'_def
@@ -3843,7 +3843,7 @@ lemma cteDeleteOne_tcbFault:
   apply (wp emptySlot_tcbFault cancelAllIPC_tcbFault getCTE_wp'
             cancelAllSignals_tcbFault unbindNotification_tcbFault
             isFinalCapability_inv unbindMaybeNotification_tcbFault
-            static_imp_wp
+            hoare_weak_lift_imp
           | wpc | simp add: Let_def)+
   apply (clarsimp split: if_split)
   done
@@ -4017,7 +4017,7 @@ proof -
               apply (wp sts_running_valid_queues setThreadState_st_tcb | simp)+
              apply (ctac add: setThreadState_ccorres_valid_queues'_simple)
              apply wp
-            apply ((wp threadSet_valid_queues threadSet_sch_act threadSet_valid_queues' static_imp_wp
+            apply ((wp threadSet_valid_queues threadSet_sch_act threadSet_valid_queues' hoare_weak_lift_imp
                        threadSet_valid_objs' threadSet_weak_sch_act_wf
                          | simp add: valid_tcb_state'_def)+)[1]
            apply (clarsimp simp: guard_is_UNIV_def ThreadState_Restart_def
@@ -4552,12 +4552,12 @@ lemma sendIPC_enqueue_ccorres_helper:
    apply (simp add: cendpoint_relation_def Let_def)
    apply (case_tac ep, simp_all add: init_def valid_ep'_def)[1]
   apply (subgoal_tac "sym_refs (state_refs_of' (\<sigma>\<lparr>ksPSpace :=
-                          ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (SendEP queue))\<rparr>))")
+                          (ksPSpace \<sigma>)(epptr \<mapsto> KOEndpoint (SendEP queue))\<rparr>))")
    prefer 2
    apply (clarsimp simp: state_refs_of'_upd ko_wp_at'_def
                          obj_at'_def projectKOs objBitsKO_def)
   apply (subgoal_tac "ko_at' (SendEP queue) epptr (\<sigma>\<lparr>ksPSpace :=
-                          ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (SendEP queue))\<rparr>)")
+                          (ksPSpace \<sigma>)(epptr \<mapsto> KOEndpoint (SendEP queue))\<rparr>)")
    prefer 2
    apply (clarsimp simp: obj_at'_def projectKOs objBitsKO_def ps_clear_upd)
   apply (intro conjI impI allI)
@@ -4948,12 +4948,12 @@ lemma receiveIPC_enqueue_ccorres_helper:
    apply (simp add: cendpoint_relation_def Let_def)
    apply (case_tac ep, simp_all add: init_def valid_ep'_def)[1]
   apply (subgoal_tac "sym_refs (state_refs_of' (\<sigma>\<lparr>ksPSpace :=
-                          ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (RecvEP queue))\<rparr>))")
+                          (ksPSpace \<sigma>)(epptr \<mapsto> KOEndpoint (RecvEP queue))\<rparr>))")
    prefer 2
    apply (clarsimp simp: state_refs_of'_upd ko_wp_at'_def
                          obj_at'_def projectKOs objBitsKO_def)
   apply (subgoal_tac "ko_at' (RecvEP queue) epptr (\<sigma>\<lparr>ksPSpace :=
-                          ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (RecvEP queue))\<rparr>)")
+                          (ksPSpace \<sigma>)(epptr \<mapsto> KOEndpoint (RecvEP queue))\<rparr>)")
    prefer 2
    apply (clarsimp simp: obj_at'_def projectKOs objBitsKO_def ps_clear_upd)
   apply (intro conjI impI allI)
@@ -5948,16 +5948,17 @@ lemma cpspace_relation_ntfn_update_ntfn':
   fixes ntfn :: "Structures_H.notification" and ntfn' :: "Structures_H.notification"
     and ntfnptr :: "word32" and s :: "kernel_state"
   defines "qs \<equiv> if isWaitingNtfn (ntfnObj ntfn') then set (ntfnQueue (ntfnObj ntfn')) else {}"
-  defines "s' \<equiv> s\<lparr>ksPSpace := ksPSpace s(ntfnptr \<mapsto> KONotification ntfn')\<rparr>"
+  defines "s' \<equiv> s\<lparr>ksPSpace := (ksPSpace s)(ntfnptr \<mapsto> KONotification ntfn')\<rparr>"
   assumes koat: "ko_at' ntfn ntfnptr s"
   and       vp: "valid_pspace' s"
   and      cp: "cmap_relation (map_to_ntfns (ksPSpace s)) (cslift t) Ptr (cnotification_relation (cslift t))"
   and      srs: "sym_refs (state_refs_of' s')"
   and     rel: "cnotification_relation (cslift t') ntfn' notification"
   and    mpeq: "(cslift t' |` (- (tcb_ptr_to_ctcb_ptr ` qs))) = (cslift t |` (- (tcb_ptr_to_ctcb_ptr ` qs)))"
-  shows "cmap_relation (map_to_ntfns (ksPSpace s(ntfnptr \<mapsto> KONotification ntfn')))
-           (cslift t(Ptr ntfnptr \<mapsto> notification)) Ptr
-            (cnotification_relation (cslift t'))"
+  shows "cmap_relation (map_to_ntfns ((ksPSpace s)(ntfnptr \<mapsto> KONotification ntfn')))
+                       ((cslift t)(Ptr ntfnptr \<mapsto> notification))
+                       Ptr
+                       (cnotification_relation (cslift t'))"
 proof -
   from koat have koat': "ko_at' ntfn' ntfnptr s'"
     by (clarsimp simp: obj_at'_def s'_def objBitsKO_def ps_clear_def projectKOs)
@@ -6035,12 +6036,12 @@ lemma receiveSignal_enqueue_ccorres_helper:
    apply (simp add: cnotification_relation_def Let_def)
    apply (case_tac "ntfnObj ntfn", simp_all add: init_def valid_ntfn'_def)[1]
   apply (subgoal_tac "sym_refs (state_refs_of' (\<sigma>\<lparr>ksPSpace :=
-                          ksPSpace \<sigma>(ntfnptr \<mapsto> KONotification (NTFN (WaitingNtfn queue) (ntfnBoundTCB ntfn)))\<rparr>))")
+                               (ksPSpace \<sigma>)(ntfnptr \<mapsto> KONotification (NTFN (WaitingNtfn queue) (ntfnBoundTCB ntfn)))\<rparr>))")
    prefer 2
    apply (clarsimp simp: state_refs_of'_upd ko_wp_at'_def ntfnBound_state_refs_equivalence
                          obj_at'_def projectKOs objBitsKO_def)
   apply (subgoal_tac "ko_at' (NTFN (WaitingNtfn queue) (ntfnBoundTCB ntfn)) ntfnptr (\<sigma>\<lparr>ksPSpace :=
-                          ksPSpace \<sigma>(ntfnptr \<mapsto> KONotification (NTFN (WaitingNtfn queue) (ntfnBoundTCB ntfn)))\<rparr>)")
+                             (ksPSpace \<sigma>)(ntfnptr \<mapsto> KONotification (NTFN (WaitingNtfn queue) (ntfnBoundTCB ntfn)))\<rparr>)")
    prefer 2
    apply (clarsimp simp: obj_at'_def projectKOs objBitsKO_def ps_clear_upd)
   apply (intro conjI impI allI)

proof/crefine/ARM/PSpace_C.thy

@@ -49,7 +49,7 @@ lemma setObject_ccorres_helper:
   fixes ko :: "'a :: pspace_storable"
   assumes valid: "\<And>\<sigma> (ko' :: 'a).
         \<Gamma> \<turnstile> {s. (\<sigma>, s) \<in> rf_sr \<and> P \<sigma> \<and> s \<in> P' \<and> ko_at' ko' p \<sigma>}
-              c {s. (\<sigma>\<lparr>ksPSpace := ksPSpace \<sigma> (p \<mapsto> injectKO ko)\<rparr>, s) \<in> rf_sr}"
+              c {s. (\<sigma>\<lparr>ksPSpace := (ksPSpace \<sigma>)(p \<mapsto> injectKO ko)\<rparr>, s) \<in> rf_sr}"
   shows "\<lbrakk> \<And>ko :: 'a. updateObject ko = updateObject_default ko;
            \<And>ko :: 'a. (1 :: word32) < 2 ^ objBits ko \<rbrakk>
     \<Longrightarrow> ccorres dc xfdc P P' hs (setObject p ko) c"

proof/crefine/ARM/Recycle_C.thy

@@ -230,7 +230,7 @@ lemma mapM_x_store_memset_ccorres_assist:
               "\<And>ko :: 'a. (1 :: word32) < 2 ^ objBits ko"
   assumes restr: "set slots \<subseteq> S"
   assumes worker: "\<And>ptr s s' (ko :: 'a). \<lbrakk> (s, s') \<in> rf_sr; ko_at' ko ptr s; ptr \<in> S \<rbrakk>
-                                \<Longrightarrow> (s \<lparr> ksPSpace := ksPSpace s (ptr \<mapsto> injectKO val)\<rparr>,
+                                \<Longrightarrow> (s \<lparr> ksPSpace := (ksPSpace s)(ptr \<mapsto> injectKO val)\<rparr>,
                                      globals_update (t_hrs_'_update (hrs_mem_update
                                                     (heap_update_list ptr
                                                     (replicateHider (2 ^ objBits val) (ucast c))))) s') \<in> rf_sr"
@@ -484,8 +484,8 @@ lemma cpspace_relation_ep_update_ep2:
            (cslift t) ep_Ptr (cendpoint_relation (cslift t));
       cendpoint_relation (cslift t') ep' endpoint;
       (cslift t' :: tcb_C ptr \<rightharpoonup> tcb_C) = cslift t \<rbrakk>
-     \<Longrightarrow> cmap_relation (map_to_eps (ksPSpace s(epptr \<mapsto> KOEndpoint ep')))
-          (cslift t(ep_Ptr epptr \<mapsto> endpoint))
+     \<Longrightarrow> cmap_relation (map_to_eps ((ksPSpace s)(epptr \<mapsto> KOEndpoint ep')))
+          ((cslift t)(ep_Ptr epptr \<mapsto> endpoint))
           ep_Ptr (cendpoint_relation (cslift t'))"
   apply (rule cmap_relationE1, assumption, erule ko_at_projectKO_opt)
   apply (rule_tac P="\<lambda>a. cmap_relation a b c d" for b c d in rsubst,

proof/crefine/ARM/Refine_C.thy

@@ -663,7 +663,7 @@ lemma threadSet_all_invs_triv':
       apply (simp add: tcb_cte_cases_def)
      apply (simp add: exst_same_def)
     apply (wp thread_set_invs_trivial thread_set_ct_running thread_set_not_state_valid_sched
-              threadSet_invs_trivial threadSet_ct_running' static_imp_wp
+              threadSet_invs_trivial threadSet_ct_running' hoare_weak_lift_imp
               thread_set_ct_in_state
            | simp add: tcb_cap_cases_def tcb_arch_ref_def
            | rule threadSet_ct_in_state'

proof/crefine/ARM/Retype_C.thy

@@ -4777,7 +4777,7 @@ lemma gsCNodes_update_ccorres:
 
 (* FIXME: move *)
 lemma map_to_tcbs_upd:
-  "map_to_tcbs (ksPSpace s(t \<mapsto> KOTCB tcb')) = map_to_tcbs (ksPSpace s)(t \<mapsto> tcb')"
+  "map_to_tcbs ((ksPSpace s)(t \<mapsto> KOTCB tcb')) = (map_to_tcbs (ksPSpace s))(t \<mapsto> tcb')"
   apply (rule ext)
   apply (clarsimp simp: map_comp_def projectKOs split: option.splits if_splits)
   done
@@ -6947,9 +6947,9 @@ shows  "ccorres dc xfdc
        including no_pre
        apply (wp insertNewCap_invs' insertNewCap_valid_pspace' insertNewCap_caps_overlap_reserved'
                  insertNewCap_pspace_no_overlap' insertNewCap_caps_no_overlap'' insertNewCap_descendants_range_in'
-                 insertNewCap_untypedRange hoare_vcg_all_lift insertNewCap_cte_at static_imp_wp)
+                 insertNewCap_untypedRange hoare_vcg_all_lift insertNewCap_cte_at hoare_weak_lift_imp)
          apply (wp insertNewCap_cte_wp_at_other)
-        apply (wp hoare_vcg_all_lift static_imp_wp insertNewCap_cte_at)
+        apply (wp hoare_vcg_all_lift hoare_weak_lift_imp insertNewCap_cte_at)
        apply (clarsimp simp:conj_comms |
          strengthen invs_valid_pspace' invs_pspace_aligned'
          invs_pspace_distinct')+
@@ -6983,7 +6983,7 @@ shows  "ccorres dc xfdc
                   hoare_vcg_prop createObject_gsCNodes_p createObject_cnodes_have_size)
         apply (rule hoare_vcg_conj_lift[OF createObject_capRange_helper])
          apply (wp createObject_cte_wp_at' createObject_ex_cte_cap_wp_to
-                   createObject_no_inter[where sz = sz] hoare_vcg_all_lift static_imp_wp)+
+                   createObject_no_inter[where sz = sz] hoare_vcg_all_lift hoare_weak_lift_imp)+
        apply (clarsimp simp:invs_pspace_aligned' invs_pspace_distinct' invs_valid_pspace'
          field_simps range_cover.sz conj_comms range_cover.aligned range_cover_sz'
          is_aligned_shiftl_self aligned_add_aligned[OF range_cover.aligned])

proof/crefine/ARM/SR_lemmas_C.thy

@@ -309,15 +309,15 @@ lemma tcb_cte_cases_proj_eq [simp]:
   by (auto split: if_split_asm)
 
 lemma map_to_ctes_upd_tcb':
-  "[| ksPSpace s p = Some (KOTCB tcb'); is_aligned p tcbBlockSizeBits;
-   ps_clear p tcbBlockSizeBits s |]
-==> map_to_ctes (ksPSpace s(p |-> KOTCB tcb)) =
-    (%x. if EX getF setF.
+  "\<lbrakk> ksPSpace s p = Some (KOTCB tcb'); is_aligned p tcbBlockSizeBits;
+     ps_clear p tcbBlockSizeBits s \<rbrakk>
+   \<Longrightarrow> map_to_ctes ((ksPSpace s)(p \<mapsto> KOTCB tcb)) =
+       (\<lambda>x. if EX getF setF.
                tcb_cte_cases (x - p) = Some (getF, setF) &
-               getF tcb ~= getF tcb'
-         then case tcb_cte_cases (x - p) of
-              Some (getF, setF) => Some (getF tcb)
-         else ctes_of s x)"
+               getF tcb \<noteq> getF tcb'
+            then case tcb_cte_cases (x - p) of
+               Some (getF, setF) \<Rightarrow> Some (getF tcb)
+            else ctes_of s x)"
   apply (erule (1) map_to_ctes_upd_tcb)
   apply (simp add: field_simps ps_clear_def3 mask_def objBits_defs)
   done
@@ -431,18 +431,19 @@ qed
 lemma fst_setCTE:
   assumes ct: "cte_at' dest s"
   and     rl: "\<And>s'. \<lbrakk> ((), s') \<in> fst (setCTE dest cte s);
-           (s' = s \<lparr> ksPSpace := ksPSpace s' \<rparr>);
-           (ctes_of s' = ctes_of s(dest \<mapsto> cte));
-           (map_to_eps (ksPSpace s) = map_to_eps (ksPSpace s'));
-           (map_to_ntfns (ksPSpace s) = map_to_ntfns (ksPSpace s'));
-           (map_to_pdes (ksPSpace s) = map_to_pdes (ksPSpace s'));
-           (map_to_ptes (ksPSpace s) = map_to_ptes (ksPSpace s'));
-           (map_to_asidpools (ksPSpace s) = map_to_asidpools (ksPSpace s'));
-           (map_to_user_data (ksPSpace s) = map_to_user_data (ksPSpace s'));
-           (map_to_user_data_device (ksPSpace s) = map_to_user_data_device (ksPSpace s'));
-           (map_option tcb_no_ctes_proj \<circ> map_to_tcbs (ksPSpace s)
-              = map_option tcb_no_ctes_proj \<circ> map_to_tcbs (ksPSpace s'));
-           \<forall>T p. typ_at' T p s = typ_at' T p s'\<rbrakk> \<Longrightarrow> P"
+                       s' = s \<lparr> ksPSpace := ksPSpace s' \<rparr>;
+                       ctes_of s' = (ctes_of s)(dest \<mapsto> cte);
+                       map_to_eps (ksPSpace s) = map_to_eps (ksPSpace s');
+                       map_to_ntfns (ksPSpace s) = map_to_ntfns (ksPSpace s');
+                       map_to_pdes (ksPSpace s) = map_to_pdes (ksPSpace s');
+                       map_to_ptes (ksPSpace s) = map_to_ptes (ksPSpace s');
+                       map_to_asidpools (ksPSpace s) = map_to_asidpools (ksPSpace s');
+                       map_to_user_data (ksPSpace s) = map_to_user_data (ksPSpace s');
+                       map_to_user_data_device (ksPSpace s) = map_to_user_data_device (ksPSpace s');
+                       map_option tcb_no_ctes_proj \<circ> map_to_tcbs (ksPSpace s)
+                         = map_option tcb_no_ctes_proj \<circ> map_to_tcbs (ksPSpace s');
+                       \<forall>T p. typ_at' T p s = typ_at' T p s'\<rbrakk>
+                     \<Longrightarrow> P"
   shows   "P"
 proof -
   from fst_setCTE0 [where cte = cte, OF ct]
@@ -458,7 +459,7 @@ proof -
     by clarsimp
   note thms = this
 
-  have ceq: "ctes_of s' = ctes_of s(dest \<mapsto> cte)"
+  have ceq: "ctes_of s' = (ctes_of s)(dest \<mapsto> cte)"
     by (rule use_valid [OF thms(1) setCTE_ctes_of_wp]) simp
 
   show ?thesis
@@ -1406,7 +1407,7 @@ lemma ntfnQueue_tail_mask_4 [simp]:
 
 lemma map_to_ctes_upd_tcb_no_ctes:
   "\<lbrakk>ko_at' tcb thread s ; \<forall>x\<in>ran tcb_cte_cases. (\<lambda>(getF, setF). getF tcb' = getF tcb) x \<rbrakk>
-  \<Longrightarrow> map_to_ctes (ksPSpace s(thread \<mapsto> KOTCB tcb')) = map_to_ctes (ksPSpace s)"
+  \<Longrightarrow> map_to_ctes ((ksPSpace s)(thread \<mapsto> KOTCB tcb')) = map_to_ctes (ksPSpace s)"
   apply (erule obj_atE')
   apply (simp add: projectKOs objBits_simps)
   apply (subst map_to_ctes_upd_tcb')
@@ -1420,14 +1421,14 @@ lemma map_to_ctes_upd_tcb_no_ctes:
 lemma update_ntfn_map_tos:
   fixes P :: "Structures_H.notification \<Rightarrow> bool"
   assumes at: "obj_at' P p s"
-  shows   "map_to_eps (ksPSpace s(p \<mapsto> KONotification ko)) = map_to_eps (ksPSpace s)"
-  and     "map_to_tcbs (ksPSpace s(p \<mapsto> KONotification ko)) = map_to_tcbs (ksPSpace s)"
-  and     "map_to_ctes (ksPSpace s(p \<mapsto> KONotification ko)) = map_to_ctes (ksPSpace s)"
-  and     "map_to_pdes (ksPSpace s(p \<mapsto> KONotification ko)) = map_to_pdes (ksPSpace s)"
-  and     "map_to_ptes (ksPSpace s(p \<mapsto> KONotification ko)) = map_to_ptes (ksPSpace s)"
-  and     "map_to_asidpools (ksPSpace s(p \<mapsto> KONotification ko)) = map_to_asidpools (ksPSpace s)"
-  and     "map_to_user_data (ksPSpace s(p \<mapsto> KONotification ko)) = map_to_user_data (ksPSpace s)"
-  and     "map_to_user_data_device (ksPSpace s(p \<mapsto> KONotification ko)) = map_to_user_data_device (ksPSpace s)"
+  shows   "map_to_eps ((ksPSpace s)(p \<mapsto> KONotification ko)) = map_to_eps (ksPSpace s)"
+  and     "map_to_tcbs ((ksPSpace s)(p \<mapsto> KONotification ko)) = map_to_tcbs (ksPSpace s)"
+  and     "map_to_ctes ((ksPSpace s)(p \<mapsto> KONotification ko)) = map_to_ctes (ksPSpace s)"
+  and     "map_to_pdes ((ksPSpace s)(p \<mapsto> KONotification ko)) = map_to_pdes (ksPSpace s)"
+  and     "map_to_ptes ((ksPSpace s)(p \<mapsto> KONotification ko)) = map_to_ptes (ksPSpace s)"
+  and     "map_to_asidpools ((ksPSpace s)(p \<mapsto> KONotification ko)) = map_to_asidpools (ksPSpace s)"
+  and     "map_to_user_data ((ksPSpace s)(p \<mapsto> KONotification ko)) = map_to_user_data (ksPSpace s)"
+  and     "map_to_user_data_device ((ksPSpace s)(p \<mapsto> KONotification ko)) = map_to_user_data_device (ksPSpace s)"
   using at
   by (auto elim!: obj_atE' intro!: map_to_ctes_upd_other map_comp_eqI
     simp: projectKOs projectKO_opts_defs split: kernel_object.splits if_split_asm)+
@@ -1435,14 +1436,14 @@ lemma update_ntfn_map_tos:
 lemma update_ep_map_tos:
   fixes P :: "endpoint \<Rightarrow> bool"
   assumes at: "obj_at' P p s"
-  shows   "map_to_ntfns (ksPSpace s(p \<mapsto> KOEndpoint ko)) = map_to_ntfns (ksPSpace s)"
-  and     "map_to_tcbs (ksPSpace s(p \<mapsto> KOEndpoint ko)) = map_to_tcbs (ksPSpace s)"
-  and     "map_to_ctes (ksPSpace s(p \<mapsto> KOEndpoint ko)) = map_to_ctes (ksPSpace s)"
-  and     "map_to_pdes (ksPSpace s(p \<mapsto> KOEndpoint ko)) = map_to_pdes (ksPSpace s)"
-  and     "map_to_ptes (ksPSpace s(p \<mapsto> KOEndpoint ko)) = map_to_ptes (ksPSpace s)"
-  and     "map_to_asidpools (ksPSpace s(p \<mapsto> KOEndpoint ko)) = map_to_asidpools (ksPSpace s)"
-  and     "map_to_user_data (ksPSpace s(p \<mapsto> KOEndpoint ko)) = map_to_user_data (ksPSpace s)"
-  and     "map_to_user_data_device (ksPSpace s(p \<mapsto> KOEndpoint ko)) = map_to_user_data_device (ksPSpace s)"
+  shows   "map_to_ntfns ((ksPSpace s)(p \<mapsto> KOEndpoint ko)) = map_to_ntfns (ksPSpace s)"
+  and     "map_to_tcbs ((ksPSpace s)(p \<mapsto> KOEndpoint ko)) = map_to_tcbs (ksPSpace s)"
+  and     "map_to_ctes ((ksPSpace s)(p \<mapsto> KOEndpoint ko)) = map_to_ctes (ksPSpace s)"
+  and     "map_to_pdes ((ksPSpace s)(p \<mapsto> KOEndpoint ko)) = map_to_pdes (ksPSpace s)"
+  and     "map_to_ptes ((ksPSpace s)(p \<mapsto> KOEndpoint ko)) = map_to_ptes (ksPSpace s)"
+  and     "map_to_asidpools ((ksPSpace s)(p \<mapsto> KOEndpoint ko)) = map_to_asidpools (ksPSpace s)"
+  and     "map_to_user_data ((ksPSpace s)(p \<mapsto> KOEndpoint ko)) = map_to_user_data (ksPSpace s)"
+  and     "map_to_user_data_device ((ksPSpace s)(p \<mapsto> KOEndpoint ko)) = map_to_user_data_device (ksPSpace s)"
   using at
   by (auto elim!: obj_atE' intro!: map_to_ctes_upd_other map_comp_eqI
     simp: projectKOs projectKO_opts_defs split: kernel_object.splits if_split_asm)+
@@ -1450,13 +1451,13 @@ lemma update_ep_map_tos:
 lemma update_tcb_map_tos:
   fixes P :: "tcb \<Rightarrow> bool"
   assumes at: "obj_at' P p s"
-  shows   "map_to_eps (ksPSpace s(p \<mapsto> KOTCB ko)) = map_to_eps (ksPSpace s)"
-  and     "map_to_ntfns (ksPSpace s(p \<mapsto> KOTCB ko)) = map_to_ntfns (ksPSpace s)"
-  and     "map_to_pdes (ksPSpace s(p \<mapsto> KOTCB ko)) = map_to_pdes (ksPSpace s)"
-  and     "map_to_ptes (ksPSpace s(p \<mapsto> KOTCB ko)) = map_to_ptes (ksPSpace s)"
-  and     "map_to_asidpools (ksPSpace s(p \<mapsto> KOTCB ko)) = map_to_asidpools (ksPSpace s)"
-  and     "map_to_user_data (ksPSpace s(p \<mapsto> KOTCB ko)) = map_to_user_data (ksPSpace s)"
-  and     "map_to_user_data_device (ksPSpace s(p \<mapsto> KOTCB ko)) = map_to_user_data_device (ksPSpace s)"
+  shows   "map_to_eps ((ksPSpace s)(p \<mapsto> KOTCB ko)) = map_to_eps (ksPSpace s)"
+  and     "map_to_ntfns ((ksPSpace s)(p \<mapsto> KOTCB ko)) = map_to_ntfns (ksPSpace s)"
+  and     "map_to_pdes ((ksPSpace s)(p \<mapsto> KOTCB ko)) = map_to_pdes (ksPSpace s)"
+  and     "map_to_ptes ((ksPSpace s)(p \<mapsto> KOTCB ko)) = map_to_ptes (ksPSpace s)"
+  and     "map_to_asidpools ((ksPSpace s)(p \<mapsto> KOTCB ko)) = map_to_asidpools (ksPSpace s)"
+  and     "map_to_user_data ((ksPSpace s)(p \<mapsto> KOTCB ko)) = map_to_user_data (ksPSpace s)"
+  and     "map_to_user_data_device ((ksPSpace s)(p \<mapsto> KOTCB ko)) = map_to_user_data_device (ksPSpace s)"
   using at
   by (auto elim!: obj_atE' intro!: map_to_ctes_upd_other map_comp_eqI
     simp: projectKOs projectKO_opts_defs split: kernel_object.splits if_split_asm)+
@@ -1464,14 +1465,14 @@ lemma update_tcb_map_tos:
 lemma update_asidpool_map_tos:
   fixes P :: "asidpool \<Rightarrow> bool"
   assumes at: "obj_at' P p s"
-  shows   "map_to_ntfns (ksPSpace s(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_ntfns (ksPSpace s)"
-  and     "map_to_tcbs (ksPSpace s(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_tcbs (ksPSpace s)"
-  and     "map_to_ctes (ksPSpace s(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_ctes (ksPSpace s)"
-  and     "map_to_pdes (ksPSpace s(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_pdes (ksPSpace s)"
-  and     "map_to_ptes (ksPSpace s(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_ptes (ksPSpace s)"
-  and     "map_to_eps  (ksPSpace s(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_eps (ksPSpace s)"
-  and     "map_to_user_data (ksPSpace s(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_user_data (ksPSpace s)"
-  and     "map_to_user_data_device (ksPSpace s(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_user_data_device (ksPSpace s)"
+  shows   "map_to_ntfns ((ksPSpace s)(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_ntfns (ksPSpace s)"
+  and     "map_to_tcbs ((ksPSpace s)(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_tcbs (ksPSpace s)"
+  and     "map_to_ctes ((ksPSpace s)(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_ctes (ksPSpace s)"
+  and     "map_to_pdes ((ksPSpace s)(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_pdes (ksPSpace s)"
+  and     "map_to_ptes ((ksPSpace s)(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_ptes (ksPSpace s)"
+  and     "map_to_eps  ((ksPSpace s)(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_eps (ksPSpace s)"
+  and     "map_to_user_data ((ksPSpace s)(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_user_data (ksPSpace s)"
+  and     "map_to_user_data_device ((ksPSpace s)(p \<mapsto> KOArch (KOASIDPool ap))) = map_to_user_data_device (ksPSpace s)"
 
   using at
   by (auto elim!: obj_atE' intro!: map_to_ctes_upd_other map_comp_eqI
@@ -1480,26 +1481,26 @@ lemma update_asidpool_map_tos:
             arch_kernel_object.split_asm)
 
 lemma update_asidpool_map_to_asidpools:
-  "map_to_asidpools (ksPSpace s(p \<mapsto> KOArch (KOASIDPool ap)))
+  "map_to_asidpools ((ksPSpace s)(p \<mapsto> KOArch (KOASIDPool ap)))
              = (map_to_asidpools (ksPSpace s))(p \<mapsto> ap)"
   by (rule ext, clarsimp simp: projectKOs map_comp_def split: if_split)
 
 lemma update_pte_map_to_ptes:
-  "map_to_ptes (ksPSpace s(p \<mapsto> KOArch (KOPTE pte)))
+  "map_to_ptes ((ksPSpace s)(p \<mapsto> KOArch (KOPTE pte)))
              = (map_to_ptes (ksPSpace s))(p \<mapsto> pte)"
   by (rule ext, clarsimp simp: projectKOs map_comp_def split: if_split)
 
 lemma update_pte_map_tos:
   fixes P :: "pte \<Rightarrow> bool"
   assumes at: "obj_at' P p s"
-  shows   "map_to_ntfns (ksPSpace s(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_ntfns (ksPSpace s)"
-  and     "map_to_tcbs (ksPSpace s(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_tcbs (ksPSpace s)"
-  and     "map_to_ctes (ksPSpace s(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_ctes (ksPSpace s)"
-  and     "map_to_pdes (ksPSpace s(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_pdes (ksPSpace s)"
-  and     "map_to_eps  (ksPSpace s(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_eps (ksPSpace s)"
-  and     "map_to_asidpools (ksPSpace s(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_asidpools (ksPSpace s)"
-  and     "map_to_user_data (ksPSpace s(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_user_data (ksPSpace s)"
-  and     "map_to_user_data_device (ksPSpace s(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_user_data_device (ksPSpace s)"
+  shows   "map_to_ntfns ((ksPSpace s)(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_ntfns (ksPSpace s)"
+  and     "map_to_tcbs ((ksPSpace s)(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_tcbs (ksPSpace s)"
+  and     "map_to_ctes ((ksPSpace s)(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_ctes (ksPSpace s)"
+  and     "map_to_pdes ((ksPSpace s)(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_pdes (ksPSpace s)"
+  and     "map_to_eps  ((ksPSpace s)(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_eps (ksPSpace s)"
+  and     "map_to_asidpools ((ksPSpace s)(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_asidpools (ksPSpace s)"
+  and     "map_to_user_data ((ksPSpace s)(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_user_data (ksPSpace s)"
+  and     "map_to_user_data_device ((ksPSpace s)(p \<mapsto> (KOArch (KOPTE pte)))) = map_to_user_data_device (ksPSpace s)"
   using at
   by (auto elim!: obj_atE' intro!: map_comp_eqI map_to_ctes_upd_other
            split: if_split_asm if_split
@@ -1507,21 +1508,21 @@ lemma update_pte_map_tos:
        auto simp: projectKO_opts_defs)
 
 lemma update_pde_map_to_pdes:
-  "map_to_pdes (ksPSpace s(p \<mapsto> KOArch (KOPDE pde)))
+  "map_to_pdes ((ksPSpace s)(p \<mapsto> KOArch (KOPDE pde)))
              = (map_to_pdes (ksPSpace s))(p \<mapsto> pde)"
   by (rule ext, clarsimp simp: projectKOs map_comp_def split: if_split)
 
 lemma update_pde_map_tos:
   fixes P :: "pde \<Rightarrow> bool"
   assumes at: "obj_at' P p s"
-  shows   "map_to_ntfns (ksPSpace s(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_ntfns (ksPSpace s)"
-  and     "map_to_tcbs (ksPSpace s(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_tcbs (ksPSpace s)"
-  and     "map_to_ctes (ksPSpace s(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_ctes (ksPSpace s)"
-  and     "map_to_ptes (ksPSpace s(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_ptes (ksPSpace s)"
-  and     "map_to_eps  (ksPSpace s(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_eps (ksPSpace s)"
-  and     "map_to_asidpools (ksPSpace s(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_asidpools (ksPSpace s)"
-  and     "map_to_user_data (ksPSpace s(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_user_data (ksPSpace s)"
-  and     "map_to_user_data_device (ksPSpace s(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_user_data_device (ksPSpace s)"
+  shows   "map_to_ntfns ((ksPSpace s)(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_ntfns (ksPSpace s)"
+  and     "map_to_tcbs ((ksPSpace s)(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_tcbs (ksPSpace s)"
+  and     "map_to_ctes ((ksPSpace s)(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_ctes (ksPSpace s)"
+  and     "map_to_ptes ((ksPSpace s)(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_ptes (ksPSpace s)"
+  and     "map_to_eps  ((ksPSpace s)(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_eps (ksPSpace s)"
+  and     "map_to_asidpools ((ksPSpace s)(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_asidpools (ksPSpace s)"
+  and     "map_to_user_data ((ksPSpace s)(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_user_data (ksPSpace s)"
+  and     "map_to_user_data_device ((ksPSpace s)(p \<mapsto> (KOArch (KOPDE pde)))) = map_to_user_data_device (ksPSpace s)"
   using at
   by (auto elim!: obj_atE' intro!: map_comp_eqI map_to_ctes_upd_other
            split: if_split_asm if_split

proof/crefine/ARM/Schedule_C.thy

@@ -630,7 +630,7 @@ lemma schedule_ccorres:
 
 (* FIXME: move *)
 lemma map_to_tcbs_upd:
-  "map_to_tcbs (ksPSpace s(t \<mapsto> KOTCB tcb')) = map_to_tcbs (ksPSpace s)(t \<mapsto> tcb')"
+  "map_to_tcbs ((ksPSpace s)(t \<mapsto> KOTCB tcb')) = (map_to_tcbs (ksPSpace s))(t \<mapsto> tcb')"
   apply (rule ext)
   apply (clarsimp simp: map_comp_def projectKOs split: option.splits if_splits)
   done

proof/crefine/ARM/SyscallArgs_C.thy

@@ -47,7 +47,7 @@ lemma replyOnRestart_invs'[wp]:
   "\<lbrace>invs'\<rbrace> replyOnRestart thread reply isCall \<lbrace>\<lambda>rv. invs'\<rbrace>"
   including no_pre
   apply (simp add: replyOnRestart_def)
-  apply (wp setThreadState_nonqueued_state_update rfk_invs' static_imp_wp)
+  apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_weak_lift_imp)
   apply (rule hoare_vcg_all_lift)
   apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_vcg_all_lift rfk_ksQ)
    apply (rule hoare_strengthen_post, rule gts_sp')
@@ -631,7 +631,7 @@ lemma getMRs_tcbContext:
   apply (wp|wpc)+
     apply (rule_tac P="n < length x" in hoare_gen_asm)
     apply (clarsimp simp: nth_append)
-    apply (wp mapM_wp' static_imp_wp)+
+    apply (wp mapM_wp' hoare_weak_lift_imp)+
     apply simp
     apply (rule asUser_cur_obj_at')
     apply (simp add: getRegister_def msgRegisters_unfold)
@@ -1051,7 +1051,7 @@ lemma getMRs_rel:
   getMRs thread buffer mi \<lbrace>\<lambda>args. getMRs_rel args buffer\<rbrace>"
   apply (simp add: getMRs_rel_def)
   apply (rule hoare_pre)
-   apply (rule_tac x=mi in hoare_vcg_exI)
+   apply (rule_tac x=mi in hoare_exI)
    apply wp
    apply (rule_tac Q="\<lambda>rv s. thread = ksCurThread s \<and> fst (getMRs thread buffer mi s) = {(rv,s)}" in hoare_strengthen_post)
     apply (wp det_result det_wp_getMRs)

proof/crefine/ARM/TcbAcc_C.thy

@@ -110,7 +110,7 @@ lemma threadSet_corres_lemma:
   assumes spec: "\<forall>s. \<Gamma>\<turnstile> \<lbrace>s. P s\<rbrace> Call f {t. Q s t}"
   and      mod: "modifies_heap_spec f"
   and  rl: "\<And>\<sigma> x t ko. \<lbrakk>(\<sigma>, x) \<in> rf_sr; Q x t; x \<in> P'; ko_at' ko thread \<sigma>\<rbrakk>
-             \<Longrightarrow> (\<sigma>\<lparr>ksPSpace := ksPSpace \<sigma>(thread \<mapsto> KOTCB (g ko))\<rparr>,
+             \<Longrightarrow> (\<sigma>\<lparr>ksPSpace := (ksPSpace \<sigma>)(thread \<mapsto> KOTCB (g ko))\<rparr>,
                   t\<lparr>globals := globals x\<lparr>t_hrs_' := t_hrs_' (globals t)\<rparr>\<rparr>) \<in> rf_sr"
   and  g:  "\<And>s x. \<lbrakk>tcb_at' thread s; x \<in> P'; (s, x) \<in> rf_sr\<rbrakk> \<Longrightarrow> P x"
   shows "ccorres dc xfdc (tcb_at' thread) P' [] (threadSet g thread) (Call f)"
@@ -139,7 +139,7 @@ lemma threadSet_corres_lemma:
 
 
 lemma threadSet_ccorres_lemma4:
-  "\<lbrakk> \<And>s tcb. \<Gamma> \<turnstile> (Q s tcb) c {s'. (s \<lparr>ksPSpace := ksPSpace s(thread \<mapsto> injectKOS (F tcb))\<rparr>, s') \<in> rf_sr};
+  "\<lbrakk> \<And>s tcb. \<Gamma> \<turnstile> (Q s tcb) c {s'. (s \<lparr>ksPSpace := (ksPSpace s)(thread \<mapsto> injectKOS (F tcb))\<rparr>, s') \<in> rf_sr};
           \<And>s s' tcb tcb'. \<lbrakk> (s, s') \<in> rf_sr; P tcb; ko_at' tcb thread s;
                              cslift s' (tcb_ptr_to_ctcb_ptr thread) = Some tcb';
                              ctcb_relation tcb tcb'; P' s ; s' \<in> R\<rbrakk> \<Longrightarrow> s' \<in> Q s tcb \<rbrakk>

proof/crefine/ARM/TcbQueue_C.thy

@@ -970,8 +970,8 @@ lemma cpspace_relation_ntfn_update_ntfn:
   and      cp: "cpspace_ntfn_relation (ksPSpace s) (t_hrs_' (globals t))"
   and     rel: "cnotification_relation (cslift t') ntfn' notification"
   and    mpeq: "(cslift t' |` (- (tcb_ptr_to_ctcb_ptr ` qs))) = (cslift t |` (- (tcb_ptr_to_ctcb_ptr ` qs)))"
-  shows "cmap_relation (map_to_ntfns (ksPSpace s(ntfnptr \<mapsto> KONotification ntfn')))
-           (cslift t(Ptr ntfnptr \<mapsto> notification)) Ptr (cnotification_relation (cslift t'))"
+  shows "cmap_relation (map_to_ntfns ((ksPSpace s)(ntfnptr \<mapsto> KONotification ntfn')))
+           ((cslift t)(Ptr ntfnptr \<mapsto> notification)) Ptr (cnotification_relation (cslift t'))"
   using koat invs cp rel
   apply -
   apply (subst map_comp_update)
@@ -1059,7 +1059,7 @@ lemma rf_sr_tcb_update_no_queue:
   (\<forall>x\<in>ran tcb_cte_cases. (\<lambda>(getF, setF). getF tcb' = getF tcb) x);
   ctcb_relation tcb' ctcb
   \<rbrakk>
-  \<Longrightarrow> (s\<lparr>ksPSpace := ksPSpace s(thread \<mapsto> KOTCB tcb')\<rparr>, x\<lparr>globals := globals s'\<lparr>t_hrs_' := t_hrs_' (globals t)\<rparr>\<rparr>) \<in> rf_sr"
+  \<Longrightarrow> (s\<lparr>ksPSpace := (ksPSpace s)(thread \<mapsto> KOTCB tcb')\<rparr>, x\<lparr>globals := globals s'\<lparr>t_hrs_' := t_hrs_' (globals t)\<rparr>\<rparr>) \<in> rf_sr"
   unfolding rf_sr_def state_relation_def cstate_relation_def cpspace_relation_def
   apply (clarsimp simp: Let_def update_tcb_map_tos map_to_ctes_upd_tcb_no_ctes
                         heap_to_user_data_def)
@@ -1108,7 +1108,7 @@ lemma rf_sr_tcb_update_not_in_queue:
     \<not> live' (KOTCB tcb); invs' s;
     (\<forall>x\<in>ran tcb_cte_cases. (\<lambda>(getF, setF). getF tcb' = getF tcb) x);
     ctcb_relation tcb' ctcb \<rbrakk>
-     \<Longrightarrow> (s\<lparr>ksPSpace := ksPSpace s(thread \<mapsto> KOTCB tcb')\<rparr>,
+     \<Longrightarrow> (s\<lparr>ksPSpace := (ksPSpace s)(thread \<mapsto> KOTCB tcb')\<rparr>,
            x\<lparr>globals := globals s'\<lparr>t_hrs_' := t_hrs_' (globals t)\<rparr>\<rparr>) \<in> rf_sr"
   unfolding rf_sr_def state_relation_def cstate_relation_def cpspace_relation_def
   apply (clarsimp simp: Let_def update_tcb_map_tos map_to_ctes_upd_tcb_no_ctes

proof/crefine/ARM/Tcb_C.thy

@@ -72,8 +72,8 @@ begin
 lemma getObject_state:
   " \<lbrakk>(x, s') \<in> fst (getObject t' s); ko_at' ko t s\<rbrakk>
   \<Longrightarrow> (if t = t' then tcbState_update (\<lambda>_. st) x else x,
-      s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>)
-      \<in> fst (getObject t' (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
+      s'\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>)
+      \<in> fst (getObject t' (s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
   apply (simp split: if_split)
   apply (rule conjI)
    apply clarsimp
@@ -131,8 +131,8 @@ lemma getObject_state:
 
 lemma threadGet_state:
   "\<lbrakk> (uc, s') \<in> fst (threadGet (atcbContextGet o tcbArch) t' s); ko_at' ko t s \<rbrakk> \<Longrightarrow>
-   (uc, s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>) \<in>
-  fst (threadGet (atcbContextGet o tcbArch) t' (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
+   (uc, s'\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>) \<in>
+  fst (threadGet (atcbContextGet o tcbArch) t' (s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
   apply (clarsimp simp: threadGet_def liftM_def in_monad)
   apply (drule (1) getObject_state [where st=st])
   apply (rule exI)
@@ -142,8 +142,8 @@ lemma threadGet_state:
 
 lemma asUser_state:
   "\<lbrakk>(x,s) \<in> fst (asUser t' f s); ko_at' ko t s; \<And>s. \<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>_. (=) s\<rbrace> \<rbrakk> \<Longrightarrow>
-  (x,s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>) \<in>
-  fst (asUser t' f (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
+  (x,s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>) \<in>
+  fst (asUser t' f (s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
   apply (clarsimp simp: asUser_def in_monad select_f_def)
   apply (frule use_valid, rule threadGet_inv [where P="(=) s"], rule refl)
   apply (frule use_valid, assumption, rule refl)
@@ -240,8 +240,8 @@ lemma asUser_state:
 
 lemma doMachineOp_state:
   "(rv,s') \<in> fst (doMachineOp f s) \<Longrightarrow>
-  (rv,s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>)
-  \<in> fst (doMachineOp f (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
+  (rv,s'\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>)
+  \<in> fst (doMachineOp f (s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
   apply (clarsimp simp: doMachineOp_def split_def in_monad select_f_def)
   apply fastforce
   done
@@ -274,7 +274,7 @@ lemma getMRs_rel_state:
   "\<lbrakk>getMRs_rel args buffer s;
     (cur_tcb' and case_option \<top> valid_ipc_buffer_ptr' buffer) s;
     ko_at' ko t s \<rbrakk> \<Longrightarrow>
-  getMRs_rel args buffer (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>)"
+  getMRs_rel args buffer (s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>)"
   apply (clarsimp simp: getMRs_rel_def)
   apply (rule exI, erule conjI)
   apply (subst (asm) det_wp_use, rule det_wp_getMRs)
@@ -606,7 +606,7 @@ lemma invokeTCB_ThreadControl_ccorres:
                             apply (rule ccorres_return_CE, simp+)[1]
                            apply (wp (once))
                           apply (clarsimp simp: guard_is_UNIV_def)
-                         apply (wpsimp wp: when_def static_imp_wp)
+                         apply (wpsimp wp: when_def hoare_weak_lift_imp)
                           apply (strengthen sch_act_wf_weak, wp)
                          apply clarsimp
                          apply wp
@@ -620,7 +620,7 @@ lemma invokeTCB_ThreadControl_ccorres:
                                                    tcb_at' target s \<and> ksCurDomain s \<le> maxDomain \<and>
                                                    valid_queues' s \<and>  fst (the priority) \<le> maxPriority)"])
                         apply (strengthen sch_act_wf_weak)
-                        apply (wp static_imp_wp)
+                        apply (wp hoare_weak_lift_imp)
                        apply (clarsimp split: if_splits)
                       apply (wp empty_fail_stateAssert hoare_case_option_wp | simp del: Collect_const)+
                    apply csymbr
@@ -645,7 +645,7 @@ lemma invokeTCB_ThreadControl_ccorres:
                       apply wp
                      apply (clarsimp simp: guard_is_UNIV_def)
                     apply (simp add: when_def)
-                    apply (wp hoare_vcg_if_lift2(1) static_imp_wp, strengthen sch_act_wf_weak; wp)
+                    apply (wp hoare_vcg_if_lift2(1) hoare_weak_lift_imp, strengthen sch_act_wf_weak; wp)
                    apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
                   apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem
                                         tcbBuffer_def size_of_def cte_level_bits_def
@@ -671,7 +671,7 @@ lemma invokeTCB_ThreadControl_ccorres:
                      apply (rule ccorres_return_CE, simp+)
                     apply wp
                    apply (clarsimp simp: guard_is_UNIV_def)
-                  apply (wp hoare_vcg_if_lift2(1) static_imp_wp, strengthen sch_act_wf_weak; wp)
+                  apply (wp hoare_vcg_if_lift2(1) hoare_weak_lift_imp, strengthen sch_act_wf_weak; wp)
                  apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
                 apply (simp add: guard_is_UNIV_def Collect_const_mem)
                 apply (clarsimp simp: ccap_relation_def cap_thread_cap_lift cap_to_H_def)
@@ -698,7 +698,7 @@ lemma invokeTCB_ThreadControl_ccorres:
                   apply wp
                  apply (clarsimp simp: guard_is_UNIV_def)
                 apply wpsimp
-                 apply (wp static_imp_wp, strengthen sch_act_wf_weak, wp )
+                 apply (wp hoare_weak_lift_imp, strengthen sch_act_wf_weak, wp )
                 apply wp
                apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
               apply (simp cong: conj_cong)
@@ -736,7 +736,7 @@ lemma invokeTCB_ThreadControl_ccorres:
                             simp add: o_def)
               apply (rule_tac P="is_aligned (fst (the buf)) msg_align_bits"
                        in hoare_gen_asm)
-              apply (wp threadSet_ipcbuffer_trivial static_imp_wp
+              apply (wp threadSet_ipcbuffer_trivial hoare_weak_lift_imp
                      | simp
                      | strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf  invs_queues
                                   invs_valid_queues' | wp hoare_drop_imps)+
@@ -893,13 +893,13 @@ lemma invokeTCB_ThreadControl_ccorres:
       apply (simp add: conj_comms)
       apply (wp hoare_case_option_wp threadSet_invs_trivial setMCPriority_invs'
                 typ_at_lifts[OF setMCPriority_typ_at']
-                threadSet_cap_to' static_imp_wp | simp)+
+                threadSet_cap_to' hoare_weak_lift_imp | simp)+
      apply (clarsimp simp: guard_is_UNIV_def tcbCTableSlot_def Kernel_C.tcbCTable_def
                            cte_level_bits_def size_of_def word_sle_def option_to_0_def
                            cintr_def Collect_const_mem)
     apply (simp add: conj_comms)
     apply (wp hoare_case_option_wp threadSet_invs_trivial
-              threadSet_cap_to' static_imp_wp | simp)+
+              threadSet_cap_to' hoare_weak_lift_imp | simp)+
    apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
   apply (clarsimp simp: inQ_def)
   apply (subst is_aligned_neg_mask_eq)
@@ -1207,8 +1207,8 @@ lemma invokeTCB_WriteRegisters_ccorres_helper:
 
 lemma doMachineOp_context:
   "(rv,s') \<in> fst (doMachineOp f s) \<Longrightarrow>
-  (rv,s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>)
-  \<in> fst (doMachineOp f (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>))"
+  (rv,s'\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>)
+  \<in> fst (doMachineOp f (s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>))"
   apply (clarsimp simp: doMachineOp_def split_def in_monad select_f_def)
   apply fastforce
   done
@@ -1217,8 +1217,8 @@ lemma doMachineOp_context:
 lemma getObject_context:
   " \<lbrakk>(x, s') \<in> fst (getObject t' s); ko_at' ko t s\<rbrakk>
   \<Longrightarrow> (if t = t' then tcbContext_update (\<lambda>_. st) x else x,
-      s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>)
-      \<in> fst (getObject t' (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>))"
+      s'\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>)
+      \<in> fst (getObject t' (s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>))"
   apply (simp split: if_split)
   apply (rule conjI)
    apply clarsimp
@@ -1277,8 +1277,8 @@ lemma getObject_context:
 lemma threadGet_context:
   "\<lbrakk> (uc, s') \<in> fst (threadGet (atcbContextGet o tcbArch) (ksCurThread s) s); ko_at' ko t s;
       t \<noteq> ksCurThread s \<rbrakk> \<Longrightarrow>
-   (uc, s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>) \<in>
-  fst (threadGet (atcbContextGet o tcbArch) (ksCurThread s) (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>))"
+   (uc, s'\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>) \<in>
+  fst (threadGet (atcbContextGet o tcbArch) (ksCurThread s) (s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>))"
   apply (clarsimp simp: threadGet_def liftM_def in_monad)
   apply (drule (1) getObject_context [where st=st])
   apply (rule exI)
@@ -1290,8 +1290,8 @@ done
 lemma asUser_context:
   "\<lbrakk>(x,s) \<in> fst (asUser (ksCurThread s) f s); ko_at' ko t s; \<And>s. \<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>_. (=) s\<rbrace> ;
     t \<noteq> ksCurThread s\<rbrakk> \<Longrightarrow>
-  (x,s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>) \<in>
-  fst (asUser (ksCurThread s) f (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>))"
+  (x,s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>) \<in>
+  fst (asUser (ksCurThread s) f (s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>))"
   apply (clarsimp simp: asUser_def in_monad select_f_def)
   apply (frule use_valid, rule threadGet_inv [where P="(=) s"], rule refl)
   apply (frule use_valid, assumption, rule refl)
@@ -1362,7 +1362,7 @@ lemma getMRs_rel_context:
   "\<lbrakk>getMRs_rel args buffer s;
     (cur_tcb' and case_option \<top> valid_ipc_buffer_ptr' buffer) s;
     ko_at' ko t s ; t \<noteq> ksCurThread s\<rbrakk> \<Longrightarrow>
-  getMRs_rel args buffer (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>)"
+  getMRs_rel args buffer (s\<lparr>ksPSpace := (ksPSpace s)(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>)"
   apply (clarsimp simp: getMRs_rel_def)
   apply (rule exI, erule conjI)
   apply (subst (asm) det_wp_use, rule det_wp_getMRs)
@@ -1439,7 +1439,7 @@ lemma threadSet_same:
   by (wpsimp wp: setObject_tcb_strongest getObject_tcb_wp) fastforce
 
 lemma invokeTCB_WriteRegisters_ccorres[where S=UNIV]:
-  notes static_imp_wp [wp]
+  notes hoare_weak_lift_imp [wp]
   shows
   "ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
    (invs' and tcb_at' dst and ex_nonz_cap_to' dst and sch_act_simple
@@ -2020,14 +2020,14 @@ shows
                                               word_less_nat_alt
                                       split: if_split_asm dest!: word_unat.Rep_inverse')
                        apply (simp add: pred_conj_def)
-                       apply (wp mapM_x_wp' sch_act_wf_lift valid_queues_lift static_imp_wp
+                       apply (wp mapM_x_wp' sch_act_wf_lift valid_queues_lift hoare_weak_lift_imp
                                  tcb_in_cur_domain'_lift)
                       apply (simp add: n_frameRegisters_def n_msgRegisters_def
                                        guard_is_UNIV_def)
                      apply simp
                      apply (rule mapM_x_wp')
                      apply (rule hoare_pre)
-                      apply (wp asUser_obj_at'[where t'=target] static_imp_wp
+                      apply (wp asUser_obj_at'[where t'=target] hoare_weak_lift_imp
                                 asUser_valid_ipc_buffer_ptr')
                      apply clarsimp
                     apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem
@@ -2036,7 +2036,7 @@ shows
                                           msgMaxLength_def msgLengthBits_def
                                           word_less_nat_alt unat_of_nat)
                    apply (wp (once) hoare_drop_imps)
-                   apply (wp asUser_obj_at'[where t'=target] static_imp_wp
+                   apply (wp asUser_obj_at'[where t'=target] hoare_weak_lift_imp
                              asUser_valid_ipc_buffer_ptr')
                   apply (vcg exspec=setRegister_modifies)
                  apply simp
@@ -2056,12 +2056,12 @@ shows
              apply (simp cong: rev_conj_cong)
              apply wp
              apply (wp asUser_inv mapM_wp' getRegister_inv
-                      asUser_get_registers[simplified] static_imp_wp)+
+                      asUser_get_registers[simplified] hoare_weak_lift_imp)+
             apply (rule hoare_strengthen_post, rule asUser_get_registers)
             apply (clarsimp simp: obj_at'_def genericTake_def
                                   frame_gp_registers_convs)
             apply arith
-           apply (wp static_imp_wp)
+           apply (wp hoare_weak_lift_imp)
           apply simp
          apply (rule ccorres_inst[where P=\<top> and P'=UNIV], simp)
         apply (simp add: performTransfer_def)
@@ -4338,7 +4338,7 @@ lemma decodeSetSpace_ccorres:
   done
 
 lemma invokeTCB_SetTLSBase_ccorres:
-  notes static_imp_wp [wp]
+  notes hoare_weak_lift_imp [wp]
   shows
   "ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
    (invs')

proof/crefine/ARM/VSpace_C.thy

@@ -3012,7 +3012,7 @@ lemma flushTable_ccorres:
         apply (rule ccorres_pre_getCurThread)
         apply (ctac (no_vcg) add: setVMRoot_ccorres)
        apply (rule ccorres_return_Skip)
-      apply (wp static_imp_wp)
+      apply (wp hoare_weak_lift_imp)
        apply clarsimp
        apply (rule_tac Q="\<lambda>_ s. invs' s \<and> cur_tcb' s" in hoare_post_imp)
         apply (simp add: invs'_invs_no_cicd cur_tcb'_def)

proof/crefine/ARM_HYP/ArchMove_C.thy

@@ -486,7 +486,7 @@ lemma ps_clear_entire_slotI:
   by (fastforce simp: ps_clear_def)
 
 lemma ps_clear_ksPSpace_upd_same[simp]:
-  "ps_clear p n (s\<lparr>ksPSpace := ksPSpace s(p \<mapsto> v)\<rparr>) = ps_clear p n s"
+  "ps_clear p n (s\<lparr>ksPSpace := (ksPSpace s)(p \<mapsto> v)\<rparr>) = ps_clear p n s"
   by (fastforce simp: ps_clear_def)
 
 lemma getObject_vcpu_prop:

proof/crefine/ARM_HYP/CSpace_C.thy

@@ -1073,14 +1073,14 @@ lemma cteInsert_ccorres:
                   apply (rule ccorres_move_c_guard_cte)
                   apply (ctac ccorres:ccorres_updateMDB_set_mdbPrev)
                  apply (ctac ccorres: ccorres_updateMDB_skip)
-                apply (wp static_imp_wp)+
+                apply (wp hoare_weak_lift_imp)+
               apply (clarsimp simp: Collect_const_mem split del: if_split)
               apply vcg
-             apply (wp static_imp_wp)
+             apply (wp hoare_weak_lift_imp)
             apply (clarsimp simp: Collect_const_mem split del: if_split)
             apply vcg
            apply (clarsimp simp:cmdb_node_relation_mdbNext)
-           apply (wp setUntypedCapAsFull_cte_at_wp static_imp_wp)
+           apply (wp setUntypedCapAsFull_cte_at_wp hoare_weak_lift_imp)
           apply (clarsimp simp: Collect_const_mem split del: if_split)
           apply (vcg exspec=setUntypedCapAsFull_modifies)
          apply wp

proof/crefine/ARM_HYP/Delete_C.thy

@@ -867,7 +867,7 @@ lemma finaliseSlot_ccorres:
                apply (simp add: guard_is_UNIV_def)
               apply (simp add: conj_comms)
               apply (wp make_zombie_invs' updateCap_cte_wp_at_cases
-                        updateCap_cap_to' hoare_vcg_disj_lift static_imp_wp)+
+                        updateCap_cap_to' hoare_vcg_disj_lift hoare_weak_lift_imp)+
             apply (simp add: guard_is_UNIV_def)
            apply wp
           apply (simp add: guard_is_UNIV_def)
@@ -896,7 +896,7 @@ lemma finaliseSlot_ccorres:
         apply (erule(1) cmap_relationE1 [OF cmap_relation_cte])
         apply (frule valid_global_refsD_with_objSize, clarsimp)
         apply (auto simp: typ_heap_simps dest!: ccte_relation_ccap_relation)[1]
-       apply (wp isFinalCapability_inv static_imp_wp | wp (once) isFinal[where x=slot'])+
+       apply (wp isFinalCapability_inv hoare_weak_lift_imp | wp (once) isFinal[where x=slot'])+
       apply vcg
      apply (rule conseqPre, vcg)
      apply clarsimp

proof/crefine/ARM_HYP/Detype_C.thy

@@ -1541,7 +1541,7 @@ lemma deleteObjects_ccorres':
   apply (rule allI, rule conseqPre, vcg)
   apply (clarsimp simp: in_monad)
   apply (rule bexI [rotated])
-   apply (rule iffD2 [OF in_monad(20)])
+   apply (rule iffD2 [OF in_monad(21)])
    apply (rule conjI [OF refl refl])
   apply (clarsimp simp: simpler_modify_def)
 proof -

proof/crefine/ARM_HYP/Fastpath_Equiv.thy

@@ -1562,8 +1562,8 @@ lemma fastpath_callKernel_SysReplyRecv_corres:
                                       setThreadState_no_sch_change setThreadState_obj_at_unchanged
                                       sts_st_tcb_at'_cases sts_bound_tcb_at'
                                       fastpathBestSwitchCandidate_lift[where f="setThreadState s t" for s t]
-                                      static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift
-                                      static_imp_wp cnode_caps_gsCNodes_lift
+                                      hoare_weak_lift_imp hoare_vcg_all_lift hoare_vcg_imp_lift
+                                      hoare_weak_lift_imp cnode_caps_gsCNodes_lift
                                       hoare_vcg_ex_lift
                           | wps)+
                            apply (strengthen imp_consequent[where Q="tcb_at' t s" for t s])
@@ -1576,8 +1576,8 @@ lemma fastpath_callKernel_SysReplyRecv_corres:
                                       emptySlot_cnode_caps
                                       user_getreg_inv asUser_typ_ats
                                       asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp'
-                                      static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift
-                                      static_imp_wp cnode_caps_gsCNodes_lift
+                                      hoare_weak_lift_imp hoare_vcg_all_lift hoare_vcg_imp_lift
+                                      hoare_weak_lift_imp cnode_caps_gsCNodes_lift
                                       hoare_vcg_ex_lift
                                       fastpathBestSwitchCandidate_lift[where f="emptySlot a b" for a b]
                                    | simp del: comp_apply
@@ -1588,8 +1588,8 @@ lemma fastpath_callKernel_SysReplyRecv_corres:
                            apply (clarsimp cong: conj_cong)
                            apply ((wp user_getreg_inv asUser_typ_ats
                                       asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp'
-                                      static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift
-                                      static_imp_wp cnode_caps_gsCNodes_lift
+                                      hoare_weak_lift_imp hoare_vcg_all_lift hoare_vcg_imp_lift
+                                      hoare_weak_lift_imp cnode_caps_gsCNodes_lift
                                       hoare_vcg_ex_lift
                                    | clarsimp simp: obj_at'_weakenE[OF _ TrueI]
                                    | solves \<open>