theory Lens_Statespace_Example
  imports Lenses
begin

statespace myss =
  x :: int
  y :: int

statespace myss' =
  a :: string

statespace myss2 = myss + myss' +
  z :: string

context myss2
begin

lemma "x \<bowtie> y"
  by (simp)

end

statespace myss3 = myss2 +
  v :: string

text \<open> We can instantiate one of the statespaces with a concrete alphabet type as shown below. \<close>

alphabet myss_c =
  x :: int
  y :: int
  a :: string
  z :: string
  v :: string

lemma "myss3 x y a z v"
  by (simp add: myss'_def myss2_axioms_def myss2_def myss3.intro myss3_axioms.intro myss_def)

end


theory AutoCorres_Misc imports
  "../l4v/lib/OptionMonadWP"
begin

section \<open>Auxilliary Lemmas for Autocorres\<close>

subsection \<open>Option monad\<close>

definition owhile_inv :: "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('s,'a) lookup) \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 'a rel \<Rightarrow> ('s,'a) lookup"   where
 "owhile_inv c b a I R \<equiv> owhile c b a"

lemma owhile_unfold: "owhile C B r s = ocondition (C r) (B r |>> owhile C B) (oreturn r) s"
  by (auto simp: ocondition_def obind_def oreturn_def owhile_def option_while_simps split: option.split)

lemma ovalidNF_owhile:
  assumes "\<And>s. P r s \<Longrightarrow> I r s"
    and "\<And>r s. ovalidNF (\<lambda>s'. I r s' \<and> C r s' \<and> s' = s) (B r) (\<lambda>r' s'. I r' s' \<and> (r', r) \<in> R)"
    and "wf R"
    and "\<And>r s. I r s \<Longrightarrow> \<not> C r s \<Longrightarrow> Q r s"
  shows "ovalidNF (P r) (OptionMonad.owhile C B r) Q"
  unfolding ovalidNF_def
proof (intro allI impI)
  fix s assume "P r s"
  then have "I r s" by fact
  moreover note \<open>wf R\<close>
  moreover have "\<And>r r'. I r s \<Longrightarrow> C r s \<Longrightarrow> B r s = Some r' \<Longrightarrow> (r', r) \<in> R"
    using assms(2) unfolding ovalidNF_def by fastforce
  moreover have "\<And>r r'. I r s \<Longrightarrow> C r s \<Longrightarrow> B r s = Some r' \<Longrightarrow> I r' s"
    using assms(2) unfolding ovalidNF_def by blast
  moreover have "\<And>r. I r s \<Longrightarrow> C r s \<Longrightarrow> B r s = None \<Longrightarrow>
      None \<noteq> None \<and> (\<forall>r'. None = Some r' \<longrightarrow> Q r' s)"
    using assms(2) unfolding ovalidNF_def by blast
  moreover have "\<And>r. I r s \<Longrightarrow> \<not> C r s \<Longrightarrow> Some r \<noteq> None \<and> (\<forall>r'. Some r = Some r' \<longrightarrow> Q r' s)"
    using assms(4) unfolding ovalidNF_def by blast
  ultimately
  show "owhile C B r s \<noteq> None \<and> (\<forall>r'. owhile C B r s = Some r' \<longrightarrow> Q r' s)"
    by (rule owhile_rule[where I=I])
qed

end


(*  Title:      HOL/MicroJava/Comp/AuxLemmas.thy
    Author:     Martin Strecker
*)

(* Auxiliary Lemmas *)

theory AuxLemmas
imports "../J/JBasis"
begin

(**********************************************************************)
(* List.thy *)
(**********************************************************************)

lemma app_nth_greater_len [simp]:
  "length pre \<le> ind \<Longrightarrow> (pre @ a # post) ! (Suc ind) = (pre @ post) ! ind"
  apply (induct pre arbitrary: ind)
   apply clarsimp
  apply (case_tac ind)
   apply auto
  done

lemma length_takeWhile: "v \<in> set xs \<Longrightarrow> length (takeWhile (\<lambda>z. z \<noteq> v) xs) < length xs"
  by (induct xs) auto

lemma nth_length_takeWhile [simp]:
  "v \<in> set xs \<Longrightarrow> xs ! (length (takeWhile (%z. z~=v) xs)) = v"
  by (induct xs) auto

lemma map_list_update [simp]:
  "\<lbrakk> x \<in> set xs; distinct xs\<rbrakk> \<Longrightarrow>
  (map f xs) [length (takeWhile (\<lambda>z. z \<noteq> x) xs) := v] = map (f(x:=v)) xs"
  apply (induct xs)
   apply simp
  apply (rename_tac a xs)
  apply (case_tac "x=a")
   apply auto
  done

(**********************************************************************)
(* Product_Type.thy *)
(**********************************************************************)

lemma split_compose:
  "(case_prod f) \<circ> (\<lambda> (a,b). ((fa a), (fb b))) = (\<lambda> (a,b). (f (fa a) (fb b)))"
  by (simp add: split_def o_def)

lemma split_iter:
  "(\<lambda> (a,b,c). ((g1 a), (g2 b), (g3 c))) = (\<lambda> (a,p). ((g1 a), (\<lambda> (b, c). ((g2 b), (g3 c))) p))"
  by (simp add: split_def o_def)

(**********************************************************************)
(* Set.thy *)
(**********************************************************************)

lemma singleton_in_set: "A = {a} \<Longrightarrow> a \<in> A" by simp

(**********************************************************************)
(* Map.thy *)
(**********************************************************************)

lemma the_map_upd: "(the \<circ> f(x\<mapsto>v)) = (the \<circ> f)(x:=v)"
  by (simp add: fun_eq_iff)

lemma map_of_in_set:
  "(map_of xs x = None) = (x \<notin> set (map fst xs))"
  by (induct xs, auto)

lemma map_map_upd [simp]:
  "y \<notin> set xs \<Longrightarrow> map (the \<circ> f(y\<mapsto>v)) xs = map (the \<circ> f) xs"
  by (simp add: the_map_upd)

lemma map_map_upds [simp]:
  "(\<forall>y\<in>set ys. y \<notin> set xs) \<Longrightarrow> map (the \<circ> f(ys[\<mapsto>]vs)) xs = map (the \<circ> f) xs"
  by (induct xs arbitrary: f vs) auto

lemma map_upds_distinct [simp]:
  "distinct ys \<Longrightarrow> length ys = length vs \<Longrightarrow> map (the \<circ> f(ys[\<mapsto>]vs)) ys = vs"
  apply (induct ys arbitrary: f vs)
   apply simp
  apply (case_tac vs)
   apply simp_all
  done

lemma map_of_map_as_map_upd:
  "distinct (map f zs) \<Longrightarrow> map_of (map (\<lambda> p. (f p, g p)) zs) = Map.empty (map f zs [\<mapsto>] map g zs)"
  by (induct zs) auto

(* In analogy to Map.map_of_SomeD *)
lemma map_upds_SomeD:
  "(m(xs[\<mapsto>]ys)) k = Some y \<Longrightarrow> k \<in> (set xs) \<or> (m k = Some y)"
  apply (induct xs arbitrary: m ys)
   apply simp
  apply (case_tac ys)
   apply fastforce+
  done

lemma map_of_upds_SomeD: "((map_of m) (xs[\<mapsto>]ys)) k = Some y
  \<Longrightarrow> k \<in> (set (xs @ map fst m))"
  by (auto dest: map_upds_SomeD map_of_SomeD fst_in_set_lemma)

lemma map_of_map_prop:
  "\<lbrakk>map_of (map f xs) k = Some v; \<forall>x \<in> set xs. P1 x; \<forall>x. P1 x \<longrightarrow> P2 (f x)\<rbrakk> \<Longrightarrow> P2 (k, v)"
  by (induct xs) (auto split: if_split_asm)

lemma map_of_map2: "\<forall>x \<in> set xs. (fst (f x)) = (fst x) \<Longrightarrow>
  map_of (map f xs) a = map_option (\<lambda> b. (snd (f (a, b)))) (map_of xs a)"
  by (induct xs, auto)

end


theory Small_Step_7p10
imports
Star
Big_Step_7p10

begin

subsection "The transition relation"

inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq1a:   "(THROW;;c\<^sub>2,s) \<rightarrow> (THROW, s)" |
Seq2:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)" |
Try1:    "c\<^sub>1 \<noteq> THROW \<Longrightarrow> (TRY c\<^sub>1 CATCH c\<^sub>2, s) \<rightarrow> (c\<^sub>1,s)" |
Try2:    "(TRY THROW CATCH c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

code_pred small_step .

lemmas small_step_induct = small_step.induct[split_format(complete)]

declare small_step.intros[simp,intro]

text{* Rule inversion: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm SkipE
inductive_cases ThrowE[elim!]: "(THROW, s) \<rightarrow> ct"
thm ThrowE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
thm IfE
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"
thm WhileE
inductive_cases TryE[elim!]: "(TRY c\<^sub>1 CATCH c\<^sub>2, s) \<rightarrow> ct"
thm TryE

(* Lemma 7.11 IMP is deterministic *)
lemma "cs \<rightarrow> cs' \<Longrightarrow> cs \<rightarrow> cs'' \<Longrightarrow> cs'' = cs'"
  apply (induction cs' arbitrary: cs'' rule: small_step.induct)
          apply blast+
  done

(* Lemma 7.13 *)
lemma star_seq2: "(c1, s1) \<rightarrow>* (c, s2) \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (c;; c2, s2)"
proof (induction "(c1,s1)" "(c,s2)" arbitrary: c1 s1 c s2  rule: star.induct)
  case (refl)
  then show ?case by simp
next
  case (step y)
  obtain c1' s1' where a: "y = (c1', s1')" by fastforce
  have star: "(c1';;c2, s1') \<rightarrow>* (c;;c2, s2)" using step.hyps(3) a by blast
  have first: "(c1;; c2, s1) \<rightarrow> (c1';;c2, s1')" using step.hyps(1) a  by blast
  thus ?case using first star step.hyps by (simp add: star.step)
qed

(* I was having trouble with proving
     obtain c1' s1' where a: "y = (c1', s1')"
  It is equivalent to the following. If you can prove that
  you can prove the "obtain" *)

lemma "\<And>thesis. (\<And>c1' s1'. y = (c1', s1') \<Longrightarrow> thesis) \<Longrightarrow> thesis"
proof -
  fix thesis
  assume [intro]: "\<And>c1' s1'. y = (c1', s1') \<Longrightarrow> thesis"
  then show thesis by fastforce
qed

(* Lemma 7.12 *)
lemma big_step_imp_small_step: "cs \<Rightarrow> (s, t) \<Longrightarrow> s = SKIP \<or> s = THROW \<Longrightarrow>  cs \<rightarrow>* (s, t)"
proof (induction rule: big_step.induct)
  case (Seq1 c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 x s\<^sub>3)
  then show ?case by (blast intro: star.step star_seq2 star_trans)
next
  case (Seq2 c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2)
  then show ?case by (blast intro: star_seq2 star_trans)
next
  case (IfTrue b s c\<^sub>1 x t c\<^sub>2)
  then have "(c\<^sub>1,s) \<rightarrow>* (x, t)" by blast
  moreover have "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" using IfTrue.hyps by blast
  ultimately show ?case using IfTrue.IH by (blast intro: star.step)
next
  case (IfFalse b s c\<^sub>2 x t c\<^sub>1)
  then have "(c\<^sub>2,s) \<rightarrow>* (x, t)" by blast
  moreover have "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" using IfFalse.hyps by blast
  ultimately show ?case using IfFalse.IH by (blast intro: star.step)
next
  case (WhileFalse b s c)
  then have a: "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN (c;; WHILE b DO c) ELSE SKIP,s)" by blast
  then have "(IF b THEN (c;; WHILE b DO c) ELSE SKIP,s) \<rightarrow>* (SKIP,s)" using WhileFalse.hyps by blast
  then show "(WHILE b DO c, s) \<rightarrow>* (SKIP, s)" using a by (blast intro: star.step)
next
  case (WhileTrue1 b s\<^sub>1 c s\<^sub>2 x s\<^sub>3)
  let ?w = "WHILE b DO c"
  let ?if = "IF b THEN c;; ?w ELSE SKIP"
  have 0: "(c, s\<^sub>1) \<rightarrow>* (SKIP, s\<^sub>2)" using WhileTrue1.IH WhileTrue1.prems(1) by blast
  have 1: "(?w, s\<^sub>1) \<rightarrow>* (?if, s\<^sub>1)" by blast
  have 2: "(?if, s\<^sub>1) \<rightarrow>* (c;;?w, s\<^sub>1)" using WhileTrue1(1) by blast
  have 3: "(c;;?w, s\<^sub>1) \<rightarrow>* (SKIP;;?w, s\<^sub>2)" using 0 WhileTrue1.IH(1) by (simp add: star_seq2)
  have 4: "(SKIP;;?w, s\<^sub>2) \<rightarrow>* (?w, s\<^sub>2)" by simp
  then have "(?w, s\<^sub>1) \<rightarrow>* (?w, s\<^sub>2)" using 1 2 3 4 by (blast intro: star_trans)
  then show ?case using WhileTrue1.IH WhileTrue1.prems(1) by (blast intro: star_trans)
next
  case (WhileTrue2 b s\<^sub>1 c s\<^sub>2)
  let ?w = "WHILE b DO c"
  let ?if = "IF b THEN c;;?w ELSE SKIP"
  have 0: "(c, s\<^sub>1) \<rightarrow>* (THROW, s\<^sub>2)" using WhileTrue2.prems WhileTrue2.IH by blast
  have 1: "(?w, s\<^sub>1) \<rightarrow>* (?if, s\<^sub>1)" using WhileTrue2 by blast
  have 2: "(?if, s\<^sub>1) \<rightarrow>* (c;;?w, s\<^sub>1)" using WhileTrue2.hyps(1) by blast
  (* FIXME *)
  have 3: "(c;;?w, s\<^sub>1) \<rightarrow>* (THROW, s\<^sub>2)" using 0
    by (meson Seq1a WhileTrue2.IH star_seq2 star_step1 star_trans)
  then show ?case using 1 2 3 WhileTrue2.IH by (blast intro: star_trans)
next
  case (Try1 c\<^sub>1 s x t c\<^sub>2)
  then show ?case by (meson small_step.Try1 star.simps)
next
  case (Try2 c\<^sub>2 s x t)
  then show ?case by (meson small_step.Try2 star.simps)
qed blast+

lemma big_step_imp_small_step_SKIP: "cs \<Rightarrow> (SKIP, t) \<Longrightarrow> cs \<rightarrow>* (SKIP, t)"
  by (auto simp: big_step_imp_small_step)

lemma big_step_imp_small_step_THROW: "cs \<Rightarrow> (THROW, t) \<Longrightarrow> cs \<rightarrow>* (THROW, t)"
  by (auto simp: big_step_imp_small_step)

(* I could have got an even smaller proof for the WhileTrue cases above if I'd have proved this
   I could then have got
     assume w: "(?w,s') \<rightarrow>* (SKIP,t)"
     assume c: "(c,s) \<rightarrow>* (SKIP,s')"
     have new_3: "(c;; ?w,s) \<rightarrow>* (SKIP,t)" by(rule seq_comp[OF c w])

     Then I could have used 1 2 and new_3

*)
lemma seq_comp: "\<lbrakk> (c\<^sub>1, s\<^sub>1) \<rightarrow>* (SKIP, s\<^sub>2); (c\<^sub>2, s\<^sub>2) \<rightarrow>* (SKIP, s\<^sub>3) \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<rightarrow>* (SKIP, s\<^sub>3)"
  by (blast intro: star_seq2 star_trans)

(* Lemma 7.15 *)
lemma small_big_comp: "\<lbrakk> cs \<rightarrow> cs'; cs' \<Rightarrow> (x,t) \<rbrakk> \<Longrightarrow> cs \<Rightarrow> (x,t)"
  apply  (induction arbitrary: x t rule: small_step.induct)
    apply auto
done

(* Lemma 7.14 *)

(* The induction here was interesting because we didn't have to use "arbitrary" in
proof (induction "cs" "(SKIP, t)" rule: star.induct *)
lemma small_step_imp_big_step_SKIP: "cs \<rightarrow>* (SKIP, t) \<Longrightarrow> cs \<Rightarrow> (SKIP, t)"
proof (induction "cs" "(SKIP, t)" rule: star.induct)
  case refl
  then show ?case by blast
next
  case (step cs cs')
  assume "cs \<rightarrow> cs'"
     and "cs' \<Rightarrow> (SKIP,t)"
  thus ?case by (rule small_big_comp)
qed

lemma small_step_imp_big_step_THROW: "cs \<rightarrow>* (THROW, t) \<Longrightarrow> cs \<Rightarrow> (THROW, t)"
proof (induction "cs" "(THROW, t)" rule: star.induct)
  case refl
  then show ?case by blast
next
  case (step cs cs')
  assume "cs \<rightarrow> cs'"
     and "cs' \<Rightarrow> (THROW, t)"
  thus ?case by (rule small_big_comp)
qed

(* The textbook got us to prove "(c,s) \<Rightarrow> t \<longleftrightarrow> (c,s) \<rightarrow>* (SKIP, t)"
   which ended up meaning that the proof for 7.18 did not go through easily.
   The form below, using "cs" insteand of "(c,s)" is the same as the form for
   final_iff_SKIP
 *)

(* Lemma 7.16 *)
lemma big_iff_small_SKIP: "cs \<Rightarrow> (SKIP, t) \<longleftrightarrow> cs \<rightarrow>* (SKIP, t)"
proof
  show "cs \<Rightarrow> (SKIP, t) \<Longrightarrow> cs \<rightarrow>* (SKIP, t)" by (rule big_step_imp_small_step_SKIP)
next
  show "cs \<rightarrow>* (SKIP, t) \<Longrightarrow> cs \<Rightarrow> (SKIP, t)" by (rule small_step_imp_big_step_SKIP)
qed

lemma big_iff_small_THROW: "cs \<Rightarrow> (THROW, t) \<longleftrightarrow> cs \<rightarrow>* (THROW, t)"
proof
  show "cs \<Rightarrow> (THROW, t) \<Longrightarrow> cs \<rightarrow>* (THROW, t)" by (rule big_step_imp_small_step_THROW)
next
  show "cs \<rightarrow>* (THROW, t) \<Longrightarrow> cs \<Rightarrow> (THROW, t)" by (rule small_step_imp_big_step_THROW)
qed

lemma big_iff_small: "x = SKIP \<or> x = THROW \<Longrightarrow> (cs \<Rightarrow> (x,t) \<longleftrightarrow> cs \<rightarrow>* (x,t))"
proof cases
  assume "x = THROW"
  then show ?thesis using big_iff_small_THROW by blast
next
  assume "x \<noteq> THROW"
     and "x = SKIP \<or> x = THROW"
  then show ?thesis using big_iff_small_SKIP by blast
qed

definition final :: "com \<times> state \<Rightarrow> bool" where
  "final cs \<longleftrightarrow> \<not>(\<exists>cs'. cs \<rightarrow> cs')"

(* Lemma 7.17 *)
lemma final_iff_SKIP_or_THROW: "final (c,s) = (c = SKIP \<or> c = THROW)"
proof
  show "c = SKIP \<or> c = THROW \<Longrightarrow> final (c, s)" by (auto simp: final_def)
next
  show "final (c, s) \<Longrightarrow> c = SKIP \<or> c = THROW"
    apply (simp add: final_def)
    apply (induction c rule: com.induct)
        apply blast+
    done
qed

(* Lemma 7.18 *)
lemma "(\<exists>cs'. cs \<Rightarrow> cs') \<longleftrightarrow> (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"
  apply (simp add: final_iff_SKIP_or_THROW)
  apply (metis big_iff_small big_step_to_SKIP_or_THROW surj_pair)
  done

end


theory SE_Monad
imports Main Option_Monad Lenses
begin
  text \<open>State exception monad, without state type change\<close>
  type_synonym ('a,'s) se = "'s \<rightharpoonup> ('a \<times> 's)"

  (* return = RNormal, throw = Abrupt o Some   *)

  definition sreturn :: "'a \<Rightarrow> ('a,'s) se" where "sreturn x s \<equiv> Some (x,s)"
  definition sfail :: "('a,'s) se" where "sfail s \<equiv> None"
  definition sbind :: "('a,'s) se \<Rightarrow> ('a \<Rightarrow> ('b,'s) se) \<Rightarrow> ('b,'s) se" where
    "sbind m f s \<equiv> case m s of Some (x,s) \<Rightarrow> f x s | _ \<Rightarrow> None"

  definition sget :: "('s,'s) se" where "sget s \<equiv> Some (s,s)"
  definition sput :: "'s \<Rightarrow> (unit,'s) se" where "sput s' s \<equiv> Some ((),s')"

  (* adhoc_overloading bind sbind *)

  abbreviation (do_notation) bind_doE where "bind_doE \<equiv> sbind"

  subsection \<open>Syntax Magic\<close>
  notation (input) sbind (infixr "\<bind>" 54)
  notation (output) bind_doE (infixr "\<bind>" 54)

  nonterminal doE_binds and doE_bind
  syntax
    "_doE_block" :: "doE_binds \<Rightarrow> 'a" ("doE {//(2  _)//}" [12] 62)
    "_doE_bind"  :: "[pttrn, 'a] \<Rightarrow> doE_bind" ("(2_ \<leftarrow>/ _)" 13)
    "_doE_let" :: "[pttrn, 'a] \<Rightarrow> doE_bind" ("(2let _ =/ _)" [1000, 13] 13)
    "_doE_then" :: "'a \<Rightarrow> doE_bind" ("_" [14] 13)
    "_doE_final" :: "'a \<Rightarrow> doE_binds" ("_")
    "_doE_cons" :: "[doE_bind, doE_binds] \<Rightarrow> doE_binds" ("_;//_" [13, 12] 12)
    "_thenM" :: "['a, 'b] \<Rightarrow> 'c" (infixr "\<then>" 54)

  syntax (ASCII)
    "_doE_bind" :: "[pttrn, 'a] \<Rightarrow> doE_bind" ("(2_ <-/ _)" 13)
    "_thenM" :: "['a, 'b] \<Rightarrow> 'c" (infixr ">>" 54)

  translations
    "_doE_block (_doE_cons (_doE_then t) (_doE_final e))"
      \<rightleftharpoons> "CONST bind_doE t (\<lambda>_. e)"
    "_doE_block (_doE_cons (_doE_bind p t) (_doE_final e))"
      \<rightleftharpoons> "CONST bind_doE t (\<lambda>p. e)"
    "_doE_block (_doE_cons (_doE_let p t) bs)"
      \<rightleftharpoons> "let p = t in _doE_block bs"
    "_doE_block (_doE_cons b (_doE_cons c cs))"
      \<rightleftharpoons> "_doE_block (_doE_cons b (_doE_final (_doE_block (_doE_cons c cs))))"
    "_doE_cons (_doE_let p t) (_doE_final s)"
      \<rightleftharpoons> "_doE_final (let p = t in s)"
    "_doE_block (_doE_final e)" \<rightharpoonup> "e"
    "(m \<then> n)" \<rightharpoonup> "(CONST bind_doE m (\<lambda>_. n))"

  lemma xrm_monad_laws[simp]:
    "doE {x \<leftarrow> sreturn y; f x} = f y"
    "doE {x \<leftarrow> m; sreturn x} = m"
    "doE {x\<leftarrow>(doE {y\<leftarrow>m; f y}); g x } = doE {y\<leftarrow>m; x\<leftarrow>f y; g x}"

    "doE {sfail; m} = sfail"
    "doE {_\<leftarrow>m; sfail} = sfail"

    "doE {s\<leftarrow>sget; sput s} = sreturn ()"
    "doE {sput s1; sput s2} = sput s2"
    "doE {sput s; sget} = doE {sput s; sreturn s}"

    unfolding sreturn_def sbind_def sfail_def sget_def sput_def
    by (auto split: option.splits)

  lemma sbind_split: "P (sbind m f s) \<longleftrightarrow> (m s = None \<longrightarrow> P None) \<and> (\<forall>r s'. m s = Some (r,s') \<longrightarrow> P (f r s'))"
    by (auto simp: sbind_def split: option.split)

  lemma sbind_split_asm: "P (sbind m f s)
    \<longleftrightarrow> \<not> ((m s = None \<and> \<not> P None) \<or> (\<exists>r s'. m s = Some (r,s') \<and> \<not> P (f r s')))"
    by (auto simp: sbind_def split: option.split)

  lemmas sbind_splits = sbind_split sbind_split_asm

  definition se_ord :: "('a,'s) se \<Rightarrow> _" where "se_ord \<equiv> fun_ord (flat_ord None)"
  definition se_lub :: "('a,'s) se set \<Rightarrow> _" where "se_lub \<equiv> fun_lub (flat_lub None)"

  abbreviation "mono_se \<equiv> monotone (fun_ord se_ord) se_ord"

  interpretation se_monad: partial_function_definitions se_ord se_lub
    unfolding se_ord_def se_lub_def
    apply (rule partial_function_lift)
    by standard

  declaration \<open>Partial_Function.init "se_monad" @{term se_monad.fixp_fun}
    @{term se_monad.mono_body} @{thm se_monad.fixp_rule_uc} @{thm se_monad.fixp_induct_uc}
    ( (*SOME @{thm fixp_induct_option}*) NONE )\<close> (* TODO: Induction rule! *)

  lemma sebind_mono[partial_function_mono]:
    assumes mf: "mono_se B" and mg: "\<And>y. mono_se (\<lambda>f. C y f)"
    shows "mono_se (\<lambda>f. sbind (B f) (\<lambda>y. C y f))"
    apply (rule monotoneI)
    using monotoneD[OF mf] monotoneD[OF mg]
    unfolding se_ord_def flat_ord_def fun_ord_def
    apply (auto split: sbind_splits dest: )
    apply (metis option.simps(3))
    by (metis fst_conv option.sel option.simps(3) snd_conv)

  definition "sassert \<Phi> \<equiv> if \<Phi> then sreturn () else sfail"

  lemma xassert_simps[simp]:
    "sassert True = sreturn ()"
    "sassert False = sfail"
    by (auto simp: sassert_def)

  lemma sfail_eq_conv[simp]:
    "sfail s = None"
    by (auto simp: sfail_def)

  lemma sreturn_eq_conv[simp]:
    "sreturn x s = Some (x,s)"
    by (auto simp: sreturn_def)

  lemma sget_eq_conv[simp]:
    "sget s = Some (s,s)"
    by (auto simp: sget_def)

  lemma xput_eq_conv[simp]:
    "sput s ss = Some ((),s)"
    by (auto simp: sput_def)

  lemma sassert_eq_conv[simp]:
    "sassert \<Phi> s = Some us \<longleftrightarrow> us=((),s) \<and> \<Phi>"
    "sassert \<Phi> s = None \<longleftrightarrow> \<not>\<Phi>"
    by (auto simp: sassert_def)

  definition wps :: "('a,'s) se \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" where
    "wps c Q s = (case c s of Some (x,s) \<Rightarrow> Q x s | None \<Rightarrow> False)"

  named_theorems wps_iffs \<open>Equality laws for weakest precondition (also used to generate intro-rules)\<close>
  named_theorems wps_simps \<open>Equality laws for weakest precondition\<close>
  named_theorems wps_intros \<open>Introduction rules for weakest precondition\<close>

  local_setup \<open>
    let
      fun get_wps_eqs ctxt =
          Named_Theorems.get ctxt @{named_theorems wps_iffs}
        @ Named_Theorems.get ctxt @{named_theorems wps_simps}

      fun get_wps_rls ctxt =
          Named_Theorems.get ctxt @{named_theorems wps_intros}
        @ map (fn thm => thm RS @{thm iffD2}) (Named_Theorems.get ctxt @{named_theorems wps_iffs})
    in
      I
      #> Local_Theory.add_thms_dynamic (@{binding wps_rls}, get_wps_rls o Context.proof_of)
      #> Local_Theory.add_thms_dynamic (@{binding wps_eqs}, get_wps_eqs o Context.proof_of)
    end
  \<close>

  lemma wps_basic_eq[wps_iffs]:
    "\<And>Q E x s. wps (sreturn x) Q s = Q x s"
    "\<And>Q E s. wps (sfail) Q s = False"
    "\<And>Q E s. wps (sget) Q s = Q s s"
    "\<And>Q E r s. wps (sput r) Q s = Q () r"
    "\<And>m f Q E s. wps (doE {x\<leftarrow>m; f x}) Q s = wps m (\<lambda>x. wps (f x) Q) s"
    unfolding wps_def
    by (auto split: sbind_splits option.splits)

  lemma wps_assert_eq[wps_iffs]:
    "wps (sassert \<Phi>) Q s \<longleftrightarrow> \<Phi> \<and> Q () s"
    unfolding wps_def by (auto split: option.splits)

  lemma
    wps_if_eq[wps_simps]: "wps (if b then t else e) Q s = (if b then wps t Q s else wps e Q s)"
    and wps_ifI[wps_intros]: "\<lbrakk> b \<Longrightarrow> wps t Q s; \<not>b \<Longrightarrow> wps e Q s \<rbrakk> \<Longrightarrow> wps (if b then t else e) Q s"
    and wps_if_eq': "wps (if b then t else e) Q = (if b then wps t Q else wps e Q)"
    by auto

  lemma wps_mono': "Q\<le>Q' \<Longrightarrow> wps c Q \<le> wps c Q'"
    unfolding wps_def by (auto split: option.splits)

  lemma wps_mono:
    assumes "wps c Q s"
    assumes "\<And>r s. Q r s \<Longrightarrow> Q' r s"
    shows "wps c Q' s"
    using wps_mono'[of Q Q' c] assms
    by (auto)

  definition sexec :: "('a,'s) se \<Rightarrow> 's \<Rightarrow> ('a\<times>'s,'t) se" where
    "sexec f s \<equiv> case f s of Some (a,s) \<Rightarrow> sreturn (a,s) | None \<Rightarrow> sfail"

  lemma wps_sexec_eq[wps_iffs]:
    "wps (sexec f s) Q t = wps f (\<lambda>a s. Q (a,s) t) s"
    by (auto simp: sexec_def wps_def split: option.splits)

  definition lift :: "'a option \<Rightarrow> ('a,'s) se" where
    "lift m \<equiv> case m of None \<Rightarrow> sfail | Some x \<Rightarrow> sreturn x"

  definition use :: "('a \<Longrightarrow> 's) \<Rightarrow> ('a,'s) se" where
    "use L \<equiv> doE { s \<leftarrow> sget; r\<leftarrow>lift (get L s); sreturn r }"

  definition modify :: "('a \<Longrightarrow> 's) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> (unit,'s) se"
    (infix "%=" 50) where
    "L %= f \<equiv> doE { s \<leftarrow> sget; x \<leftarrow> lift (get L s); s \<leftarrow> lift (put L (f x) s); sput s }"

  definition modifyM :: "('a \<Longrightarrow> 's) \<Rightarrow> ('a \<Rightarrow> ('a,'s) se) \<Rightarrow> (unit,'s) se"
    (infix "%^=" 50) where
    "L %^= f \<equiv> doE {
      s \<leftarrow> sget;
      x \<leftarrow> lift (get L s);
      x \<leftarrow> f x;
      s \<leftarrow> lift (put L x s);
      sput s
    }"

  definition assign :: "('a \<Longrightarrow> 's) \<Rightarrow> 'a \<Rightarrow> (unit,'s) se"
    (infix "::=" 50) where
    "L ::= x \<equiv> doE { s \<leftarrow> sget; s \<leftarrow> lift (put L x s); sput s }"

  definition assignM (infix "::^=" 50) where
    "L ::^= x \<equiv> doE { x\<leftarrow>x; L ::= x }"

  schematic_goal [simp]: "(lift f) s = ?s"
    unfolding lift_def by simp

  schematic_goal [simp]: "(use L) s = ?s"
    unfolding use_def by simp

  schematic_goal [simp]: "(x%=f) s = ?s"
    unfolding modify_def by simp

  schematic_goal [simp]: "(x%^=f) s = ?s"
    unfolding modifyM_def by simp

  schematic_goal [simp]: "(x::=v) s = ?s"
    unfolding assign_def by simp

  schematic_goal [simp]: "(x::^=m) s = ?s"
    unfolding assignM_def by simp

  lemma wps_use_eq:
    assumes "lens L"
    assumes "pre_get L s"
    shows "wps (use L) Q s \<longleftrightarrow> Q (get' L s) s"
    using assms by (auto simp: wps_def split: sbind_splits option.splits)

  lemma wps_upd_eq:
    assumes "lens L"
    assumes "pre_get L s"
    shows "wps (L %= f) Q s \<longleftrightarrow> Q () (put' L (f (get' L s)) s)"
    using assms by (auto simp: wps_def split: sbind_splits option.splits)

  lemma wps_assign_eq:
    assumes "lens L"
    assumes "pre_put L s"
    shows "wps (L ::= x) Q s \<longleftrightarrow> Q () (put' L x s)"
    using assms by (auto simp: wps_def split: sbind_splits option.splits)

  abbreviation lens_comp_bwd (infixr "\<bullet>" 90) where "a\<bullet>b \<equiv> b;\<^sub>La"
  abbreviation idx_lens_comp ("_[_]\<^sub>L" [100,100] 100) where "l[i]\<^sub>L \<equiv> l \<bullet> idx\<^sub>L i"
  abbreviation fun_lens_comp ("_'(_')\<^sub>L" [100,100] 100) where "f(x)\<^sub>L \<equiv> f \<bullet> fun\<^sub>L x"

  section \<open>Tests and Examples\<close>

  context begin

    private definition "test1 \<equiv> doE {
      let x = id\<^sub>L;
      let i = 2;
      idx\<^sub>L i \<bullet>fst\<^sub>L ::= 41;
      x[i]\<^sub>L\<bullet>fst\<^sub>L ::= 42;
      l \<leftarrow> use x;
      sreturn (l!i)
    }"

    private lemma "test1 = doE {
      t \<leftarrow> use (id\<^sub>L[2]\<^sub>L);
      id\<^sub>L[2]\<^sub>L\<bullet>fst\<^sub>L ::= 42;
      sreturn (42, snd t)
    }"
      apply (rule ext)
      by (auto simp: test1_def split: sbind_splits option.splits)

    value "test1 [(1::nat,2::nat),(n,4),(5,6)]"
    qualified definition "Monad3_test_foo n \<equiv>
      test1 [(1::nat,2::nat),(n,4),(5,6)]"

    code_thms SE_Monad.Monad3_test_foo
    value [simp] "Monad3_test_foo 3"

    export_code SE_Monad.Monad3_test_foo checking SML

    ML_val \<open>
      @{code SE_Monad.Monad3_test_foo} (@{code nat_of_integer} 2)
    \<close>

    term "f(x)\<^sub>L \<bullet> the\<^sub>L"

    private definition "test2 \<equiv> doE {
      let db=id\<^sub>L;
      db(''Hello'')\<^sub>L\<bullet>the\<^sub>L\<bullet>snd\<^sub>L %= (+) (5::nat);
      db(''Hello'')\<^sub>L\<bullet>the\<^sub>L\<bullet>fst\<^sub>L ::= (''World'');

      r \<leftarrow> use (db(''Hello'')\<^sub>L \<bullet> the\<^sub>L   );
      sreturn r
    }"

    value "test2 [''Hello'' \<mapsto> (''x'',3::nat)]"

    private definition "test3 \<equiv> doE {
      let db=id\<^sub>L;
      db(''Hello'')\<^sub>L\<bullet>crov\<^sub>L ::= ''World'';
      r \<leftarrow> use (db(''Hello'')\<^sub>L \<bullet> the\<^sub>L );
      sreturn r
    }"

    value "test3 Map.empty"
    (* the.snd.lookup("Hello")   *)

    value "get' (the\<^sub>L \<bullet> snd\<^sub>L \<bullet> fun\<^sub>L ''Hello'') (test3 Map.empty)"

    private datatype 'a test = A (xcord: nat) (ycord: 'a) | B (name: string) | C bool bool int

    private define_lenses test

    value [code] "put' ycord\<^sub>L ''bar'' (A 3 ''foo'')"
  end

end