548 lines
22 KiB
Plaintext
548 lines
22 KiB
Plaintext
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: BSD-2-Clause
|
|
*)
|
|
|
|
(* A theory of rewriting under refinement. *)
|
|
|
|
theory MonadicRewrite
|
|
imports
|
|
"Monad_WP/NonDetMonadVCG"
|
|
Corres_UL
|
|
EmptyFailLib
|
|
LemmaBucket
|
|
begin
|
|
|
|
definition
|
|
monadic_rewrite :: "bool \<Rightarrow> bool \<Rightarrow> ('a \<Rightarrow> bool)
|
|
\<Rightarrow> ('a, 'b) nondet_monad \<Rightarrow> ('a, 'b) nondet_monad \<Rightarrow> bool"
|
|
where
|
|
"monadic_rewrite F E P f g \<equiv> \<forall>s. P s \<and> (F \<longrightarrow> \<not> snd (f s))
|
|
\<longrightarrow> (E \<longrightarrow> f s = g s)
|
|
\<and> (\<not> E \<longrightarrow> fst (g s) \<subseteq> fst (f s) \<and> (snd (g s) \<longrightarrow> snd (f s)))"
|
|
|
|
|
|
(* FIXME: also in Retype_C *)
|
|
lemma snd_bind:
|
|
"snd ((a >>= b) s) = (snd (a s) \<or> (\<exists>(r, s') \<in> fst (a s). snd (b r s')))"
|
|
by (auto simp add: bind_def split_def)
|
|
|
|
lemma monadic_rewrite_bind:
|
|
"\<lbrakk> monadic_rewrite F E P f g; \<And>x. monadic_rewrite F E (Q x) (h x) (j x);
|
|
\<lbrace>R\<rbrace> g \<lbrace>Q\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (P and R) (f >>= (\<lambda>x. h x)) (g >>= (\<lambda>x. j x))"
|
|
apply (cases E)
|
|
apply (clarsimp simp: monadic_rewrite_def snd_bind imp_conjL)
|
|
apply (drule spec, drule(1) mp, clarsimp)
|
|
apply (rule bind_apply_cong)
|
|
apply simp
|
|
apply (frule(2) use_valid)
|
|
apply fastforce
|
|
apply (clarsimp simp: monadic_rewrite_def snd_bind imp_conjL)
|
|
apply (simp add: bind_def split_def)
|
|
apply (rule conjI)
|
|
apply (rule UN_mono)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (frule(2) use_valid)
|
|
apply fastforce
|
|
apply (rule conjI)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (frule(2) use_valid)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma monadic_rewrite_refl:
|
|
"monadic_rewrite F E \<top> f f"
|
|
by (simp add: monadic_rewrite_def)
|
|
|
|
lemma monadic_rewrite_bindE:
|
|
"\<lbrakk> monadic_rewrite F E P f g; \<And>x. monadic_rewrite F E (Q x) (h x) (j x);
|
|
\<lbrace>R\<rbrace> g \<lbrace>Q\<rbrace>,- \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (P and R) (f >>=E (\<lambda>x. h x)) (g >>=E (\<lambda>x. j x))"
|
|
apply (simp add: bindE_def)
|
|
apply (erule monadic_rewrite_bind)
|
|
defer
|
|
apply (simp add: validE_R_def validE_def)
|
|
apply (case_tac x, simp_all add: lift_def monadic_rewrite_refl)
|
|
done
|
|
|
|
lemma monadic_rewrite_catch:
|
|
"\<lbrakk> monadic_rewrite F E P f g; \<And>x. monadic_rewrite F E (Q x) (h x) (j x);
|
|
\<lbrace>R\<rbrace> g -,\<lbrace>Q\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (P and R) (f <catch> (\<lambda>x. h x)) (g <catch> (\<lambda>x. j x))"
|
|
apply (simp add: catch_def)
|
|
apply (erule monadic_rewrite_bind)
|
|
defer
|
|
apply (simp add: validE_E_def validE_def)
|
|
apply (case_tac x, simp_all add: lift_def monadic_rewrite_refl)
|
|
done
|
|
|
|
lemma monadic_rewrite_symb_exec_pre:
|
|
assumes inv: "\<And>s. \<lbrace>(=) s\<rbrace> g \<lbrace>\<lambda>r. (=) s\<rbrace>"
|
|
and ef: "empty_fail g"
|
|
and rv: "\<lbrace>P\<rbrace> g \<lbrace>\<lambda>y s. y \<in> S\<rbrace>"
|
|
and h': "\<And>y. y \<in> S \<longrightarrow> h y = h'"
|
|
shows "monadic_rewrite True True P (g >>= h) h'"
|
|
proof -
|
|
have P: "\<And>s v. \<lbrakk> P s; v \<in> fst (g s) \<rbrakk> \<Longrightarrow> split h v = h' s"
|
|
apply clarsimp
|
|
apply (frule use_valid[OF _ inv], rule refl)
|
|
apply (frule(1) use_valid[OF _ rv])
|
|
apply (simp add: h')
|
|
done
|
|
|
|
show ?thesis
|
|
apply (clarsimp simp: monadic_rewrite_def bind_def P image_constant_conv
|
|
cong: image_cong)
|
|
apply (drule empty_failD2[OF ef])
|
|
apply (clarsimp simp: prod_eq_iff split: if_split_asm)
|
|
done
|
|
qed
|
|
|
|
lemma monadic_rewrite_trans:
|
|
"\<lbrakk> monadic_rewrite F E P f g; monadic_rewrite F E Q g h \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (P and Q) f h"
|
|
by (auto simp add: monadic_rewrite_def)
|
|
|
|
lemma singleton_eq_imp_helper:
|
|
"v \<in> {x} \<longrightarrow> h v = h x" by simp
|
|
|
|
lemmas monadic_rewrite_symb_exec
|
|
= monadic_rewrite_symb_exec_pre [OF _ _ _ singleton_eq_imp_helper,
|
|
THEN monadic_rewrite_trans,
|
|
simplified]
|
|
|
|
lemma eq_UNIV_imp_helper:
|
|
"v \<in> UNIV \<longrightarrow> x = x" by simp
|
|
|
|
lemmas monadic_rewrite_symb_exec2
|
|
= monadic_rewrite_symb_exec_pre[OF _ _ _ eq_UNIV_imp_helper, where P=\<top>,
|
|
simplified, THEN monadic_rewrite_trans]
|
|
|
|
lemma monadic_rewrite_imp:
|
|
"\<lbrakk> monadic_rewrite F E Q f g; \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> monadic_rewrite F E P f g"
|
|
by (auto simp add: monadic_rewrite_def)
|
|
|
|
lemmas monadic_rewrite_bind_tail
|
|
= monadic_rewrite_bind [OF monadic_rewrite_refl, simplified pred_and_true_var]
|
|
lemmas monadic_rewrite_bind_head
|
|
= monadic_rewrite_bind [OF _ monadic_rewrite_refl hoare_vcg_prop,
|
|
simplified pred_and_true]
|
|
|
|
lemma monadic_rewrite_bind2:
|
|
"\<lbrakk> monadic_rewrite F E P f g; \<And>x. monadic_rewrite F E (Q x) (h x) (j x);
|
|
\<lbrace>R\<rbrace> f \<lbrace>Q\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (P and R) (f >>= (\<lambda>x. h x)) (g >>= (\<lambda>x. j x))"
|
|
apply (rule monadic_rewrite_imp)
|
|
apply (rule monadic_rewrite_trans)
|
|
apply (erule(1) monadic_rewrite_bind_tail)
|
|
apply (erule monadic_rewrite_bind_head)
|
|
apply simp
|
|
done
|
|
|
|
lemma monadic_rewrite_if:
|
|
"\<lbrakk> P \<Longrightarrow> monadic_rewrite F E Q a c; \<not> P \<Longrightarrow> monadic_rewrite F E R b d \<rbrakk> \<Longrightarrow>
|
|
monadic_rewrite F E (\<lambda>s. (P \<longrightarrow> Q s) \<and> (\<not> P \<longrightarrow> R s))
|
|
(If P a b) (If P c d)"
|
|
by (cases P, simp_all)
|
|
|
|
lemma monadic_rewrite_liftM:
|
|
"monadic_rewrite F E P f g \<Longrightarrow> monadic_rewrite F E P (liftM fn f) (liftM fn g)"
|
|
apply (simp add: liftM_def)
|
|
apply (erule monadic_rewrite_bind_head)
|
|
done
|
|
|
|
lemmas monadic_rewrite_liftE
|
|
= monadic_rewrite_liftM[where fn=Inr, folded liftE_liftM]
|
|
|
|
lemma monadic_rewrite_from_simple:
|
|
"P \<longrightarrow> f = g \<Longrightarrow> monadic_rewrite F E (\<lambda>_. P) f g"
|
|
by (simp add: monadic_rewrite_def)
|
|
|
|
lemma monadic_rewrite_gen_asm:
|
|
"\<lbrakk> P \<Longrightarrow> monadic_rewrite F E Q f g \<rbrakk> \<Longrightarrow> monadic_rewrite F E ((\<lambda>_. P) and Q) f g"
|
|
by (auto simp add: monadic_rewrite_def)
|
|
|
|
lemma monadic_rewrite_assert:
|
|
"\<lbrakk> Q \<Longrightarrow> monadic_rewrite True E P (f ()) g \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite True E (\<lambda>s. Q \<longrightarrow> P s) (assert Q >>= f) g"
|
|
apply (simp add: assert_def split: if_split)
|
|
apply (simp add: monadic_rewrite_def fail_def)
|
|
done
|
|
|
|
lemma monadic_rewrite_drop_modify:
|
|
"monadic_rewrite F E (\<lambda>s. f s = s) (modify f >>= v) (v ())"
|
|
by (simp add: monadic_rewrite_def bind_def simpler_modify_def)
|
|
|
|
lemma monadic_rewrite_symb_exec_r:
|
|
"\<lbrakk> \<And>s. \<lbrace>(=) s\<rbrace> m \<lbrace>\<lambda>r. (=) s\<rbrace>; no_fail P' m;
|
|
\<And>rv. monadic_rewrite F False (Q rv) x (y rv);
|
|
\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F False (P and P') x (m >>= y)"
|
|
apply (clarsimp simp: monadic_rewrite_def bind_def)
|
|
apply (drule(1) no_failD)
|
|
apply (subgoal_tac "\<forall>v \<in> fst (m s). Q (fst v) (snd v) \<and> snd v = s")
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (frule(2) use_valid)
|
|
apply (frule use_valid, assumption, rule refl)
|
|
apply simp
|
|
done
|
|
|
|
lemma monadic_rewrite_symb_exec_r':
|
|
"\<lbrakk> \<And>s. \<lbrace>(=) s\<rbrace> m \<lbrace>\<lambda>r. (=) s\<rbrace>; no_fail P m;
|
|
\<And>rv. monadic_rewrite F False (Q rv) x (y rv);
|
|
\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F False P x (m >>= y)"
|
|
apply (rule monadic_rewrite_imp)
|
|
apply (rule monadic_rewrite_symb_exec_r; assumption)
|
|
apply simp
|
|
done
|
|
|
|
lemma monadic_rewrite_symb_exec_l'':
|
|
"\<lbrakk> \<And>s. \<lbrace>(=) s\<rbrace> m \<lbrace>\<lambda>r. (=) s\<rbrace>; empty_fail m;
|
|
\<not> F \<longrightarrow> no_fail P' m;
|
|
\<And>rv. monadic_rewrite F False (Q rv) (x rv) y;
|
|
\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F False (P and P') (m >>= x) y"
|
|
apply (clarsimp simp: monadic_rewrite_def bind_def)
|
|
apply (subgoal_tac "\<not> snd (m s)")
|
|
apply (subgoal_tac "\<forall>v \<in> fst (m s). Q (fst v) (snd v) \<and> snd v = s")
|
|
apply (frule(1) empty_failD2)
|
|
apply (clarsimp simp: split_def)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (frule(2) use_valid)
|
|
apply (frule use_valid, assumption, rule refl)
|
|
apply simp
|
|
apply (cases F, simp_all add: no_failD)
|
|
done
|
|
|
|
lemma monadic_rewrite_symb_exec_l':
|
|
"\<lbrakk> \<And>P. \<lbrace>P\<rbrace> m \<lbrace>\<lambda>r. P\<rbrace>; empty_fail m;
|
|
\<not> F \<longrightarrow> no_fail P' m;
|
|
\<And>rv. monadic_rewrite F E (Q rv) (x rv) y;
|
|
\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (P and P') (m >>= x) y"
|
|
apply (cases E)
|
|
apply (clarsimp simp: monadic_rewrite_def bind_def prod_eq_iff)
|
|
apply (subgoal_tac "\<not> snd (m s)")
|
|
apply (simp add: empty_fail_def, drule_tac x=s in spec)
|
|
apply (subgoal_tac "\<forall>(rv, s') \<in> fst (m s). x rv s' = y s")
|
|
apply (rule conjI)
|
|
apply (rule equalityI)
|
|
apply (clarsimp simp: Ball_def)
|
|
apply (fastforce simp: Ball_def elim!: nonemptyE elim: rev_bexI)
|
|
apply (simp add: Bex_def Ball_def cong: conj_cong)
|
|
apply auto[1]
|
|
apply clarsimp
|
|
apply (drule(1) in_inv_by_hoareD)
|
|
apply (frule(2) use_valid)
|
|
apply (clarsimp simp: Ball_def prod_eq_iff)
|
|
apply (clarsimp simp: no_fail_def)
|
|
apply simp
|
|
apply (rule monadic_rewrite_symb_exec_l'', assumption+)
|
|
done
|
|
|
|
(* FIXME this should replace monadic_rewrite_symb_exec_l' as it preserves names,
|
|
and this approach should be used everywhere else anyhow, however that breaks proofs
|
|
relying on arbitrarily generated names, so will be dealt with in future *)
|
|
lemma monadic_rewrite_symb_exec_l'_preserve_names:
|
|
"\<lbrakk> \<And>P. \<lbrace>P\<rbrace> m \<lbrace>\<lambda>r. P\<rbrace>; empty_fail m;
|
|
\<not> F \<longrightarrow> no_fail P' m;
|
|
\<And>rv. monadic_rewrite F E (Q rv) (x rv) y;
|
|
\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (P and P') (m >>= (\<lambda>rv. x rv)) y"
|
|
by (rule monadic_rewrite_symb_exec_l')
|
|
|
|
(* FIXME merge into below upon change-over desribed above *)
|
|
lemmas monadic_rewrite_symb_exec_l'_TT
|
|
= monadic_rewrite_symb_exec_l'_preserve_names[where P'="\<top>" and F=True, simplified]
|
|
|
|
lemmas monadic_rewrite_symb_exec_l
|
|
= monadic_rewrite_symb_exec_l''[where F=True and P'=\<top>, simplified]
|
|
monadic_rewrite_symb_exec_l''[where F=False, simplified simp_thms]
|
|
|
|
lemma monadic_rewrite_alternative_rhs:
|
|
"\<lbrakk> monadic_rewrite F E P a b; monadic_rewrite F E Q a c \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (P and Q) a (b \<sqinter> c)"
|
|
apply (clarsimp simp: monadic_rewrite_def alternative_def)
|
|
apply auto
|
|
done
|
|
|
|
lemma monadic_rewrite_rdonly_bind:
|
|
"\<lbrakk> \<And>s. \<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>rv. (=) s\<rbrace> \<rbrakk> \<Longrightarrow>
|
|
monadic_rewrite F False \<top>
|
|
(alternative (f >>= (\<lambda>x. g x)) h)
|
|
(f >>= (\<lambda>x. alternative (g x) h))"
|
|
apply (clarsimp simp: monadic_rewrite_def bind_def
|
|
alternative_def imp_conjL)
|
|
apply (subgoal_tac "\<forall>x \<in> fst (f s). snd x = s")
|
|
apply (simp add: image_image split_def cong: image_cong)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (frule use_valid, (assumption | rule refl | simp)+)
|
|
done
|
|
|
|
lemmas monadic_rewrite_rdonly_bind_l
|
|
= monadic_rewrite_trans [OF monadic_rewrite_rdonly_bind]
|
|
|
|
lemma monadic_rewrite_if_rhs:
|
|
"\<lbrakk> P \<Longrightarrow> monadic_rewrite F E Q a b; \<not> P \<Longrightarrow> monadic_rewrite F E R a c \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (\<lambda>s. (P \<longrightarrow> Q s) \<and> (\<not> P \<longrightarrow> R s))
|
|
a (If P b c)"
|
|
by (cases P, simp_all)
|
|
|
|
lemma monadic_rewrite_transverse:
|
|
"\<lbrakk> monadic_rewrite False True Q c b; monadic_rewrite F E P a b \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (P and Q) a c"
|
|
by (auto simp add: monadic_rewrite_def)
|
|
|
|
lemma monadic_rewrite_alternative_l:
|
|
"monadic_rewrite F False \<top> (alternative f g) g"
|
|
by (clarsimp simp: monadic_rewrite_def alternative_def)
|
|
|
|
lemma monadic_rewrite_introduce_alternative:
|
|
"\<lbrakk> f = f'; monadic_rewrite F E P (alternative f' f) g \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E P f g"
|
|
by (simp add: alternative_def)
|
|
|
|
lemma monadic_rewrite_modify_noop:
|
|
"monadic_rewrite F E (\<lambda>s. f s = s) (modify f) (return ())"
|
|
by (clarsimp simp: monadic_rewrite_def simpler_modify_def return_def)
|
|
|
|
lemma monadic_rewrite_split_fn:
|
|
"\<lbrakk> monadic_rewrite F E P (liftM fn a) c;
|
|
\<And>rv. monadic_rewrite F E (Q rv) (b rv) (d (fn rv));
|
|
\<lbrace>R\<rbrace> a \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow>
|
|
monadic_rewrite F E (P and R) (a >>= b) (c >>= d)"
|
|
apply (rule monadic_rewrite_imp)
|
|
apply (rule monadic_rewrite_trans[rotated])
|
|
apply (erule monadic_rewrite_bind_head)
|
|
apply (simp add: liftM_def)
|
|
apply (erule(1) monadic_rewrite_bind_tail)
|
|
apply simp
|
|
done
|
|
|
|
lemma monadic_rewrite_pick_alternative_1:
|
|
"monadic_rewrite F False \<top> (alternative f g) f"
|
|
by (auto simp add: monadic_rewrite_def alternative_def)
|
|
|
|
lemma monadic_rewrite_pick_alternative_2:
|
|
"monadic_rewrite F False \<top> (alternative f g) g"
|
|
by (auto simp add: monadic_rewrite_def alternative_def)
|
|
|
|
lemma monadic_rewrite_weaken:
|
|
"monadic_rewrite (F \<and> F') (E \<or> E') P f g
|
|
\<Longrightarrow> monadic_rewrite F' E' P f g"
|
|
apply (clarsimp simp add: monadic_rewrite_def)
|
|
apply auto
|
|
done
|
|
|
|
lemma monadic_rewrite_is_refl:
|
|
"x = y \<Longrightarrow> monadic_rewrite F E \<top> x y"
|
|
by (simp add: monadic_rewrite_refl)
|
|
|
|
lemma monadic_rewrite_refl3:
|
|
"[| !!s. P s ==> f s = g s |] ==> monadic_rewrite F E P f g"
|
|
by (simp add: monadic_rewrite_def)
|
|
|
|
lemmas monadic_rewrite_refl2 = monadic_rewrite_refl3[where P=\<top>]
|
|
|
|
lemma monadic_rewrite_cases:
|
|
"\<lbrakk> P \<Longrightarrow> monadic_rewrite F E Q a b; \<not> P \<Longrightarrow> monadic_rewrite F E R a b \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (\<lambda>s. (P \<longrightarrow> Q s) \<and> (\<not> P \<longrightarrow> R s)) a b"
|
|
by (cases P, simp_all)
|
|
|
|
lemma monadic_rewrite_symb_exec_l_known:
|
|
"\<lbrakk> \<And>s. \<lbrace>(=) s\<rbrace> m \<lbrace>\<lambda>r. (=) s\<rbrace>; empty_fail m;
|
|
monadic_rewrite True False Q (x rv) y; \<lbrace>P\<rbrace> m \<lbrace>\<lambda>rv' s. rv' = rv \<and> Q s\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite True False P (m >>= x) y"
|
|
apply (erule(1) monadic_rewrite_symb_exec_l)
|
|
apply (rule_tac P="rva = rv" in monadic_rewrite_gen_asm)
|
|
apply simp
|
|
apply (erule hoare_strengthen_post)
|
|
apply simp
|
|
done
|
|
|
|
lemma monadic_rewrite_gets_the_known_v:
|
|
"monadic_rewrite F E (\<lambda>s. f s = Some v)
|
|
(gets_the f) (return v)"
|
|
by (simp add: monadic_rewrite_def gets_the_def
|
|
exec_gets assert_opt_def)
|
|
|
|
lemma monadic_rewrite_gets_the_walk:
|
|
"\<lbrakk> \<And>x. monadic_rewrite True False (P x) (g x) (gets_the pf >>= g' x);
|
|
\<And>Q. \<lbrace>\<lambda>s. Q (pf s)\<rbrace> f \<lbrace>\<lambda>rv s. Q (pf s)\<rbrace>; \<lbrace>R\<rbrace> f \<lbrace>P\<rbrace>; empty_fail f \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite True False R
|
|
(f >>= g)
|
|
(do v \<leftarrow> gets_the pf; x \<leftarrow> f; g' x v od)"
|
|
apply (rule monadic_rewrite_imp)
|
|
apply (rule monadic_rewrite_trans)
|
|
apply (erule(1) monadic_rewrite_bind_tail)
|
|
apply (simp add: gets_the_def bind_assoc)
|
|
apply (rule monadic_rewrite_symb_exec_r, wp+)
|
|
apply (rule monadic_rewrite_trans)
|
|
apply (rule monadic_rewrite_bind_tail)
|
|
apply (rule_tac rv=rv in monadic_rewrite_symb_exec_l_known,
|
|
(wp empty_fail_gets)+)
|
|
apply (rule monadic_rewrite_refl)
|
|
apply wp
|
|
apply assumption
|
|
apply (rule_tac P="rv = None" in monadic_rewrite_cases[where Q=\<top>])
|
|
apply (simp add: assert_opt_def)
|
|
apply (clarsimp simp: monadic_rewrite_def fail_def snd_bind)
|
|
apply (rule ccontr, drule(1) empty_failD2)
|
|
apply clarsimp
|
|
apply (simp add: assert_opt_def case_option_If2)
|
|
apply (rule monadic_rewrite_refl)
|
|
apply wp
|
|
apply simp
|
|
done
|
|
|
|
lemma monadic_rewrite_alternatives:
|
|
"\<lbrakk> monadic_rewrite E F P a c; monadic_rewrite E F Q b d \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite E F (P and Q) (a \<sqinter> b) (c \<sqinter> d)"
|
|
by (auto simp: monadic_rewrite_def alternative_def)
|
|
|
|
lemma monadic_rewrite_weaken2:
|
|
"monadic_rewrite F E P f g
|
|
\<Longrightarrow> monadic_rewrite F' E' ((\<lambda>_. (F \<longrightarrow> F') \<and> (E' \<longrightarrow> E)) and P) f g"
|
|
apply (rule monadic_rewrite_gen_asm)
|
|
apply (rule monadic_rewrite_weaken[where F=F and E=E])
|
|
apply auto
|
|
done
|
|
|
|
lemma monadic_rewrite_case_sum:
|
|
"\<lbrakk> \<And>v. x = Inl v \<Longrightarrow> monadic_rewrite F E (P v) (a v) (c v);
|
|
\<And>v. x = Inr v \<Longrightarrow> monadic_rewrite F E (Q v) (b v) (d v) \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (\<lambda>s. (\<not> isRight x \<longrightarrow> P (theLeft x) s) \<and> (isRight x \<longrightarrow> Q (theRight x) s))
|
|
(case_sum a b x) (case_sum c d x)"
|
|
by (cases x, simp_all add: isRight_def)
|
|
|
|
lemma monadic_rewrite_add_gets:
|
|
"monadic_rewrite F E \<top> m (gets f >>= (\<lambda>_. m))"
|
|
by (simp add: monadic_rewrite_def exec_gets)
|
|
|
|
lemma monadic_rewrite_add_assert:
|
|
"monadic_rewrite F E (\<lambda>s. P) m (assert P >>= (\<lambda>_. m))"
|
|
by (simp add: monadic_rewrite_def)
|
|
|
|
lemma monadic_rewrite_gets_known:
|
|
"monadic_rewrite F E (\<lambda>s. f s = rv) (gets f >>= m) (m rv)"
|
|
by (simp add: monadic_rewrite_def exec_gets)
|
|
|
|
lemma monadic_rewrite_name_pre:
|
|
"\<lbrakk> \<And>s. P s \<Longrightarrow> monadic_rewrite F E ((=) s) f g \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E P f g"
|
|
by (auto simp add: monadic_rewrite_def)
|
|
|
|
lemma monadic_rewrite_named_bindE:
|
|
"\<lbrakk> monadic_rewrite F E ((=) s) f f';
|
|
\<And>rv s'. (Inr rv, s') \<in> fst (f' s)
|
|
\<Longrightarrow> monadic_rewrite F E ((=) s') (g rv) (g' rv) \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E ((=) s) (f >>=E (\<lambda>rv. g rv)) (f' >>=E g')"
|
|
apply (rule monadic_rewrite_imp)
|
|
apply (erule_tac R="(=) s" and Q="\<lambda>rv s'. (Inr rv, s') \<in> fst (f' s)" in monadic_rewrite_bindE)
|
|
apply (rule monadic_rewrite_name_pre)
|
|
apply clarsimp
|
|
apply (clarsimp simp add: validE_R_def validE_def valid_def
|
|
split: sum.split)
|
|
apply simp
|
|
done
|
|
|
|
lemmas monadic_rewrite_named_if
|
|
= monadic_rewrite_if[where Q="(=) s" and R="(=) s", simplified] for s
|
|
|
|
lemma monadic_rewrite_if_lhs:
|
|
"\<lbrakk> P \<Longrightarrow> monadic_rewrite F E Q b a; \<not> P \<Longrightarrow> monadic_rewrite F E R c a \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E (\<lambda>s. (P \<longrightarrow> Q s) \<and> (\<not> P \<longrightarrow> R s))
|
|
(If P b c) a"
|
|
by (cases P, simp_all)
|
|
|
|
lemma monadic_rewrite_to_eq:
|
|
"monadic_rewrite False True \<top> f g ==> f = g"
|
|
by (simp add: monadic_rewrite_def fun_eq_iff)
|
|
|
|
lemma corres_underlyingI:
|
|
assumes rv: "\<And>s t rv' t'. \<lbrakk>(s, t) \<in> R; P s; P' t; (rv', t') \<in> fst (c t)\<rbrakk> \<Longrightarrow> \<exists>(rv, s') \<in> fst (a s). (s', t') \<in> R \<and> r rv rv'"
|
|
and nf: "\<And>s t. \<lbrakk>(s, t) \<in> R; P s; P' t; nf'\<rbrakk> \<Longrightarrow> \<not> snd (c t)"
|
|
shows "corres_underlying R nf nf' r P P' a c"
|
|
unfolding corres_underlying_def using rv nf by (auto simp: split_def)
|
|
|
|
lemma corres_underlyingE:
|
|
assumes cul: "corres_underlying R nf nf' r P P' a c"
|
|
and xin: "(s, t) \<in> R" "P s" "P' t" "(rv', t') \<in> fst (c t)"
|
|
and rl: "\<And>s' rv. \<lbrakk>nf' \<longrightarrow> \<not> snd (c t); (rv, s') \<in> fst (a s); (s', t') \<in> R; r rv rv'\<rbrakk> \<Longrightarrow> Q"
|
|
and nf: "nf \<longrightarrow> \<not> snd (a s)"
|
|
shows "Q"
|
|
using cul xin nf
|
|
unfolding corres_underlying_def by (fastforce simp: split_def intro: rl)
|
|
|
|
(* Above here is generic *)
|
|
lemma monadic_rewrite_corres:
|
|
assumes cu: "corres_underlying R False nf' r P P' a' c"
|
|
and me: "monadic_rewrite False True Q a a'"
|
|
shows "corres_underlying R False nf' r (P and Q) P' a c"
|
|
proof (rule corres_underlyingI)
|
|
fix s t rv' t'
|
|
assume st: "(s, t) \<in> R" and pq: "(P and Q) s" and pt: "P' t" and ct: "(rv', t') \<in> fst (c t)"
|
|
from pq have Ps: "P s" and Qs: "Q s" by simp_all
|
|
|
|
from cu st Ps pt ct obtain s' rv where
|
|
as': "(rv, s') \<in> fst (a' s)" and rest: "nf' \<longrightarrow> \<not> snd (c t)" "(s', t') \<in> R" "r rv rv'"
|
|
by (fastforce elim: corres_underlyingE)
|
|
|
|
from me st Qs as' have as: "(rv, s') \<in> fst (a s)"
|
|
by (clarsimp simp: monadic_rewrite_def)
|
|
|
|
with rest show "\<exists>(rv, s')\<in>fst (a s). (s', t') \<in> R \<and> r rv rv'" by auto
|
|
next
|
|
fix s t
|
|
assume "(s, t) \<in> R" "(P and Q) s" "P' t" "nf'"
|
|
thus "\<not> snd (c t)" using cu
|
|
by (fastforce simp: corres_underlying_def split_def)
|
|
qed
|
|
|
|
lemma monadic_rewrite_refine_valid:
|
|
"monadic_rewrite F E P f g
|
|
\<Longrightarrow> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>
|
|
\<Longrightarrow> F \<longrightarrow> no_fail P'' f
|
|
\<Longrightarrow> \<lbrace>P and P' and P''\<rbrace> g \<lbrace>Q\<rbrace>"
|
|
apply (clarsimp simp: monadic_rewrite_def valid_def no_fail_def imp_conjL)
|
|
apply (drule spec, drule(1) mp)+
|
|
apply (clarsimp simp: Ball_def)
|
|
apply auto
|
|
done
|
|
|
|
lemma monadic_rewrite_refine_validE_R:
|
|
"monadic_rewrite F E P f g
|
|
\<Longrightarrow> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>, -
|
|
\<Longrightarrow> F \<longrightarrow> no_fail P'' f
|
|
\<Longrightarrow> \<lbrace>P and P' and P''\<rbrace> g \<lbrace>Q\<rbrace>, -"
|
|
by (simp add: validE_R_def validE_def monadic_rewrite_refine_valid)
|
|
|
|
lemma wpc_helper_monadic_rewrite:
|
|
"monadic_rewrite F E Q' m m'
|
|
\<Longrightarrow> wpc_helper (P, P') (Q, {s. Q' s}) (monadic_rewrite F E (\<lambda>s. s \<in> P') m m')"
|
|
apply (clarsimp simp: wpc_helper_def)
|
|
apply (erule monadic_rewrite_imp)
|
|
apply auto
|
|
done
|
|
|
|
lemma monadic_rewrite_trans_dup:
|
|
"\<lbrakk> monadic_rewrite F E P f g; monadic_rewrite F E P g h \<rbrakk>
|
|
\<Longrightarrow> monadic_rewrite F E P f h"
|
|
by (auto simp add: monadic_rewrite_def)
|
|
|
|
lemmas monadic_rewrite_bind_alt
|
|
= monadic_rewrite_trans[OF monadic_rewrite_bind_tail monadic_rewrite_bind_head, rotated -1]
|
|
|
|
wpc_setup "\<lambda>m. monadic_rewrite F E Q' m m'" wpc_helper_monadic_rewrite
|
|
wpc_setup "\<lambda>m. monadic_rewrite F E Q' (m >>= c) m'" wpc_helper_monadic_rewrite
|
|
|
|
end
|