* This software may be distributed and modified according to the terms of
* the BSD 2-Clause license. Note that NO WARRANTY is provided.
* See "LICENSE_BSD2.txt" for details.
*
* @TAG(NICTA_BSD)
*)
theory BCorres_UL
imports "wp/NonDetMonadVCG" Crunch
begin
definition s_bcorres_underlying where
"s_bcorres_underlying t f g s \<equiv> (\<lambda>(x,y). (x, t y)) ` (fst (f s)) \<subseteq> (fst (g (t s)))"
definition bcorres_underlying where
"bcorres_underlying t f g \<equiv> \<forall>s. s_bcorres_underlying t f g s"
lemma wpc_helper_bcorres:
"bcorres_underlying t f g \<Longrightarrow> wpc_helper (P, P') (Q, Q') (bcorres_underlying t f g)"
by (simp add: wpc_helper_def)
lemma wpc_helper_s_bcorres:
"s_bcorres_underlying t f g s \<Longrightarrow> wpc_helper (P, P') (Q, Q') (s_bcorres_underlying t f g s)"
by (simp add: wpc_helper_def)
wpc_setup "\<lambda>f. bcorres_underlying t f g" wpc_helper_bcorres
wpc_setup "\<lambda>f. s_bcorres_underlying t f g s" wpc_helper_bcorres
lemma s_bcorres_underlying_split[wp_split]: "(\<And>r s'. (r,s') \<in> fst (f s) \<Longrightarrow> (s_bcorres_underlying t (g r) (g' r) s')) \<Longrightarrow> s_bcorres_underlying t f f' s \<Longrightarrow> s_bcorres_underlying t (f >>= g) (f' >>= g') s"
apply (simp add: s_bcorres_underlying_def)
apply clarsimp
apply (simp add: bind_def split_def)
apply (simp add: split_def image_def)
apply force
done
lemma bcorres_underlying_split[wp_split]: "(\<And>r. (bcorres_underlying t (g r) (g' r))) \<Longrightarrow> bcorres_underlying t f f' \<Longrightarrow> bcorres_underlying t (f >>= g) (f' >>= g')"
lemma bcorres_underlying_splitE[wp_split]: "(\<And>r. (bcorres_underlying t (g r) (g' r))) \<Longrightarrow> bcorres_underlying t f f' \<Longrightarrow> bcorres_underlying t (f >>=E g) (f' >>=E g')"
lemma returnOk_bcorres_underlying[wp]: "bcorres_underlying t (returnOk x) (returnOk x)"
apply (simp add: returnOk_def)
apply wp
done
lemma whenE_s_bcorres_underlying[wp]: "(P = P' \<Longrightarrow> P \<Longrightarrow> s_bcorres_underlying t f f' s) \<Longrightarrow> P = P' \<Longrightarrow> s_bcorres_underlying t (whenE P f) (whenE P' f') s"
apply (clarsimp simp add: whenE_def)
apply (rule drop_sbcorres_underlying)
apply wp
done
lemma select_s_bcorres_underlying[wp]: "A \<subseteq> B \<Longrightarrow> s_bcorres_underlying t (select A) (select B) s"
lemma when_s_bcorres_underlying[wp]: "(P \<Longrightarrow> s_bcorres_underlying t f f' s) \<Longrightarrow> s_bcorres_underlying t (when P f) (when P f') s"
apply (simp add: when_def)
apply (intro impI conjI)
apply wp
done
lemma when_bcorres_underlying[wp]: "(P \<Longrightarrow> bcorres_underlying t f f') \<Longrightarrow> bcorres_underlying t (when P f) (when P f')"
lemma bcorres_underlying_mapME[wp]: "(\<And>x. bcorres_underlying t (f x) (f' x)) \<Longrightarrow> bcorres_underlying t (mapME f r) (mapME f' r)"
apply (induct r)
apply (simp add: mapME_def sequenceE_def | wp)+
done
lemma handle2_bcorres_underlying[wp]: "bcorres_underlying t f f' \<Longrightarrow> (\<And>x. bcorres_underlying t (g x) (g' x)) \<Longrightarrow> bcorres_underlying t (f <handle2> g) (f' <handle2> g')"
apply (simp add: handleE'_def)
apply (wp | wpc | simp)+
done
lemma liftME_bcorres_underlying[wp]: "bcorres_underlying t f f' \<Longrightarrow> bcorres_underlying t (liftME a f) (liftME a f')"
apply (simp add: liftME_def)
apply (wp | simp)+
done
lemma zipWithM_x_bcorres[wp]: "(\<And>x y. bcorres_underlying t (f x y) (f' x y) ) \<Longrightarrow> bcorres_underlying t (zipWithM_x f xs ys) (zipWithM_x f' xs ys)"
apply (simp add: zipWithM_x_def)
apply (simp add: zipWith_def split_def)
apply (wp | simp)+
done
lemma mapME_x_bcorres_underlying[wp]: "(\<And>x. bcorres_underlying t (f x) (f' x)) \<Longrightarrow> bcorres_underlying t (mapME_x f xs) (mapME_x f' xs)"