(*
 * Copyright 2014, NICTA
 *
 * 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)
 *)

(*
  The state and error monads in Isabelle,
*)

chapter "Monads"

theory StateMonad (* FIXME: untested/unused *)
imports Lib
begin

type_synonym ('s,'a) state_monad = "'s \<Rightarrow> 'a \<times> 's"

definition
  runState :: "('s,'a) state_monad \<Rightarrow> 's \<Rightarrow> 'a \<times> 's"
where
  "runState \<equiv> id"

definition
  "return a \<equiv> \<lambda>s. (a,s)"

definition
  bind :: "('s, 'a) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state_monad) \<Rightarrow>
           ('s, 'b) state_monad" (infixl ">>=" 60)
where
  "bind f g \<equiv> (\<lambda>s. let (v,s') = f s in (g v) s')"

definition
  "bind' f g \<equiv> bind f (\<lambda>_. g)"

declare bind'_def [iff]

definition
  "get \<equiv> \<lambda>s. (s,s)"

definition
  "put s \<equiv> \<lambda>_. ((),s)"

definition
  "gets f \<equiv> get >>= (\<lambda>s. return $ f s)"

definition
  "modify f \<equiv> get >>= (\<lambda>s. put $ f s)"

definition
  "when p s \<equiv> if p then s else return ()"

definition
  "unless p s \<equiv> when (\<not>p) s"

text \<open>The monad laws:\<close>

lemma return_bind [simp]: "(return x >>= f) = f x"
  by (simp add: return_def bind_def runState_def)

lemma bind_return [simp]: "(m >>= return) = m"
  unfolding bind_def return_def runState_def
  by (simp add: Let_def split_def)

lemma bind_assoc:
  fixes m :: "('s,'a) state_monad"
  fixes f :: "'a \<Rightarrow> ('s,'b) state_monad"
  fixes g :: "'b \<Rightarrow> ('s,'c) state_monad"
  shows "(m >>= f) >>= g  =  m >>= (\<lambda>x. f x >>= g)"
  unfolding bind_def
  by (clarsimp simp add: Let_def split_def)

text \<open>An errorT state\_monad (returnOk=return, bindE=bind):\<close>

definition
  "returnOk \<equiv> return o Inr"

definition
  "throwError \<equiv> return o Inl"

definition
  "Ok \<equiv> Inr"

definition
  lift :: "('a \<Rightarrow> ('s, 'e + 'b) state_monad) \<Rightarrow> 'e+'a \<Rightarrow> ('s, 'e + 'b) state_monad"
where
  "lift f v \<equiv> case v of Inl e \<Rightarrow> throwError e | Inr v' \<Rightarrow> f v'"

definition
  lift2 :: "('c \<Rightarrow> ('a, 'b + 'e + 'd) state_monad) \<Rightarrow> 'b+'e+'c \<Rightarrow> ('a, 'b+'e+'d) state_monad"
where
  "lift2 f v \<equiv> case v of
                 Inl e \<Rightarrow> throwError e
               | Inr v'' \<Rightarrow> (case v'' of Inl e' \<Rightarrow> return $ Inr $ Inl e' | Inr v' \<Rightarrow> f v')"

(* This is used if you are just trying to throwError by itself *)
definition
  raise :: "'a \<Rightarrow> 's \<Rightarrow> ('a + unit) \<times> 's"
where
  "raise \<equiv> return \<circ> Inl"

definition
  bindE :: "('s, 'e + 'a) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'e + 'b) state_monad) \<Rightarrow>
            ('s, 'e + 'b) state_monad"  (infixl ">>=E" 60)
where
  "bindE f g \<equiv> bind f (lift g)"

definition
  "bindE' f g \<equiv> bindE f (\<lambda>_. g)"

definition
  liftE :: "('s,'a) state_monad \<Rightarrow> ('s, 'e+'a) state_monad" where
  "liftE f \<equiv> \<lambda>s. let (v,s') = f s in (Inr v, s')"

definition
  "whenE P f \<equiv> if P then f else returnOk ()"

definition
  "unlessE P f \<equiv> if P then returnOk () else f"

definition
  "throw_opt ex x \<equiv> case x of None \<Rightarrow> throwError ex | Some v \<Rightarrow> returnOk v"

definition
  "bindEE f g \<equiv> bind f (lift2 g)"
definition
  "bindEE' f g \<equiv> bindEE f (\<lambda>_. g)"

definition
  "modifyE \<equiv> (liftE \<circ> modify)"
definition
  "getsE x \<equiv> liftE $ gets x"

syntax
  bindEE :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixl ">>=EE" 60)

declare
  bindE'_def [iff]
  bindEE_def [iff]
  bindEE'_def [iff]

lemma returnOk_bindE [simp]: "(returnOk x >>=E f) = f x"
  unfolding bindE_def return_def returnOk_def
  by (clarsimp simp: lift_def bind_def)

lemma lift_return [simp]:
  "lift (return \<circ> Inr) = return"
  by (auto simp: lift_def throwError_def split: sum.splits)

lemma bindE_returnOk [simp]: "(m >>=E returnOk) = m"
  by (simp add: bindE_def returnOk_def)

 lemma bindE_assoc:
  shows "(m >>=E f) >>=E g  =  m >>=E (\<lambda>x. f x >>=E g)"
  by (auto simp: Let_def bindE_def bind_def lift_def split_def runState_def throwError_def return_def
           split: sum.splits)

lemma throwError_bindE [simp]:
  "throwError E >>=E f = throwError E"
  by (simp add: bindE_def bind_def throwError_def lift_def return_def)

subsection "Syntax for state monad"

nonterminal
  dobinds and dobind and nobind

syntax
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ <-/ _)" 10)
  ""           :: "dobind => dobinds"                 ("_")
  "_nobind"    :: "'a => dobind"                      ("_")
  "_dobinds"   :: "[dobind, dobinds] => dobinds"      ("(_);//(_)")

  "_do"        :: "[dobinds, 'a] => 'a"               ("(do (_);//   (_)//od)" 100)
syntax (xsymbols)
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ \<leftarrow>/ _)" 10)

translations
  "_do (_dobinds b bs) e"  == "_do b (_do bs e)"
  "_do (_nobind b) e"      == "CONST bind' b e"
  "do x <- a; e od"        == "a >>= (\<lambda>x. e)"

lemma "do x \<leftarrow> return 1; return 2; return x od = return 1"
  by simp

subsection "Syntax for errorT state monad"

syntax
  "_doE" :: "[dobinds, 'a] => 'a"  ("(doE (_);//    (_)//odE)" 100)

translations
  "_doE (_dobinds b bs) e"  == "_doE b (_doE bs e)"
  "_doE (_nobind b) e"      == "CONST bindE' b e"
  "doE x <- a; e odE"       == "a >>=E (\<lambda>x. e)"

subsection "Syntax for errorT errorT state monad"

syntax
  "_doEE" :: "[dobinds, 'a] => 'a" ("(doEE (_);//     (_)//odEE)" 100)

translations
  "_doEE (_dobinds b bs) e"  == "_doEE b (_doEE bs e)"
  "_doEE (_nobind b) e"      == "CONST bindEE' b e"
  "doEE x <- a; e odEE"      == "a >>=EE (\<lambda>x. e)"

primrec
  inc_forloop :: "nat \<Rightarrow> 'g::{plus,one} \<Rightarrow> ('g \<Rightarrow> ('a, 'b + unit) state_monad) \<Rightarrow>
                  ('a, 'b + unit) state_monad"
where
  "inc_forloop 0 current body = returnOk ()"
| "inc_forloop (Suc left) current body = doE body current ; inc_forloop left (current+1) body odE"

primrec
  do_times :: "nat \<Rightarrow> ('a, 'b + unit) state_monad \<Rightarrow> ('a, 'b + unit) state_monad \<Rightarrow>
              ('a, 'b + unit) state_monad"
where
  "do_times 0 body increment = returnOk ()"
| "do_times (Suc left) body increment = doE body ; increment ; do_times left body increment odE"

definition
  function_update :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)" where
  "function_update index modifier f \<equiv>
   \<lambda>x. if x = index then modifier (f x) else (f x)"

lemma "doE x \<leftarrow> returnOk 1; returnOk 2; returnOk x odE = returnOk 1"
  by simp

term "doEE x \<leftarrow> returnOk $ Ok 1; returnOk $ Ok 2; returnOk $ Ok x odEE"

definition
  "skip \<equiv> returnOk $ Ok ()"

definition
  "liftM f m \<equiv> do x \<leftarrow> m; return (f x) od"
definition
  "liftME f m \<equiv> doE x \<leftarrow> m; returnOk (f x) odE"

definition
  "sequence_x xs \<equiv> foldr (\<lambda>x y. x >>= (\<lambda>_. y)) xs (return ())"

definition
  "zipWithM_x f xs ys \<equiv> sequence_x (zipWith f xs ys)"
definition
  "mapM_x f xs \<equiv> sequence_x (map f xs)"

definition
  "sequence xs \<equiv> let mcons = (\<lambda>p q. p >>= (\<lambda>x. q >>= (\<lambda>y. return (x#y))))
                 in foldr mcons xs (return [])"

definition
  "mapM f xs \<equiv> sequence (map f xs)"

definition
  "sequenceE_x xs \<equiv> foldr (\<lambda>x y. doE uu <- x; y odE) xs (returnOk ())"
definition
  "mapME_x f xs \<equiv> sequenceE_x (map f xs)"

definition
  "sequenceEE_x xs \<equiv> foldr bindEE' xs (skip)"
definition
  "mapMEE_x f xs \<equiv> sequenceEE_x (map f xs)"

definition
  catch :: "('s, 'a + 'b) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state_monad) \<Rightarrow> ('s, 'b) state_monad"
where
  "catch f handler \<equiv> do x \<leftarrow> f;
                        case x of
                            Inr b \<Rightarrow> return b
                          | Inl e \<Rightarrow> handler e
                      od"

definition
  handleE :: "('s, 'x + 'a) state_monad \<Rightarrow>
              ('x \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
              ('s, 'x + 'a) state_monad" (infix "<handle>" 11) where
  "f <handle> handler \<equiv>
   do v \<leftarrow> f; case v of Inl e \<Rightarrow> handler e | Inr v' \<Rightarrow> return v od"

definition
  handle_elseE :: "('s, 'x + 'a) state_monad \<Rightarrow>
                   ('x \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
                   ('a \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
                   ('s, 'x + 'a) state_monad" ("_ <handle> _ <else> _" 10)
where
  "f <handle> handler <else> continue \<equiv>
    do v \<leftarrow> f;
       case v of Inl e \<Rightarrow> handler e
               | Inr v \<Rightarrow> continue v
    od"

definition
  isSkip :: "('s, 'a) state_monad \<Rightarrow> bool" where
  "isSkip m \<equiv> \<forall>s. \<exists>r. m s = (r,s)"

lemma isSkip_bindI: "\<lbrakk> isSkip f; \<And>x. isSkip (g x) \<rbrakk> \<Longrightarrow> isSkip (f >>= g)"
  apply (clarsimp simp: isSkip_def bind_def Let_def)
  apply (erule_tac x=s in allE)
  apply clarsimp
  done

lemma isSkip_return [simp,intro!]:
  "isSkip (return x)"
  by (simp add: isSkip_def return_def)

lemma isSkip_gets [simp,intro!]:
  "isSkip (gets x)"
  by (simp add: isSkip_def gets_def get_def bind_def return_def)

lemma isSkip_liftE [iff]: "isSkip (liftE f) = isSkip f"
  apply (simp add: isSkip_def liftE_def Let_def split_def)
  apply rule
   apply clarsimp
   apply (case_tac "f s")
   apply (erule_tac x = s in allE)
   apply simp
  apply clarsimp
  apply (case_tac "f s")
  apply (erule_tac x = s in allE)
  apply simp
  done

lemma isSkip_liftI [simp, intro!]:
  "\<lbrakk> \<And>y. x = Inr y \<Longrightarrow> isSkip (f y) \<rbrakk> \<Longrightarrow> isSkip (lift f x)"
  by (simp add: lift_def throwError_def return_def isSkip_def split: sum.splits)

lemma isSkip_Error [iff]:
  "isSkip (throwError x)"
  by (simp add: throwError_def)

lemma isSkip_returnOk [iff]:
  "isSkip (returnOk x)"
  by (simp add: returnOk_def)

lemma isSkip_throw_opt [iff]:
  "isSkip (throw_opt e x)"
  by (simp add: throw_opt_def split: option.splits)

lemma nested_bind [simp]:
  "do x <- do y <- f; return (g y) od; h x od =
   do y <- f; h (g y) od"
  apply (clarsimp simp add: bind_def)
  apply (rule ext)
  apply (clarsimp simp add: Let_def split_def runState_def return_def)
  done

lemma skip_bind:
  "isSkip s \<Longrightarrow> do _ \<leftarrow> s; g od = g"
  apply (clarsimp simp add: bind_def)
  apply (rule ext)
  apply (clarsimp simp add: isSkip_def Let_def)
  apply (erule_tac x=sa in allE)
  apply clarsimp
  done

lemma bind_eqI:
  "\<lbrakk> f = f'; \<And>x. g x = g' x \<rbrakk> \<Longrightarrow> f >>= g = f' >>= g'"
  by (simp add: bind_def)

lemma bind'_cong [fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s s'. f' s = (v, s') \<Longrightarrow> g s' = g' s' \<rbrakk> \<Longrightarrow> bind' f g = bind' f' g'"
  by (auto intro: bind_cong)

lemma bindE_cong[fundef_cong]:
  "\<lbrakk> M = M' ; \<And>v s s'. M' s = (Inr v, s') \<Longrightarrow> N v s' = N' v s' \<rbrakk> \<Longrightarrow> bindE M N = bindE M' N'"
  apply (simp add: bindE_def)
  apply (rule bind_cong)
   apply (rule refl)
  apply (unfold lift_def)
  apply (case_tac v, simp_all)
  done

lemma bindE'_cong[fundef_cong]:
  "\<lbrakk> M = M' ; \<And>v s s'. M' s = (Inr v, s') \<Longrightarrow> N s' = N' s' \<rbrakk> \<Longrightarrow> bindE' M N = bindE' M' N'"
  by (auto intro: bindE_cong)

definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) state_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> split Q (f s)"

definition
  validE :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) state_monad \<Rightarrow> ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>, \<lbrace>_\<rbrace>") where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> split (\<lambda>r s. case r of Inr b \<Rightarrow> Q b s
                                                  | Inl a \<Rightarrow> R a s) (f s)"

lemma validE_def2:
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace> \<equiv> \<lbrace>P\<rbrace> f \<lbrace> \<lambda>r s. case r of Inr b \<Rightarrow> Q b s | Inl a \<Rightarrow> R a s \<rbrace>"
  by (unfold valid_def validE_def)

(* FIXME: modernize *)
syntax top :: "'a \<Rightarrow> bool" ("\<top>")
       bottom :: "'a \<Rightarrow> bool" ("\<bottom>")

translations
  "\<top>" == "\<lambda>_. CONST True"
  "\<bottom>" == "\<lambda>_. CONST False"

definition
  bipred_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" (infixl "And" 96)
where
  "bipred_conj P Q \<equiv> \<lambda>x y. P x y \<and> Q x y"

definition
  bipred_disj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" (infixl "Or" 91)
where
  "bipred_disj P Q \<equiv> \<lambda>x y. P x y \<or> Q x y"

definition
  bipred_neg :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" ("Not _") where
  "bipred_neg P \<equiv> \<lambda>x y. \<not> P x y"

syntax toptop :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<top>\<top>")
       botbot :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<bottom>\<bottom>")

translations "\<top>\<top>" == "\<lambda>_ _. CONST True"
             "\<bottom>\<bottom>" == "\<lambda>_ _. CONST False"

definition
  pred_lift_exact :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" ("\<guillemotleft>_,_\<guillemotright>") where
  "pred_lift_exact P Q \<equiv> \<lambda>x y. P x \<and> Q y"

lemma pred_lift_taut[simp]: "\<guillemotleft>\<top>,\<top>\<guillemotright> = \<top>\<top>"
  by (simp add:pred_lift_exact_def)

lemma pred_lift_cont_l[simp]: "\<guillemotleft>\<bottom>,x\<guillemotright> = \<bottom>\<bottom>"
  by (simp add:pred_lift_exact_def)

lemma pred_lift_cont_r[simp]: "\<guillemotleft>x,\<bottom>\<guillemotright> = \<bottom>\<bottom>"
  by (simp add:pred_lift_exact_def)

lemma pred_liftI[intro!]: "\<lbrakk> P x; Q y \<rbrakk> \<Longrightarrow> \<guillemotleft>P,Q\<guillemotright> x y"
  by (simp add:pred_lift_exact_def)

lemma pred_exact_split:
  "\<guillemotleft>P,Q\<guillemotright> = (\<guillemotleft>P,\<top>\<guillemotright> And \<guillemotleft>\<top>,Q\<guillemotright>)"
  by (simp add:pred_lift_exact_def bipred_conj_def)

lemma pred_andE[elim!]: "\<lbrakk> (A and B) x; \<lbrakk> A x; B x \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (simp add:pred_conj_def)

lemma pred_andI[intro!]: "\<lbrakk> A x; B x \<rbrakk> \<Longrightarrow> (A and B) x"
  by (simp add:pred_conj_def)

lemma bipred_conj_app[simp]: "(P And Q) x = (P x and Q x)"
  by (simp add:pred_conj_def bipred_conj_def)

lemma bipred_disj_app[simp]: "(P Or Q) x = (P x or Q x)"
  by (simp add:pred_disj_def bipred_disj_def)

lemma pred_conj_app[simp]: "(P and Q) x = (P x \<and> Q x)"
  by (simp add:pred_conj_def)

lemma pred_disj_app[simp]: "(P or Q) x = (P x \<or> Q x)"
  by (simp add:pred_disj_def)

lemma pred_notnotD[simp]: "(not not P) = P"
  by (simp add:pred_neg_def)

lemma bipred_notnotD[simp]: "(Not Not P) = P"
  by (simp add:bipred_neg_def)

lemma pred_lift_add[simp]: "\<guillemotleft>P,Q\<guillemotright> x = ((\<lambda>s. P x) and Q)"
  by (simp add:pred_lift_exact_def pred_conj_def)

lemma pred_and_true[simp]: "(P and \<top>) = P"
  by (simp add:pred_conj_def)

lemma pred_and_true_var[simp]: "(\<top> and P) = P"
  by (simp add:pred_conj_def)

lemma pred_and_false[simp]: "(P and \<bottom>) = \<bottom>"
  by (simp add:pred_conj_def)

lemma pred_and_false_var[simp]: "(\<bottom> and P) = \<bottom>"
  by (simp add:pred_conj_def)

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>
   \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  apply (clarsimp simp: valid_def runState_def bind_def Let_def split_def)
  apply (case_tac "f s")
  apply fastforce
  done

lemma seq:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>"
  assumes "\<And>x. P x \<Longrightarrow> \<lbrace>C\<rbrace> g x \<lbrace>D\<rbrace>"
  assumes "\<And>x s. B x s \<Longrightarrow> P x \<and> C s"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  using assms by (blast intro: seq')

lemma seq_invar_nobind:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. \<lbrace>A\<rbrace> g x \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  apply(rule_tac B="\<guillemotleft>\<top>,A\<guillemotright>" and C="A" and P="\<top>" in seq)
    apply(insert f_valid g_valid)
    apply(simp_all add:pred_lift_exact_def)
  done

lemma seq_invar_bind:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>B,A\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. P x \<Longrightarrow> \<lbrace>A\<rbrace> g x \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  assumes bind: "\<And>x. B x \<Longrightarrow> P x"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  apply(rule_tac B="\<guillemotleft>B,A\<guillemotright>" and C="A" and P="P" in seq)
    apply(insert f_valid g_valid bind)
    apply(simp_all add: pred_lift_exact_def)
  done

lemma seq_noimp:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>C,B\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. C x \<Longrightarrow> \<lbrace>B\<rbrace> g x \<lbrace>D\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  apply(rule_tac B="\<guillemotleft>C,B\<guillemotright>" and C="B" and P="C" in seq)
    apply(insert f_valid g_valid, simp_all add:pred_lift_exact_def)
  done

lemma seq_ext':
  "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>; \<forall>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 (clarsimp simp: valid_def runState_def bind_def Let_def split_def)

lemma seq_ext:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>" "\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>C\<rbrace>"
  using assms by (blast intro: seq_ext')

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>
   \<lbrace>A\<rbrace> doE x \<leftarrow> f; g x odE \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  apply(simp add: bindE_def lift_def bind_def Let_def split_def)
  apply(clarsimp simp: validE_def)
  apply(rename_tac s r x)
  apply(case_tac "fst (f s)"; case_tac r; fastforce simp:throwError_def return_def)
  done

lemma seqE:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>,\<lbrace>E\<rbrace>" "\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  shows "\<lbrace>A\<rbrace> doE x \<leftarrow> f; g x odE \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  using assms by(blast intro: seqE')

lemma get_sp:
  "\<lbrace>P\<rbrace> get \<lbrace>\<lambda>a s. s = a \<and> P s\<rbrace>"
  by (simp add:get_def valid_def)

lemma put_sp:
  "\<lbrace>\<top>\<rbrace> put a \<lbrace>\<lambda>_ s. s = a\<rbrace>"
  by (simp add:put_def valid_def)

lemma return_sp:
  "\<lbrace>P\<rbrace> return a \<lbrace>\<lambda>b s. b = a \<and> P s\<rbrace>"
  by (simp add:return_def valid_def)

lemma hoare_post_conj [intro!]:
  "\<lbrakk> \<lbrace> P \<rbrace> a \<lbrace> Q \<rbrace>; \<lbrace> P \<rbrace> a \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> a \<lbrace> Q And R \<rbrace>"
  by (simp add:valid_def split_def bipred_conj_def)

lemma hoare_pre_disj [intro!]:
  "\<lbrakk> \<lbrace> P \<rbrace> a \<lbrace> R \<rbrace>; \<lbrace> Q \<rbrace> a \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> P or Q \<rbrace> a \<lbrace> R \<rbrace>"
  by (simp add:valid_def pred_disj_def)

lemma hoare_post_taut [iff]: "\<lbrace> P \<rbrace> a \<lbrace> \<top>\<top> \<rbrace>"
  by (simp add:valid_def)

lemma hoare_pre_cont [iff]: "\<lbrace> \<bottom> \<rbrace> a \<lbrace> P \<rbrace>"
  by (simp add:valid_def)

lemma hoare_return [intro!]: "\<And>x. P x \<Longrightarrow> \<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>P,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_drop [iff]: "\<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>\<top>,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_drop_var [iff]: "\<lbrace> Q \<rbrace> return x \<lbrace> \<lambda>r. Q \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_only [intro!]: "\<And>x. P x \<Longrightarrow> \<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>P,\<top>\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_get [iff]: "\<lbrace> P \<rbrace> get \<lbrace> \<guillemotleft>P,P\<guillemotright> \<rbrace>"
  by (simp add:valid_def get_def pred_lift_exact_def)

lemma hoare_gets [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) s \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> gets f \<lbrace> Q \<rbrace>"
  by (simp add:valid_def gets_def get_def bind_def return_def)

lemma hoare_modify [iff]: "\<lbrace> P o f \<rbrace> modify f \<lbrace> \<guillemotleft>\<top>,P\<guillemotright> \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_modifyE [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> modify f \<lbrace> \<guillemotleft>\<top>,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_modifyE_var [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> modify f \<lbrace> \<lambda>r s. Q s \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_put [intro!]: "P x \<Longrightarrow> \<lbrace> Q \<rbrace> put x \<lbrace> \<guillemotleft>\<top>,P\<guillemotright>\<rbrace>"
  by (simp add:valid_def put_def pred_lift_exact_def)

lemma hoare_if [intro!]:
  "\<lbrakk> P \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> R \<rbrace>; \<not> P \<Longrightarrow> \<lbrace> Q \<rbrace> b \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> if P then a else b \<lbrace> R \<rbrace>"
  by (simp add:valid_def)

lemma hoare_when [intro!]:
  "\<lbrakk> \<lbrakk> P \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>; \<And>s. \<lbrakk> \<not> P; Q s \<rbrakk> \<Longrightarrow> R s \<rbrakk> \<Longrightarrow>
   \<lbrace> Q \<rbrace> when P a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>"
  by (simp add:valid_def when_def split_def return_def pred_lift_exact_def)

lemma hoare_unless [intro!]:
  "\<lbrakk> \<And>s. \<lbrakk> P; Q s \<rbrakk> \<Longrightarrow> R s; \<lbrakk> \<not> P \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace> \<rbrakk> \<Longrightarrow>
   \<lbrace> Q \<rbrace> unless P a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>"
  by (simp add:valid_def unless_def split_def when_def return_def pred_lift_exact_def)

lemma hoare_pre_subst: "\<lbrakk> A = B; \<lbrace>A\<rbrace> a \<lbrace>C\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>B\<rbrace> a \<lbrace>C\<rbrace>"
  by (clarsimp simp:valid_def split_def)

lemma hoare_post_subst: "\<lbrakk> B = C; \<lbrace>A\<rbrace> a \<lbrace>B\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> a \<lbrace>C\<rbrace>"
  by (clarsimp simp:valid_def split_def)

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 (clarsimp simp:valid_def split_def pred_conj_def pred_neg_def, blast)

lemma hoare_return_var[intro!]: "\<lbrakk> \<And>x. P x \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> (\<And>x. P x \<Longrightarrow> \<lbrace>R\<rbrace> return x \<lbrace>\<guillemotleft>Q,R\<guillemotright>\<rbrace>)"
  by (rule hoare_return)

lemma hoare_return_drop_imp[intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> return x \<lbrace>\<guillemotleft>\<top>,Q\<guillemotright>\<rbrace>"
 by (simp add:valid_def return_def)

lemmas hoare_case_option_inference = option.exhaust

lemma hoare_pre_imp: "\<lbrakk> \<lbrace>Q\<rbrace> a \<lbrace>R\<rbrace>; \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>"
  by (simp add:valid_def)

lemma hoare_post_imp: "\<lbrakk> \<lbrace>P\<rbrace> a \<lbrace>Q\<rbrace>; \<And>r s. Q r s \<Longrightarrow> R r s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>"
  by (simp add:valid_def split_def)

lemma hoare_post_impE:
  "\<lbrakk> \<lbrace>P\<rbrace> a \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>; \<And>r s. Q r s \<Longrightarrow> R r s; \<And>e s. E e s \<Longrightarrow> F e s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>,\<lbrace>F\<rbrace>"
  apply(clarsimp simp: validE_def)
  apply(rename_tac s r x)
  apply(case_tac r; fastforce)
  done

lemma "isSkip f \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> \<guillemotleft>\<top>,P\<guillemotright> \<rbrace>"
  apply (clarsimp simp: valid_def split_def isSkip_def)
  apply (rename_tac s)
  apply (case_tac "f s")
  apply (erule_tac x=s in allE)
  apply auto
  done

end


(*  Title:      HOL/TLA/Buffer/DBuffer.thy
    Author:     Stephan Merz, University of Munich
*)

section {* Two FIFO buffers in a row, with interleaving assumption *}

theory DBuffer
imports Buffer
begin

axiomatization
  (* implementation variables *)
  inp  :: "nat stfun" and
  mid  :: "nat stfun" and
  out  :: "nat stfun" and
  q1   :: "nat list stfun" and
  q2   :: "nat list stfun" and
  qc   :: "nat list stfun" and

  DBInit :: stpred and
  DBEnq :: action and
  DBDeq :: action and
  DBPass :: action and
  DBNext :: action and
  DBuffer :: temporal
where
  DB_base:        "basevars (inp,mid,out,q1,q2)" and

  (* the concatenation of the two buffers *)
  qc_def:         "PRED qc == PRED (q2 @ q1)" and

  DBInit_def:     "DBInit   == PRED (BInit inp q1 mid  &  BInit mid q2 out)" and
  DBEnq_def:      "DBEnq    == ACT  Enq inp q1 mid  &  unchanged (q2,out)" and
  DBDeq_def:      "DBDeq    == ACT  Deq mid q2 out  &  unchanged (inp,q1)" and
  DBPass_def:     "DBPass   == ACT  Deq inp q1 mid
                                 & (q2$ = $q2 @ [ mid$ ])
                                 & (out$ = $out)" and
  DBNext_def:     "DBNext   == ACT  (DBEnq | DBDeq | DBPass)" and
  DBuffer_def:    "DBuffer  == TEMP Init DBInit
                                 & [][DBNext]_(inp,mid,out,q1,q2)
                                 & WF(DBDeq)_(inp,mid,out,q1,q2)
                                 & WF(DBPass)_(inp,mid,out,q1,q2)"

declare qc_def [simp]

lemmas db_defs =
  BInit_def Enq_def Deq_def Next_def IBuffer_def Buffer_def
  DBInit_def DBEnq_def DBDeq_def DBPass_def DBNext_def DBuffer_def

(*** Proper initialization ***)
lemma DBInit: "|- Init DBInit --> Init (BInit inp qc out)"
  by (auto simp: Init_def DBInit_def BInit_def)

(*** Step simulation ***)
lemma DB_step_simulation: "|- [DBNext]_(inp,mid,out,q1,q2) --> [Next inp qc out]_(inp,qc,out)"
  apply (rule square_simulation)
   apply clarsimp
  apply (tactic
    {* action_simp_tac (@{context} addsimps (@{thm hd_append} :: @{thms db_defs})) [] [] 1 *})
  done

(*** Simulation of fairness ***)

(* Compute enabledness predicates for DBDeq and DBPass actions *)
lemma DBDeq_visible: "|- <DBDeq>_(inp,mid,out,q1,q2) = DBDeq"
  apply (unfold angle_def DBDeq_def Deq_def)
  apply (safe, simp (asm_lr))+
  done

lemma DBDeq_enabled:
    "|- Enabled (<DBDeq>_(inp,mid,out,q1,q2)) = (q2 ~= #[])"
  apply (unfold DBDeq_visible [action_rewrite])
  apply (force intro!: DB_base [THEN base_enabled, temp_use]
    elim!: enabledE simp: angle_def DBDeq_def Deq_def)
  done

lemma DBPass_visible: "|- <DBPass>_(inp,mid,out,q1,q2) = DBPass"
  by (auto simp: angle_def DBPass_def Deq_def)

lemma DBPass_enabled:
    "|- Enabled (<DBPass>_(inp,mid,out,q1,q2)) = (q1 ~= #[])"
  apply (unfold DBPass_visible [action_rewrite])
  apply (force intro!: DB_base [THEN base_enabled, temp_use]
    elim!: enabledE simp: angle_def DBPass_def Deq_def)
  done

(* The plan for proving weak fairness at the higher level is to prove
   (0)  DBuffer => (Enabled (Deq inp qc out) ~> (Deq inp qc out))
   which is in turn reduced to the two leadsto conditions
   (1)  DBuffer => (Enabled (Deq inp qc out) ~> q2 ~= [])
   (2)  DBuffer => (q2 ~= [] ~> DBDeq)
   and the fact that DBDeq implies <Deq inp qc out>_(inp,qc,out)
   (and therefore DBDeq ~> <Deq inp qc out>_(inp,qc,out) trivially holds).

   Condition (1) is reduced to
   (1a) DBuffer => (qc ~= [] /\ q2 = [] ~> q2 ~= [])
   by standard leadsto rules (leadsto_classical) and rule Deq_enabledE.

   Both (1a) and (2) are proved from DBuffer's WF conditions by standard
   WF reasoning (Lamport's WF1 and WF_leadsto).
   The condition WF(Deq inp qc out) follows from (0) by rule leadsto_WF.

   One could use Lamport's WF2 instead.
*)

(* Condition (1a) *)
lemma DBFair_1a: "|- [][DBNext]_(inp,mid,out,q1,q2) & WF(DBPass)_(inp,mid,out,q1,q2)
         --> (qc ~= #[] & q2 = #[] ~> q2 ~= #[])"
  apply (rule WF1)
    apply (force simp: db_defs)
   apply (force simp: angle_def DBPass_def)
  apply (force simp: DBPass_enabled [temp_use])
  done

(* Condition (1) *)
lemma DBFair_1: "|- [][DBNext]_(inp,mid,out,q1,q2) & WF(DBPass)_(inp,mid,out,q1,q2)
         --> (Enabled (<Deq inp qc out>_(inp,qc,out)) ~> q2 ~= #[])"
  apply clarsimp
  apply (rule leadsto_classical [temp_use])
  apply (rule DBFair_1a [temp_use, THEN LatticeTransitivity [temp_use]])
  apply assumption+
  apply (rule ImplLeadsto_gen [temp_use])
  apply (force intro!: necT [temp_use] dest!: STL2_gen [temp_use] Deq_enabledE [temp_use]
    simp add: Init_defs)
  done

(* Condition (2) *)
lemma DBFair_2: "|- [][DBNext]_(inp,mid,out,q1,q2) & WF(DBDeq)_(inp,mid,out,q1,q2)
         --> (q2 ~= #[] ~> DBDeq)"
  apply (rule WF_leadsto)
    apply (force simp: DBDeq_enabled [temp_use])
   apply (force simp: angle_def)
  apply (force simp: db_defs elim!: Stable [temp_use])
  done

(* High-level fairness *)
lemma DBFair: "|- [][DBNext]_(inp,mid,out,q1,q2) & WF(DBPass)_(inp,mid,out,q1,q2)
                                        & WF(DBDeq)_(inp,mid,out,q1,q2)
         --> WF(Deq inp qc out)_(inp,qc,out)"
  apply (auto simp del: qc_def intro!: leadsto_WF [temp_use]
    DBFair_1 [temp_use, THEN [2] LatticeTransitivity [temp_use]]
    DBFair_2 [temp_use, THEN [2] LatticeTransitivity [temp_use]])
  apply (auto intro!: ImplLeadsto_simple [temp_use]
    simp: angle_def DBDeq_def Deq_def hd_append [try_rewrite])
  done

(*** Main theorem ***)
lemma DBuffer_impl_Buffer: "|- DBuffer --> Buffer inp out"
  apply (unfold DBuffer_def Buffer_def IBuffer_def)
  apply (force intro!: eexI [temp_use] DBInit [temp_use]
    DB_step_simulation [THEN STL4, temp_use] DBFair [temp_use])
  done

end


(* Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Preliminaries\<close>

theory MFMC_Misc imports
  "HOL-Probability.Probability"
  "HOL-Library.Transitive_Closure_Table"
  "HOL-Library.Complete_Partial_Order2"
  "HOL-Library.Bourbaki_Witt_Fixpoint"
begin

hide_const (open) cycle
hide_const (open) path
hide_const (open) cut
hide_const (open) orthogonal

lemmas disjE [consumes 1, case_names left right, cases pred] = disjE

lemma inj_on_Pair2 [simp]: "inj_on (Pair x) A"
by(simp add: inj_on_def)

lemma inj_on_Pair1 [simp]: "inj_on (\<lambda>x. (x, y)) A"
by(simp add: inj_on_def)

lemma inj_map_prod': "\<lbrakk> inj f; inj g \<rbrakk> \<Longrightarrow> inj_on (map_prod f g) X"
by(rule subset_inj_on[OF prod.inj_map subset_UNIV])

lemma not_range_Inr: "x \<notin> range Inr \<longleftrightarrow> x \<in> range Inl"
by(cases x) auto

lemma not_range_Inl: "x \<notin> range Inl \<longleftrightarrow> x \<in> range Inr"
by(cases x) auto

lemma Chains_into_chain: "M \<in> Chains {(x, y). R x y} \<Longrightarrow> Complete_Partial_Order.chain R M"
by(simp add: Chains_def chain_def)

lemma chain_dual: "Complete_Partial_Order.chain (\<ge>) = Complete_Partial_Order.chain (\<le>)"
by(auto simp add: fun_eq_iff chain_def)

lemma Cauchy_real_Suc_diff:
  fixes X :: "nat \<Rightarrow> real" and x :: real
  assumes bounded: "\<And>n. \<bar>f (Suc n) - f n\<bar> \<le> (c / x ^ n)"
  and x: "1 < x"
  shows "Cauchy f"
proof(cases "c > 0")
  case c: True
  show ?thesis
  proof(rule metric_CauchyI)
    fix \<epsilon> :: real
    assume "0 < \<epsilon>"

    from bounded[of 0] x have c_nonneg: "0 \<le> c" by simp
    from x have "0 < ln x" by simp
    from reals_Archimedean3[OF this] obtain M :: nat
      where "ln (c * x) - ln (\<epsilon> * (x - 1)) < real M * ln x" by blast
    hence "exp (ln (c * x) - ln (\<epsilon> * (x - 1))) < exp (real M * ln x)" by(rule exp_less_mono)
    hence M: "c * (1 / x) ^ M / (1 - 1 / x) < \<epsilon>" using \<open>0 < \<epsilon>\<close> x c
      by (simp add: exp_diff exp_of_nat_mult field_simps del: ln_mult)

    { fix n m :: nat
      assume "n \<ge> M" "m \<ge> M"
      then have "\<bar>f m - f n\<bar> \<le> c * ((1 / x) ^ M - (1 / x) ^ max m n) / (1 - 1 / x)"
      proof(induction n m rule: linorder_wlog)
        case sym thus ?case by(simp add: abs_minus_commute max.commute min.commute)
      next
        case (le m n)
        then show ?case
        proof(induction k\<equiv>"n - m" arbitrary: n m)
          case 0 thus ?case using x c_nonneg by(simp add: field_simps mult_left_mono)
        next
          case (Suc k m n)
          from \<open>Suc k = _\<close> obtain m' where m: "m = Suc m'" by(cases m) simp_all
          with \<open>Suc k = _\<close> Suc.prems have "k = m' - n" "n \<le> m'" "M \<le> n" "M \<le> m'" by simp_all
          hence "\<bar>f m' - f n\<bar> \<le> c * ((1 / x) ^ M - (1 / x) ^ (max m' n)) / (1 - 1 / x)" by(rule Suc)
          also have "\<dots> = c * ((1 / x) ^ M - (1 / x) ^ m') / (1 - 1 / x)" using \<open>n \<le> m'\<close> by(simp add: max_def)
          moreover
          from bounded have "\<bar>f m - f m'\<bar> \<le> (c / x ^ m')" by(simp add: m)
          ultimately have "\<bar>f m' - f n\<bar> + \<bar>f m - f m'\<bar> \<le> c * ((1 / x) ^ M - (1 / x) ^ m') / (1 - 1 / x) + \<dots>" by simp
          also have "\<dots> \<le> c * ((1 / x) ^ M - (1 / x) ^ m) / (1 - 1 / x)" using m x by(simp add: field_simps)
          also have "\<bar>f m - f n\<bar> \<le> \<bar>f m' - f n\<bar> + \<bar>f m - f m'\<bar>"
            using abs_triangle_ineq4[of "f m' - f n" "f m - f m'"] by simp
          ultimately show ?case using \<open>n \<le> m\<close> by(simp add: max_def)
        qed
      qed
      also have "\<dots> < c * (1 / x) ^ M / (1 - 1 / x)" using x c by(auto simp add: field_simps)
      also have "\<dots> < \<epsilon>" using M .
      finally have "\<bar>f m - f n\<bar> < \<epsilon>" . }
    thus "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (f m) (f n) < \<epsilon>" unfolding dist_real_def by blast
  qed
next
  case False
  with bounded[of 0] have [simp]: "c = 0" by simp
  have eq: "f m = f 0" for m
  proof(induction m)
    case (Suc m) from bounded[of m] Suc.IH show ?case by simp
  qed simp
  show ?thesis by(rule metric_CauchyI)(subst (1 2) eq; simp)
qed

lemma complete_lattice_ccpo_dual:
  "class.ccpo Inf (\<ge>) ((>) :: _ :: complete_lattice \<Rightarrow> _)"
by(unfold_locales)(auto intro: Inf_lower Inf_greatest)

lemma card_eq_1_iff: "card A = Suc 0 \<longleftrightarrow> (\<exists>x. A = {x})"
using card_eq_SucD by auto

lemma nth_rotate1: "n < length xs \<Longrightarrow> rotate1 xs ! n = xs ! (Suc n mod length xs)"
apply(cases xs; clarsimp simp add: nth_append not_less)
apply(subgoal_tac "n = length list"; simp)
done

lemma set_zip_rightI: "\<lbrakk> x \<in> set ys; length xs \<ge> length ys \<rbrakk> \<Longrightarrow> \<exists>z. (z, x) \<in> set (zip xs ys)"
by(fastforce simp add: in_set_zip in_set_conv_nth simp del: length_greater_0_conv intro!: nth_zip conjI[rotated])

lemma map_eq_append_conv:
  "map f xs = ys @ zs \<longleftrightarrow> (\<exists>ys' zs'. xs = ys' @ zs' \<and> ys = map f ys' \<and> zs = map f zs')"
by(auto 4 4 intro: exI[where x="take (length ys) xs"] exI[where x="drop (length ys) xs"] simp add: append_eq_conv_conj take_map drop_map dest: sym)

lemma rotate1_append:
  "rotate1 (xs @ ys) = (if xs = [] then rotate1 ys else tl xs @ ys @ [hd xs])"
by(clarsimp simp add: neq_Nil_conv)

lemma in_set_tlD: "x \<in> set (tl xs) \<Longrightarrow> x \<in> set xs"
by(cases xs) simp_all

lemma countable_converseI:
  assumes "countable A"
  shows "countable (converse A)"
proof -
  have "converse A = prod.swap ` A" by auto
  then show ?thesis using assms by simp
qed

lemma countable_converse [simp]: "countable (converse A) \<longleftrightarrow> countable A"
using countable_converseI[of A] countable_converseI[of "converse A"] by auto

lemma nn_integral_count_space_reindex:
  "inj_on f A \<Longrightarrow>(\<integral>\<^sup>+ y. g y \<partial>count_space (f ` A)) = (\<integral>\<^sup>+ x. g (f x) \<partial>count_space A)"
by(simp add: embed_measure_count_space'[symmetric] nn_integral_embed_measure' measurable_embed_measure1)

syntax
  "_nn_sum" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(2\<Sum>\<^sup>+ _\<in>_./ _)" [0, 51, 10] 10)
  "_nn_sum_UNIV" :: "pttrn \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add" ("(2\<Sum>\<^sup>+ _./ _)" [0, 10] 10)
translations
  "\<Sum>\<^sup>+ i\<in>A. b" \<rightleftharpoons> "CONST nn_integral (CONST count_space A) (\<lambda>i. b)"
  "\<Sum>\<^sup>+ i. b" \<rightleftharpoons> "\<Sum>\<^sup>+ i\<in>CONST UNIV. b"

inductive_simps rtrancl_path_simps:
  "rtrancl_path R x [] y"
  "rtrancl_path R x (a # bs) y"

definition restrict_rel :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
where "restrict_rel A R = {(x, y)\<in>R. x \<in> A \<and> y \<in> A}"

lemma in_restrict_rel_iff: "(x, y) \<in> restrict_rel A R \<longleftrightarrow> (x, y) \<in> R \<and> x \<in> A \<and> y \<in> A"
by(simp add: restrict_rel_def)

lemma restrict_relE: "\<lbrakk> (x, y) \<in> restrict_rel A R; \<lbrakk> (x, y) \<in> R; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis"
by(simp add: restrict_rel_def)

lemma restrict_relI [intro!]: "\<lbrakk> (x, y) \<in> R; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x, y) \<in> restrict_rel A R"
by(simp add: restrict_rel_def)

lemma Field_restrict_rel_subset: "Field (restrict_rel A R) \<subseteq> A \<inter> Field R"
by(auto simp add: Field_def in_restrict_rel_iff)

lemma Field_restrict_rel [simp]: "Refl R \<Longrightarrow> Field (restrict_rel A R) = A \<inter> Field R"
using Field_restrict_rel_subset[of A R]
by auto (auto simp add: Field_def dest: refl_onD)

lemma Partial_order_restrict_rel:
  assumes "Partial_order R"
  shows "Partial_order (restrict_rel A R)"
proof -
  from assms have "Refl R" by(simp add: order_on_defs)
  from Field_restrict_rel[OF this, of A] assms show ?thesis
    by(simp add: order_on_defs trans_def antisym_def)
      (auto intro: FieldI1 FieldI2 intro!: refl_onI simp add: in_restrict_rel_iff elim: refl_onD)
qed

lemma Chains_restrict_relD: "M \<in> Chains (restrict_rel A leq) \<Longrightarrow> M \<in> Chains leq"
by(auto simp add: Chains_def in_restrict_rel_iff)

lemma bourbaki_witt_fixpoint_restrict_rel:
  assumes leq: "Partial_order leq"
  and chain_Field: "\<And>M. \<lbrakk> M \<in> Chains (restrict_rel A leq); M \<noteq> {} \<rbrakk> \<Longrightarrow> lub M \<in> A"
  and lub_least: "\<And>M z. \<lbrakk> M \<in> Chains leq; M \<noteq> {}; \<And>x. x \<in> M \<Longrightarrow> (x, z) \<in> leq \<rbrakk> \<Longrightarrow> (lub M, z) \<in> leq"
  and lub_upper: "\<And>M z. \<lbrakk> M \<in> Chains leq; z \<in> M \<rbrakk> \<Longrightarrow> (z, lub M) \<in> leq"
  and increasing: "\<And>x. \<lbrakk> x \<in> A; x \<in> Field leq \<rbrakk> \<Longrightarrow> (x, f x) \<in> leq \<and> f x \<in> A"
  shows "bourbaki_witt_fixpoint lub (restrict_rel A leq) f"
proof
  show "Partial_order (restrict_rel A leq)" using leq by(rule Partial_order_restrict_rel)
next
  from leq have Refl: "Refl leq" by(simp add: order_on_defs)

  { fix M z
    assume M: "M \<in> Chains (restrict_rel A leq)"
    presume z: "z \<in> M"
    hence "M \<noteq> {}" by auto
    with M have lubA: "lub M \<in> A" by(rule chain_Field)
    from M have M': "M \<in> Chains leq" by(rule Chains_restrict_relD)
    then have *: "(z, lub M) \<in> leq" using z by(rule lub_upper)
    hence "lub M \<in> Field leq" by(rule FieldI2)
    with lubA show "lub M \<in> Field (restrict_rel A leq)" by(simp add: Field_restrict_rel[OF Refl])
    from Chains_FieldD[OF M z] have "z \<in> A" by(simp add: Field_restrict_rel[OF Refl])
    with * lubA show "(z, lub M ) \<in> restrict_rel A leq" by auto

    fix z
    assume upper: "\<And>x. x \<in> M \<Longrightarrow> (x, z) \<in> restrict_rel A leq"
    from upper[OF z] have "z \<in> Field (restrict_rel A leq)" by(auto simp add: Field_def)
    with Field_restrict_rel_subset[of A leq] have "z \<in> A" by blast
    moreover from lub_least[OF M' \<open>M \<noteq> {}\<close>] upper have "(lub M, z) \<in> leq"
      by(auto simp add: in_restrict_rel_iff)
    ultimately show "(lub M, z) \<in> restrict_rel A leq" using lubA by(simp add: in_restrict_rel_iff) }
  { fix x
    assume "x \<in> Field (restrict_rel A leq)"
    hence "x \<in> A" "x \<in> Field leq" by(simp_all add: Field_restrict_rel[OF Refl])
    with increasing[OF this] show "(x, f x) \<in> restrict_rel A leq" by auto }
  show "(SOME x. x \<in> M) \<in> M" "(SOME x. x \<in> M) \<in> M" if "M \<noteq> {}" for M :: "'a set"
    using that by(auto intro: someI)
qed

lemma Field_le [simp]: "Field {(x :: _ :: preorder, y). x \<le> y} = UNIV"
by(auto intro: FieldI1)

lemma Field_ge [simp]: "Field {(x :: _ :: preorder, y). y \<le> x} = UNIV"
by(auto intro: FieldI1)

lemma refl_le [simp]: "refl {(x :: _ :: preorder, y). x \<le> y}"
by(auto intro!: refl_onI simp add: Field_def)

lemma refl_ge [simp]: "refl {(x :: _ :: preorder, y). y \<le> x}"
by(auto intro!: refl_onI simp add: Field_def)

lemma partial_order_le [simp]: "partial_order_on UNIV {(x :: _ :: order, x'). x \<le> x'}"
by(auto simp add: order_on_defs trans_def antisym_def)

lemma partial_order_ge [simp]: "partial_order_on UNIV {(x :: _ :: order, x'). x' \<le> x}"
by(auto simp add: order_on_defs trans_def antisym_def)

lemma incseq_chain_range: "incseq f \<Longrightarrow> Complete_Partial_Order.chain (\<le>) (range f)"
apply(rule chainI; clarsimp)
 using linear by (auto dest: incseqD)

end