lib: apply consistent style to OptionMonad
Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
This commit is contained in:
parent
ed0cd5b282
commit
12c9c2bc21
|
@ -18,19 +18,29 @@ theory OptionMonad (* FIXME: this is really a Reader_Option_Monad *)
|
|||
Less_Monad_Syntax
|
||||
begin
|
||||
|
||||
section \<open>Projections\<close>
|
||||
|
||||
type_synonym ('s,'a) lookup = "'s \<Rightarrow> 'a option"
|
||||
|
||||
text \<open>Similar to map_option but the second function returns option as well\<close>
|
||||
definition
|
||||
opt_map :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> ('s,'b) lookup" (infixl "|>" 54)
|
||||
where
|
||||
definition opt_map :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> ('s,'b) lookup" (infixl "|>" 54) where
|
||||
"f |> g \<equiv> \<lambda>s. case f s of None \<Rightarrow> None | Some x \<Rightarrow> g x"
|
||||
|
||||
abbreviation opt_map_Some :: "('s \<rightharpoonup> 'a) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 's \<rightharpoonup> 'b" (infixl "||>" 54) where
|
||||
"f ||> g \<equiv> f |> (Some \<circ> g)"
|
||||
|
||||
lemmas opt_map_Some_def = opt_map_def
|
||||
|
||||
lemma opt_map_cong [fundef_cong]:
|
||||
definition map_set :: "('a \<Rightarrow> 'b set option) \<Rightarrow> 'a \<Rightarrow> 'b set" where
|
||||
"map_set f \<equiv> case_option {} id \<circ> f"
|
||||
|
||||
definition opt_pred :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a option) \<Rightarrow> ('b \<Rightarrow> bool)" (infixl "|<" 55) where
|
||||
"P |< proj \<equiv> (\<lambda>x. case_option False P (proj x))"
|
||||
|
||||
|
||||
subsection \<open>Lemmas for @{const opt_map}\<close>
|
||||
|
||||
lemma opt_map_cong[fundef_cong]:
|
||||
"\<lbrakk> f = f'; \<And>v s. f s = Some v \<Longrightarrow> g v = g' v\<rbrakk> \<Longrightarrow> f |> g = f' |> g'"
|
||||
by (rule ext) (simp add: opt_map_def split: option.splits)
|
||||
|
||||
|
@ -78,8 +88,7 @@ lemma opt_map_Some_upd_Some:
|
|||
"f(x \<mapsto> v) ||> g = (f ||> g)(x \<mapsto> g v)"
|
||||
by (simp add: opt_map_upd_Some)
|
||||
|
||||
lemmas opt_map_upd[simp]
|
||||
= opt_map_upd_None opt_map_upd_Some opt_map_Some_upd_Some
|
||||
lemmas opt_map_upd[simp] = opt_map_upd_None opt_map_upd_Some opt_map_Some_upd_Some
|
||||
|
||||
lemma opt_map_upd_triv:
|
||||
"t k = Some x \<Longrightarrow> (t |> f)(k := f x) = t |> f"
|
||||
|
@ -96,17 +105,16 @@ lemma opt_map_upd_triv_None:
|
|||
lemmas opt_map_upd_triv_simps = opt_map_upd_triv opt_map_Some_upd_triv opt_map_upd_triv_None
|
||||
|
||||
lemma opt_map_foldr_upd:
|
||||
"(foldr (\<lambda>p kh. kh(p := new)) ptrs f)|> g
|
||||
"foldr (\<lambda>p kh. kh(p := new)) ptrs f |> g
|
||||
= foldr (\<lambda>p kh. kh(p := (case new of Some x \<Rightarrow> g x | _ \<Rightarrow> None))) ptrs (f |> g)"
|
||||
by (induct ptrs arbitrary: new; clarsimp split: option.splits)
|
||||
|
||||
lemma opt_map_Some_foldr_upd:
|
||||
"(foldr (\<lambda>p kh. kh(p := new)) ptrs f) ||> g
|
||||
= foldr (\<lambda>p kh. kh(p := (case new of Some x \<Rightarrow> Some (g x) | _ \<Rightarrow> None))) ptrs (f ||> g)"
|
||||
by (induct ptrs arbitrary: new; clarsimp split: option.splits)
|
||||
"foldr (\<lambda>p kh. kh(p := new)) ptrs f ||> g
|
||||
= foldr (\<lambda>p kh. kh(p := map_option g new)) ptrs (f ||> g)"
|
||||
by (induct ptrs arbitrary: new; clarsimp simp: map_option_case split: option.splits)
|
||||
|
||||
lemmas opt_map_foldr_upd_simps
|
||||
= opt_map_foldr_upd opt_map_Some_foldr_upd
|
||||
lemmas opt_map_foldr_upd_simps = opt_map_foldr_upd opt_map_Some_foldr_upd
|
||||
|
||||
lemma opt_map_Some_comp[simp]:
|
||||
"f ||> g ||> h = f ||> h o g"
|
||||
|
@ -138,8 +146,7 @@ lemma opt_map_Some_eta_fold:
|
|||
by (simp add: o_def)
|
||||
|
||||
lemma case_opt_map_distrib:
|
||||
"((\<lambda>s. case_option None g (f s)) |> h)
|
||||
= ((\<lambda>s. case_option None (g |> h) (f s)))"
|
||||
"(\<lambda>s. case_option None g (f s)) |> h = (\<lambda>s. case_option None (g |> h) (f s))"
|
||||
by (fastforce simp: opt_map_def split: option.splits)
|
||||
|
||||
lemma opt_map_apply_left_eq:
|
||||
|
@ -152,20 +159,14 @@ declare None_upd_eq[simp]
|
|||
lemma "\<lbrakk> (f |> g) x = None; g v = None \<rbrakk> \<Longrightarrow> f(x \<mapsto> v) |> g = f |> g"
|
||||
by simp
|
||||
|
||||
definition map_set :: "('a \<Rightarrow> 'b set option) \<Rightarrow> 'a \<Rightarrow> 'b set" where
|
||||
"map_set f \<equiv> case_option {} id \<circ> f"
|
||||
|
||||
(* opt_pred *)
|
||||
|
||||
definition opt_pred :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a option) \<Rightarrow> ('b \<Rightarrow> bool)" (infixl "|<" 55) where
|
||||
"P |< proj \<equiv> (\<lambda>x. case_option False P (proj x))"
|
||||
subsection \<open>Lemmas for @{const opt_pred}\<close>
|
||||
|
||||
lemma opt_pred_conj:
|
||||
"((P1 |< hp) p \<and> (P2 |< hp) p) = (((P1 and P2) |< hp) p)"
|
||||
"((P |< hp) p \<and> (Q |< hp) p) = ((P and Q) |< hp) p"
|
||||
by (fastforce simp: pred_conj_def opt_pred_def split: option.splits)
|
||||
|
||||
lemma opt_pred_disj:
|
||||
"((P1 |< hp) p \<or> (P2 |< hp) p) = (((P1 or P2) |< hp) p)"
|
||||
"((P |< hp) p \<or> (Q |< hp) p) = ((P or Q) |< hp) p"
|
||||
by (fastforce simp: pred_disj_def opt_pred_def split: option.splits)
|
||||
|
||||
lemma in_opt_pred:
|
||||
|
@ -179,40 +180,38 @@ lemma opt_predE:
|
|||
by (blast dest: opt_predD)
|
||||
|
||||
lemma opt_pred_unfold_map:
|
||||
"(P |< (f |> g)) = ((P |< g) |< f)"
|
||||
"P |< (f |> g) = P |< g |< f"
|
||||
by (fastforce simp: opt_map_def in_opt_pred split: option.splits)
|
||||
|
||||
lemma opt_pred_unfold_proj:
|
||||
"(P |< (f ||> g))= (P o g |< f)"
|
||||
"P |< (f ||> g) = P o g |< f"
|
||||
by (clarsimp simp: opt_map_def opt_pred_def split: option.splits)
|
||||
|
||||
(* This rule is useful when fun_upd_apply is not in the simp set: *)
|
||||
lemma opt_pred_proj_upd_eq[simp]:
|
||||
"(P |< proj (p \<mapsto> v)) p = P v"
|
||||
by (simp add: in_opt_pred)
|
||||
|
||||
|
||||
(* obind, etc. *)
|
||||
section \<open>The Reader Option Monad\<close>
|
||||
|
||||
definition
|
||||
obind :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> ('s,'b) lookup) \<Rightarrow> ('s,'b) lookup" (infixl "|>>" 53)
|
||||
where
|
||||
definition obind :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> ('s,'b) lookup) \<Rightarrow> ('s,'b) lookup" (infixl "|>>" 53)
|
||||
where
|
||||
"f |>> g \<equiv> \<lambda>s. case f s of None \<Rightarrow> None | Some x \<Rightarrow> g x s"
|
||||
|
||||
(* Enable "do { .. }" syntax *)
|
||||
adhoc_overloading
|
||||
Monad_Syntax.bind obind
|
||||
|
||||
definition
|
||||
definition ofail :: "('s, 'a) lookup" where
|
||||
"ofail = K None"
|
||||
|
||||
definition
|
||||
definition oreturn :: "'a \<Rightarrow> ('s, 'a) lookup" where
|
||||
"oreturn = K o Some"
|
||||
|
||||
definition
|
||||
definition oassert :: "bool \<Rightarrow> ('s, unit) lookup" where
|
||||
"oassert P \<equiv> if P then oreturn () else ofail"
|
||||
|
||||
definition
|
||||
definition oassert_opt :: "'a option \<Rightarrow> ('s, 'a) lookup" where
|
||||
"oassert_opt r \<equiv> case r of None \<Rightarrow> ofail | Some x \<Rightarrow> oreturn x"
|
||||
|
||||
definition oapply :: "'a \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> 'b option" where
|
||||
|
@ -231,19 +230,18 @@ definition owhen :: "bool \<Rightarrow> ('s, unit) lookup \<Rightarrow> ('s, uni
|
|||
"owhen P f \<equiv> if P then f else oreturn ()"
|
||||
|
||||
(* Reader monad interface: *)
|
||||
abbreviation (input)
|
||||
abbreviation (input) ask :: "('s, 's) lookup" where
|
||||
"ask \<equiv> Some"
|
||||
|
||||
definition
|
||||
definition asks :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s, 'a) lookup" where
|
||||
"asks f = do { v <- ask; oreturn (f v) }"
|
||||
|
||||
abbreviation
|
||||
abbreviation ogets :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s, 'a) lookup" where
|
||||
"ogets \<equiv> asks"
|
||||
|
||||
text \<open>
|
||||
If the result can be an exception.
|
||||
Corresponding bindE would be analogous to lifting in NonDetMonad.
|
||||
\<close>
|
||||
Integration with exception monad.
|
||||
Corresponding bindE would be analogous to lifting in NonDetMonad.\<close>
|
||||
|
||||
definition
|
||||
"oreturnOk x = K (Some (Inr x))"
|
||||
|
@ -260,11 +258,15 @@ definition
|
|||
definition
|
||||
"oskip \<equiv> oreturn ()"
|
||||
|
||||
text \<open>Monad laws\<close>
|
||||
lemma oreturn_bind [simp]: "(oreturn x |>> f) = f x"
|
||||
|
||||
subsection \<open>Monad laws\<close>
|
||||
|
||||
lemma oreturn_bind[simp]:
|
||||
"(oreturn x |>> f) = f x"
|
||||
by (auto simp add: oreturn_def obind_def K_def)
|
||||
|
||||
lemma obind_return [simp]: "(m |>> oreturn) = m"
|
||||
lemma obind_return[simp]:
|
||||
"(m |>> oreturn) = m"
|
||||
by (auto simp add: oreturn_def obind_def K_def split: option.splits)
|
||||
|
||||
lemma obind_assoc:
|
||||
|
@ -272,7 +274,7 @@ lemma obind_assoc:
|
|||
by (auto simp add: oreturn_def obind_def K_def split: option.splits)
|
||||
|
||||
|
||||
text \<open>Binding fail\<close>
|
||||
subsection \<open>Binding and fail\<close>
|
||||
|
||||
lemma obind_fail [simp]:
|
||||
"f |>> (\<lambda>_. ofail) = ofail"
|
||||
|
@ -283,53 +285,53 @@ lemma ofail_bind [simp]:
|
|||
by (auto simp add: ofail_def obind_def K_def split: option.splits)
|
||||
|
||||
|
||||
subsection \<open>Function package setup\<close>
|
||||
|
||||
text \<open>Function package setup\<close>
|
||||
lemma opt_bind_cong [fundef_cong]:
|
||||
lemma opt_bind_cong[fundef_cong]:
|
||||
"\<lbrakk> f = f'; \<And>v s. f' s = Some v \<Longrightarrow> g v s = g' v s \<rbrakk> \<Longrightarrow> f |>> g = f' |>> g'"
|
||||
by (rule ext) (simp add: obind_def split: option.splits)
|
||||
|
||||
lemma opt_bind_cong_apply [fundef_cong]:
|
||||
lemma opt_bind_cong_apply[fundef_cong]:
|
||||
"\<lbrakk> f s = f' s; \<And>v. f' s = Some v \<Longrightarrow> g v s = g' v s \<rbrakk> \<Longrightarrow> (f |>> g) s = (f' |>> g') s"
|
||||
by (simp add: obind_def split: option.splits)
|
||||
|
||||
lemma oassert_bind_cong [fundef_cong]:
|
||||
lemma oassert_bind_cong[fundef_cong]:
|
||||
"\<lbrakk> P = P'; P' \<Longrightarrow> m = m' \<rbrakk> \<Longrightarrow> oassert P |>> m = oassert P' |>> m'"
|
||||
by (auto simp: oassert_def)
|
||||
|
||||
lemma oassert_bind_cong_apply [fundef_cong]:
|
||||
lemma oassert_bind_cong_apply[fundef_cong]:
|
||||
"\<lbrakk> P = P'; P' \<Longrightarrow> m () s = m' () s \<rbrakk> \<Longrightarrow> (oassert P |>> m) s = (oassert P' |>> m') s"
|
||||
by (auto simp: oassert_def)
|
||||
|
||||
lemma oreturn_bind_cong [fundef_cong]:
|
||||
lemma oreturn_bind_cong[fundef_cong]:
|
||||
"\<lbrakk> x = x'; m x' = m' x' \<rbrakk> \<Longrightarrow> oreturn x |>> m = oreturn x' |>> m'"
|
||||
by simp
|
||||
|
||||
lemma oreturn_bind_cong_apply [fundef_cong]:
|
||||
lemma oreturn_bind_cong_apply[fundef_cong]:
|
||||
"\<lbrakk> x = x'; m x' s = m' x' s \<rbrakk> \<Longrightarrow> (oreturn x |>> m) s = (oreturn x' |>> m') s"
|
||||
by simp
|
||||
|
||||
lemma oreturn_bind_cong2 [fundef_cong]:
|
||||
lemma oreturn_bind_cong2[fundef_cong]:
|
||||
"\<lbrakk> x = x'; m x' = m' x' \<rbrakk> \<Longrightarrow> (oreturn $ x) |>> m = (oreturn $ x') |>> m'"
|
||||
by simp
|
||||
|
||||
lemma oreturn_bind_cong2_apply [fundef_cong]:
|
||||
lemma oreturn_bind_cong2_apply[fundef_cong]:
|
||||
"\<lbrakk> x = x'; m x' s = m' x' s \<rbrakk> \<Longrightarrow> ((oreturn $ x) |>> m) s = ((oreturn $ x') |>> m') s"
|
||||
by simp
|
||||
|
||||
lemma ocondition_cong [fundef_cong]:
|
||||
lemma ocondition_cong[fundef_cong]:
|
||||
"\<lbrakk>c = c'; \<And>s. c' s \<Longrightarrow> l s = l' s; \<And>s. \<not>c' s \<Longrightarrow> r s = r' s\<rbrakk>
|
||||
\<Longrightarrow> ocondition c l r = ocondition c' l' r'"
|
||||
by (auto simp: ocondition_def)
|
||||
|
||||
|
||||
text \<open>Decomposition\<close>
|
||||
subsection \<open>Decomposition\<close>
|
||||
|
||||
lemma ocondition_K_true [simp]:
|
||||
lemma ocondition_K_true[simp]:
|
||||
"ocondition (\<lambda>_. True) T F = T"
|
||||
by (simp add: ocondition_def)
|
||||
|
||||
lemma ocondition_K_false [simp]:
|
||||
lemma ocondition_K_false[simp]:
|
||||
"ocondition (\<lambda>_. False) T F = F"
|
||||
by (simp add: ocondition_def)
|
||||
|
||||
|
@ -353,7 +355,7 @@ lemma oreturnE:
|
|||
"\<lbrakk>oreturn x s = Some v; v = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
|
||||
by simp
|
||||
|
||||
lemma in_ofail [simp]:
|
||||
lemma in_ofail[simp]:
|
||||
"ofail s \<noteq> Some v"
|
||||
by (auto simp: ofail_def K_def)
|
||||
|
||||
|
@ -361,15 +363,15 @@ lemma ofailE:
|
|||
"ofail s = Some v \<Longrightarrow> P"
|
||||
by simp
|
||||
|
||||
lemma in_oassert_eq [simp]:
|
||||
lemma in_oassert_eq[simp]:
|
||||
"(oassert P s = Some v) = P"
|
||||
by (simp add: oassert_def)
|
||||
|
||||
lemma oassert_True [simp]:
|
||||
lemma oassert_True[simp]:
|
||||
"oassert True = oreturn ()"
|
||||
by (simp add: oassert_def)
|
||||
|
||||
lemma oassert_False [simp]:
|
||||
lemma oassert_False[simp]:
|
||||
"oassert False = ofail"
|
||||
by (simp add: oassert_def)
|
||||
|
||||
|
@ -398,11 +400,10 @@ lemma obind_eqI_full:
|
|||
(clarsimp simp: obind_def split: option.splits)
|
||||
|
||||
lemma obindE:
|
||||
"\<lbrakk> (f |>> g) s = Some v;
|
||||
\<And>v'. \<lbrakk>f s = Some v'; g v' s = Some v\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
|
||||
"\<lbrakk> (f |>> g) s = Some v; \<And>v'. \<lbrakk>f s = Some v'; g v' s = Some v\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
|
||||
by (auto simp: in_obind_eq)
|
||||
|
||||
lemma in_othrow_eq [simp]:
|
||||
lemma in_othrow_eq[simp]:
|
||||
"(othrow e s = Some v) = (v = Inl e)"
|
||||
by (auto simp: othrow_def K_def)
|
||||
|
||||
|
@ -410,7 +411,7 @@ lemma othrowE:
|
|||
"\<lbrakk>othrow e s = Some v; v = Inl e \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
|
||||
by simp
|
||||
|
||||
lemma in_oreturnOk_eq [simp]:
|
||||
lemma in_oreturnOk_eq[simp]:
|
||||
"(oreturnOk x s = Some v) = (v = Inr x)"
|
||||
by (auto simp: oreturnOk_def K_def)
|
||||
|
||||
|
@ -418,8 +419,7 @@ lemma oreturnOkE:
|
|||
"\<lbrakk>oreturnOk x s = Some v; v = Inr x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
|
||||
by simp
|
||||
|
||||
lemmas omonadE [elim!] =
|
||||
obindE oreturnE ofailE othrowE oreturnOkE oassertE
|
||||
lemmas omonadE[elim!] = obindE oreturnE ofailE othrowE oreturnOkE oassertE
|
||||
|
||||
lemma in_opt_map_Some_eq:
|
||||
"((f ||> g) x = Some y) = (\<exists>v. f x = Some v \<and> g v = y)"
|
||||
|
@ -481,10 +481,7 @@ text \<open>
|
|||
(without passing through a state)
|
||||
\<close>
|
||||
|
||||
inductive_set
|
||||
option_while' :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a option) \<Rightarrow> 'a option rel"
|
||||
for C B
|
||||
where
|
||||
inductive_set option_while' :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a option) \<Rightarrow> 'a option rel" for C B where
|
||||
final: "\<not> C r \<Longrightarrow> (Some r, Some r) \<in> option_while' C B"
|
||||
| fail: "\<lbrakk> C r; B r = None \<rbrakk> \<Longrightarrow> (Some r, None) \<in> option_while' C B"
|
||||
| step: "\<lbrakk> C r; B r = Some r'; (Some r', sr'') \<in> option_while' C B \<rbrakk>
|
||||
|
@ -498,10 +495,12 @@ definition
|
|||
lemma option_while'_inj:
|
||||
assumes "(s,s') \<in> option_while' C B" "(s, s'') \<in> option_while' C B"
|
||||
shows "s' = s''"
|
||||
using assms by (induct rule: option_while'.induct) (auto elim: option_while'.cases)
|
||||
using assms
|
||||
by (induct rule: option_while'.induct) (auto elim: option_while'.cases)
|
||||
|
||||
lemma option_while'_inj_step:
|
||||
"\<lbrakk> C s; B s = Some s'; (Some s, t) \<in> option_while' C B ; (Some s', t') \<in> option_while' C B \<rbrakk> \<Longrightarrow> t = t'"
|
||||
"\<lbrakk> C s; B s = Some s'; (Some s, t) \<in> option_while' C B ; (Some s', t') \<in> option_while' C B \<rbrakk>
|
||||
\<Longrightarrow> t = t'"
|
||||
by (metis option_while'.step option_while'_inj)
|
||||
|
||||
lemma option_while'_THE:
|
||||
|
@ -516,9 +515,9 @@ lemma option_while_simps:
|
|||
"(Some s, ss') \<in> option_while' C B \<Longrightarrow> option_while C B s = ss'"
|
||||
using option_while'_inj_step[of C s B s']
|
||||
by (auto simp: option_while_def option_while'_THE
|
||||
intro: option_while'.intros
|
||||
dest: option_while'_inj
|
||||
elim: option_while'.cases)
|
||||
intro: option_while'.intros
|
||||
dest: option_while'_inj
|
||||
elim: option_while'.cases)
|
||||
|
||||
lemma option_while_rule:
|
||||
assumes "option_while C B s = Some s'"
|
||||
|
@ -582,9 +581,7 @@ qed
|
|||
|
||||
section \<open>Lift @{term option_while} to the @{typ "('a,'s) lookup"} monad\<close>
|
||||
|
||||
definition
|
||||
owhile :: "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('s,'a) lookup) \<Rightarrow> 'a \<Rightarrow> ('s,'a) lookup"
|
||||
where
|
||||
definition owhile :: "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('s,'a) lookup) \<Rightarrow> 'a \<Rightarrow> ('s,'a) lookup" where
|
||||
"owhile c b a \<equiv> \<lambda>s. option_while (\<lambda>a. c a s) (\<lambda>a. b a s) a"
|
||||
|
||||
lemma owhile_unroll:
|
||||
|
@ -593,7 +590,7 @@ lemma owhile_unroll:
|
|||
option_while_simps
|
||||
split: option.split)
|
||||
|
||||
text \<open>rule for terminating loops\<close>
|
||||
text \<open>Rule for terminating loops\<close>
|
||||
|
||||
lemma owhile_rule:
|
||||
assumes "I r s"
|
||||
|
|
Loading…
Reference in New Issue