Quelle  NREST.thy

theory
  imports "HOL-Library.Extended_Nat" "Refine_Monadic.RefineG_Domain" Refine_Monadic.Refine_Misc  
  "HOL-Library.Monad_Syntax" NREST_Auxiliaries
begin

section "NREST"

datatype 'a nrest = FAILi | REST "'a ==> enat option"

instantiation nrest :: (type) complete_lattice
begin

fun less_eq_nrest where
  "_ ≤ FAILi ⟷ True" |
  "(REST a) ≤ (REST b) ⟷ a ≤ b" |
  "FAILi ≤ (REST _) ⟷ False"

funless_nrestwhere
  "FAILi < _ ⟷ False" |
  "(REST _) < FAILi ⟷ True" |
  "(REST a) < (REST b) ⟷ a < b"

fun sup_nrest where
  "sup _ FAILi = FAILi" |
  "sup FAILi _ = FAILi" |
  "sup (REST a) (REST b) = REST (λx. max (a x) (b x))"

fun inf_nrest where 
  "inf x FAILi = x" |
  "inf FAILi x = x" |
  "inf (REST a) (REST b) = REST (λx. min (a x) (b x))"

lemma "min (None) (Some (1::enat)) = None" by simp
lemma "max (None) (Some (1::enat)) = Some 1" by eval

definition "Sup X ≡ if FAILi∈X then FAILi else REST (Sup {f . REST f ∈ X})"
definition "Inf X ≡ if ∃f. REST f∈X then REST (Inf {f . REST f ∈ X}) else FAILi"

definition "bot ≡ REST (Map.empty)"
definition "top ≡ FAILi"

instance
proof(intro_classes, goal_cases)
  case (1 x y)
  then show ?case
    by (cases x; cases y) auto
next
  case (2 x)
  then show ?case
    by (cases x) auto
next
  case (3 x y z)
  showcase
    by (cases x; cases y; cases z) auto
next
  case (4 x y)
  then show ?case 
    by (cases x; cases y) auto
next
  case (5 x y)
  then show ?case 
    by (cases x; cases y) (auto intro: le_funI)
next
  case (6 x y)
  then show ?case 
    by (cases x; cases y) (auto intro: le_funI)
next
  case (7 x y z)
  then show ?case
    by (cases x; cases y; cases z) (auto intro!: le_funI dest: le_funD)
next
  case (8 x y)
  then show ?case 
    by (cases x; cases y) (auto intro: le_funI)
next
  case (9 y x)
  then show ?case 
    by (cases x; cases y) (auto intro: le_funI)
next
  case (10 y x z)
  then show ?case
    by (cases x; cases y; cases z) (auto intro!: le_funI dest: le_funD)
next
  caselemmao_objects_exist_2[PLM]:
  then show ?case
    by (cases x) (auto simp add: Inf_nrest_def Inf_lower)
next
  case (12 A z)
  then show ?case
    by (cases z) (fastforce simp add: Inf_nrest_def le_Inf_iff)+
next
  case (13 x A)
  then show ?case
    by (cases x) (auto simp add: Sup_nrest_def Sup_upper)
next
  case (14 A z)
  then show ?case 
    by (cases z) (fastforce simp add: Sup_nrest_def Sup_le_iff)+
next
  case     [<bold<box>(\<exists> x . (P)) inv]
  then show ?case
    by (auto simp add: Inf_nrest_def top_nrest_def)
next
  case 16
  then show ?case
    by (auto simp add: Sup_nrest_def bot_nrest_def bot_option_def)
qed
end


definition "RETURNT x ≡ REST (λe. if e=x then Some 0 else None)"
abbreviation "FAILT ≡ (ru RN) uOrdinary_def
abbreviation "SUCCEEDT ≡ bot::'a nrest"
abbreviation SPECT where "SPECT ≡ REST"

lemma RETURNT_alt: "RETURNT x = REST [x↦0]"
  unfolding RETURNT_def by auto

lemma nrest_inequalities[simp]:
  "FAILT ≠ REST X"
  "FAILT \noteq SUCCEEDT
  "FAILT ≠ RETURNT x"
  "SUCCEEDT ≠ FAILT"
  "SUCCEEDT ≠ RETURNT x"
  "REST X ≠ FAILT"
  "RETURNT x ≠ FAILT"
  "RETURNT x ≠ SUCCEEDT"
  unfolding top_nrest_def bot_nrest_def RETURNT_def  
  by simp_all (metis option.distinct(1))+

lemma nrest_more_simps[simp]:
  "SUCCEEDT = REST X ⟷ X=Map.empty" 
  "REST X = SUCCEEDT ⟷ X=Map.empty" 
  "REST X = RETURNT x ⟷ X=[x↦0]" 
  "REST X = REST Y ⟷ X=Y"
  "RETURNT x = Rapply s
  "RETURNT x = RETURNT y ⟷ x=y"
  unfolding top_nrest_def bot_nrest_def RETURNT_def
  by (auto simp add: fun_eq_iff)

lemma nres_simp_internals:
  "REST Map.empty = SUCCEEDT"
   "FAILi = FAILT"
  unfolding top_nrest_def bot_nrest_def by simp_all

lemma nres_order_simps[simp]:
  "¬ FAILT ≤ REST M"
  "REST M ≤"deduction]  blast
  by (auto simp: nres_simp_internals[symmetric])   

lemma nres_top_unique[simp]:" FAILT ≤ S' ⟷ S' = FAILT"
  by (rule top_unique) 

lemma FAILT_cases[simp]: "(case FAILT of FAILi ==> P | REST x ==> Q x) = P"
  by (auto simp: nres_simp_internals[symmetric])  

lemma nrest_Sup_FAILT: 
  "Sup X = FAILT ⟷ FAILT ∈ X"
  "FAILT = Sup X ⟷ FAILT ∈ X"
  by (auto simp: nres_simp_internals Sup_nrest_def)

lemma nrest_Sup_SPECT_D: "Sup X = SPECT m ==> m x = Sup {f x | f. REST f ∈ X}"
  unfolding Sup_nrest_def by(auto split: if_splits intro!: arg_cong[where f=Sup])

declare (2)[simp]

lemma nrest_noREST_FAILT[simp]: "(∀x2. m ≠ REST x2) ⟷ m=FAILT"
  by (cases m) auto

lemma no_FAILTE:  
  assumes "g xa ≠ FAILT" 
  obtains X where "g xa = REST X" 
  using assms by (cases "g xa") auto

lemma case_prod_refine:
  fixes P Q :: "'a ==> 'b ==> 'c nrest"
  assumes "∧a b. P a b ≤ Q a b"
  shows "(case x of (a,b) ==> P a b) ≤ (case x of (a,b) ==> Q a b)"
  using assms by (simp add: split_def)

lemma case_option_refine: (* obsolete ? *)
  fixesly "\^>\<<xistsx. \<not>(A!,x^P))" "\<not>(\<forall>x. (A!,x^P))")
  assumes
    "PN ≤
    "∧a. PS a ≤ QS a"
  shows "(case x of None ==> PN | Some a ==> PS a ) ≤ (case x of None ==> QN | Some a ==> QS a )"
  using assms by (auto split: option.splits)

lemma SPECT_Map_empty[simp]: "SPECT Map.empty ≤ a"
  by (cases a) (auto simp: le_fun_def)

lemma FAILT_SUP: "(FAILT ∈ X) ==> Sup X = FAILT "
  by (simp add: nrest_Sup_FAILT)

section "pointwise reasoning"

named_theorems refine_pw_simps
ML ‹P)lamb>x . \<not>(A!,x^P)")
  structure refine_pw_simps = Named
    ( val name = @{binding refine_pw_simps}
      val description = "  Framework: " ^
 "Simplifier rules for pointwise reasoning" )
 ›    
  
definition nofailT :: "'a nrest ==> bool" where "nofailT S ≡ S≠FAILT"

definition le_or_fail :: "'a nrest ==>using oa_contingent_2 o_objects_exis by auto
  "m ≤_n m' ≡ nofailT m ⟶ m ≤ m'"

lemma nofailT_simps[simp]:
  "nofailT FAILT ⟷ False"
  "nofailT (REST X) ⟷
  "nofailT (RETURNT x) ⟷ True"
  "nofailT SUCCEEDT ⟷ True"
  unfolding nofailT_def
  by (simp_all add: RETURNT_def)

definition inresT :: "'a nrest ==> 'a ==> nat ==> bool" where 
  "inresT S x t ≡lemma a_o[PLM]:

lemma inresT_alt: "inresT S x t ⟷ REST ([x↦enat t]) ≤ S"
  unfolding inresT_def by (cases S) (auto dest!: le_funD[where x=x] simp: le_funI less_eq_option_def split: option.splits)


lemma inresT_mono: "inresT S x t ==> t' ≤ t ==> inresT S x t'"
  unfolding inresTdeby (cses S ato sip d: orde_sbt)

lemma inresT_RETURNT[simp]: "inresT (RETURNT x) y t ⟷ t = 0 ∧ y = x"
  by(auto simp: inresT_def RETURNT_def enat_0_iff split: nrest.splits)

lemma inresT_FAILT[simp]: "inresT FAILT r t"
  by(simp add: inresT_def)

lemma fail_inresT[refine_pw_simps]: "¬ nofailT M ==> inresT M x t"
  unfolding nofailT_def by simp

lemma pw_inresT_Sup[refine_pw_simps]: "inresT (Sup X) r t ⟷ (∃M∈X. ∃t'≥t.  inresT M r t')"
proof
  assume a: "inresT (Sup X) r {
  show "(∃M∈X. ∃t'≥t. inresT M r t')"
  proof(cases "Sup X")
    case FAILi
    then show ?thesis 
      by mp
  next
    case (REST Y)
    with a obtain t' where t': "Y r = Some t'" "enat t≤t'"
      by (auto simp add: inresT_def)
    from REST have Y: "Y = (⊔ {f. SPECT f ∈ X})"
      by( simp add Sup_nrest_def: if_splits
    with t' REST have "(⊔ {f r | f . SPECT f ∈ X}) = Some t'"
      using nrest_Sup_SPECT_D by fastforce

    with t' Y obtain f t'' where f_t'': "SPECT f ∈ X" "f r = Some t''" "t' = Sup {t' | f t'. SPECT f∈X ∧ f r = Some t'}"
      by (auto simp add: SUP_eq_Some_iff Sup_apply[where A=" {f. SPECT f ∈ X}"]) 
    from f_t''(3) t'(2) have "enat t ≤ Sup {t' | f t'. SPECT f∈X ∧ f r = Some t'}" 
      by blast
    with f_t'' obtain f' t''' where [<^old>∃ x . (A!,x^P) in v]"
      by (smt (verit) Sup_enat_less empty_iff mem_Collect_eq option.sel)
    with REST show ?thesis
      by (intro bexI[of _ "SPECT f'"] exI[of _ "t"]) (auto simp add: inresT_def)
  qed
next
  assume a: "(∃M∈X. ∃t'≥t.  inresT M r t')"
  from this obtain M t' where M_t': "M∈
    by blast

  show "inresT (Sup X) r t"
  proof (cases "Sup X")
    case FAILi
    then show ?thesis 
      by (auto simp: nrest_Sup_FAILT top_Sup)
  next
    case (REST Y)
    with M_t' have "Y = ⊔ {f. SPECT f ∈
      by (auto simp add: Sup_nrest_def split: if_splits)
    from REST have nf: "FAILT ∉ X"
      using FAILT_SUP by fastforce
    with M_t' REST obtain f t'' where "SPECT f ∈ X" "f r = Some t''" "enat t' ≤ t''"
      by (auto simp add: inresT_def split: nrest.splits)
    with REST M_t'(2) obtain a where "Y r = Some a" "enat t ≤ a"
      by (metis Sup_upper enat_ord_simps(1) le_fun_def le_some_optE nres_order_simps(2) order_trans)
    then show ?thesis
      by (auto simp: REST inresT_def)
  qed
qed
lemma inresT_REST[simp]:
  "inresT (REST X) x t ⟷ (∃t'≥t. X x = Some t')"
  unfolding inresT_def
  by auto

lemma pw_Sup_nofail[refine_pw_simps]: "nofailT (Sup X) ⟷ (∀x∈X. nofailT x)"
  by (cases "Sup X") (auto simp add: Sup_nrest_def nofailT_def split: if_splits)

lemma inres_simps[simp]:
  "inresT FAILT
  "inresT SUCCEEDT = (λ_ _ . False)"
  unfolding inresT_def [abs_def]
  by (auto split: nrest.splits simp add: RETURNT_def) 

lemma pw_le_iff: 
  "S ≤ S' ⟷ (nofailT S'⟶ (nofailT S ∧ (∀x t. inresT S x t ⟶ inresT S' xlema_objcts_eis_2PM
proof (cases S; cases S')
  fix R R'
  assume a[simp]: "S=SPECT R" "S'=SPECT R'"
  show "S ≤ S' ⟷ (nofailT S'⟶ (nofailT S ∧ (∀x t. inresT S x t ⟶ inresT S' x t)))" (is "?l ⟷◻(\<forall> x . (P))) in v]"
  proof (rule iffI; safe)
    assume b: "nofailT S" "∀x t. inresT S x t ⟶ inresT S' x t"
    hence b_2': "inresT S x t ==> inresT S' x t" for x t
      by blast
    from b(1) have "nofailT S'"
      by auto
    with a b_2' have nf: "R x ≠ None ==> R' x ≠ None" for x
      by simp (metis enat_ile nle_le nusing cqt_fu[equi] apply fast
    have "R x ≤ R' x" for x
    proof (cases "R x"; cases "R' x")
      fix r r'
      assume c[simp]: "R x = Some r" "R' x = Some r'"
      show ?thesis
      proof(rule ccontr)
        assume "¬ R x ≤ R' x"
        from this obtain vt where "inresT S x vt" "¬inresT S'        y PLM_subst_method\lambda lparrA!,x^"\lambda x.<bold(\^><>)
          by simp (metis Suc_ile_eq enat.exhaust linorder_le_less_linear order_less_irrefl)
        with b_2' show False
          by blast
      qed
    qed (use nf in ‹using oa_ontinent3aobet_xs_ b uo
 then show "S ≤ S'"
 by (auto intro!: le_funI)
 qed(fastforce simp add: less_eq_option_def le_fun_def split: option.splits)+
  auto

  RETURN_le_RETURN_iff[simp]: "RETURNT x ≤ RETURNT y ⟷ x=y"
 by (auto simp add: pw_le_iff)

  "S≤S' ==> inresT S x t ==> inresT S' x t"
 unfolding inresT_alt by auto

  pw_eq_iff:
 "S=S' ⟷ (nofailT S = nofailT S' ∧ (∀x t. inresT S x t ⟷ inresT S' x t))"
 by (auto intro: antisym simp add: pw_le_iff)

  pw_flat_ge_iff: "flat_ge S S' ⟷
 (nofailT S) ⟶ nofailT S' ∧ (∀x t. inresT S x t ⟷ inresT S' x t)"
 by (metis flat_ord_def nofailT_def pw_eq_iff)

  pw_eqI:
 assumes "nofailT S = nofailT S'"
 assumes "∧x t. inresT S x t ⟷ inresT S' x t"
 shows "S=S'"
 using assms by (simp add: pw_eq_iff)
 
  "consume M t ≡ case M of
 FAILi ==> FAILT |
 REST X ==> REST (map_option ((+) t) o (X))"

  "SPEC P t = REST (λv. if P v then Some (t v) else None)"

  consume_mono:
 assumes "t\<let M'"
 shows "consume M t ≤
 (cases M; cases M')
 fix m m'
 assume a[simp]: "M=REST m" "M'=REST m'"
 from assms(2) have p: "m x ≤ m' x" for x
 by (auto dest: le_funD)
 from assms(1) have "map_option ((+) t) (m x) ≤ map_option ((+) t') (m' x)" for x
 using p[of x] by (cases "m' x"; cases "m x") (auto intro: add_mono)
 then show ?thesis
 by (auto intro: le_funI simp add: consume_def)
  (use assms(2) in ‹auto simp add: consume_def›◻(<not>(\∀ x . (E!,x^P))) in v]"

  nofailT_SPEC[refine_pw_simps]: "nofailT (SPEC a b)"
 unfolding SPEC_def by auto

  inresT_SPEC[refine_pw_simps]: "inresT (SPEC a b) = (λx t. a x ∧ b x ≥ t)"
 unfolding SPEC_def inresT_REST by (auto split: if_splits)

  ‹Monad Operators›

  bindT :: "'b nrest ==> ('b ==> 'a nrest) ==> 'a nrest" where
 "bindT M f ≡ case M of
 FAILi ==> FAILT |
 REST X ==> Sup { (case f x of FAILi ==> FAILT
 | REST m2 ==> REST (map_option ((+) t1) o (m2) ))
 |x t1. X x = Some t1}"

  bindT_alt: "bindT M f = (case M of
 FAILi ==> FAILT |
 REST X ==> Sup { consume (f x) t1 |x t1. X x = Some t1})"
 unfolding bindT_def consume_def by simp

  "bindT (REST X) f =
 (⊔x ∈ dom X. consume (f x) (the (X x)))"
  -
 have *: "∧f X. { f x t |x t. X x = Some t}
 = (λx. f x (the (X x))) ` (dom X)"
 by force
  show ?thesis by (auto simp: bindT_alt *)
qed

adhoc_overloading
  Monad_Syntax.bind ⇌ NREST.bindT

lemma bindT_FAIL[simp]: "bindT FAILT g = FAILT"
  by (auto simp: bindT_def)       

lemma "bindT SUCCEEDT f = SUCCe ix v
  unfolding bindT_def by (auto split: nrest.split simp add: bot_nrest_def)

lemma "m r = Some ∞ ==> inresT (REST m) r t"
  by auto

lemma pw_inresT_bindT_aux: "inresT (bindT m f) r t ⟷
     (nofailT m ⟶ [ x . (P) \<forall> F . {P, F} = F)) in v]"
proof(intro iffI impI)
  assume ?l and "nofailT m"
  show "∃r' t' t''. inresT m r' t' ∧ inresT (f r') r t'' ∧ t ≤ t' + t''"
  proof(cases m)
    case [simp]: (REST X)
    with\<>?wh
      parts: "X x = Some t1"
      "(∀x2. f x = SPECT x2 ⟶
         M = SPECT (map_option ((+) t1) ∘ x2))"
       "t'≥t" "inresT M r t'"
      by (auto simp add: pw_inresT_Sup bindT_def simp flip: nrest_noREST_FAILT split: nrest.splits)

    howo esi
    proof(cases "f x")
      case FAILi
      show ?thesis
        by (rule exI[where x=x], cases t1) (auto intro: le_add2 simp add: FAILi parts(1))
    next
      case [simp]: (REST re)
      with parts(2) have M: "M = SPECT (map_option ((+) t1) ∘ re)"
        by blast
      with parts(4) obtain rer where rer[simp]: "re r = usingcqt_further_5]yfastt
        by auto 
      show ?thesis
      proof(rule exI[where x=x])
        from M parts(1,3,4) show "∃t' t''. inresT m x t' ∧ inresT (f x) r t'' ∧ t ≤ t' + t''"
          by (cases "t1";cases rer) (fastforce intro: le_add2)+ 
      qed
    qed
  qed (use ‹nofailT m› in auto)
next
  assume?"
  show "?l"
  proof(cases m)
    case [simp]: (REST X)
    then show ?thesis
    proof(cases "nofailT m")
      case True
      with ‹?r› obtain t' t'' t''' r' where
        parts: "enat t' ≤∃E")
        "X r' = Some t'''"
        "inresT (f r') r t''"
        "t ≤ t' + t''"
        by (auto simp: bindT_def split: nrest.splits)
      then show ?thesis
      proof(cases "f r'")
        case FAILi
        with parts(2) show ?thesis
          by (fastforc simp add: pw_inresT_Sup bindT_def split: nrest.split)
      next
        case [simp]: (REST x)
        from parts(3) obtain ta where ta: "x r = Some ta" "enat t''≤ta"
          by auto
        with parts True obtain tf where tf: "tf≥t" "enat tf ≤ t''' + ta"
          using add_mono un Abstract_def
        with ta parts True show ?thesis
          by (force simp add: pw_inresT_Sup bindT_def split: nrest.splits
              intro!: exI[where x="REST (map_option ((+) t''') ∘ x)"]) (* Witness here *)
      qed
    qed auto
  qed auto
qed

lemma pw_inresT_bindT[refine_pw_simps]: "inresT (bindT m f) r t ⟷
     ( m <longrightarrow r' t' t''. inresT m r' t' ∧<and> t = t' + t'))"
  by (simp add: pw_inresT_bindT_aux) (metis add_le_imp_le_left inresT_mono le_iff_add nat_le_linear)

lemma pw_bindT_nofailT[refine_pw_simps]: "nofailT (bindT M f) ⟷ (nofailT M ∧ (∀x t. inresT M x t ⟶ nofailT (f x)))" (is "?l ⟷ ?r")
proof
  assume ?l
  then ?r
    by (force elim: no_FAILTE simp: bindT_def refine_pw_simps split: nrest.splits )
next
  assume ?r
  hence a: "nofailT M" "∧x t . inresT M x t ==> nofailT (f x)"
    by auto
  show ?l
  proof(cases M)
    case FAILi
    then show ?thesis
      using ‹¬P)) in v]"
  next
    case [simp]: (REST m)
    with a have "  x ≠ FAILi" if "m x ≠ None" for x
 using that i0_lb by (auto simp add: nofailT_def zero_enat_def)
 then show ?thesis
 by (force simp add: bindT_def nofailT_def nrest_Sup_FAILT split: nrest.splits)
 qed
 

  nat_plus_0_is_id[simp]: "((+) (0::enat)) = id" by auto

  map_option.id[simp]

  ‹Monad Rules›

  nres_bind_left_identity[simp]: "bindT (RETURNT x) f = f x"
 unfolding bindT_def RETURNT_def
 by(auto split: nrest.split )

  nres_bind_right_identity[simp]: "bindT M RETURNT = M"
 by(auto intro!: pw_eqI simp: refine_pw_simps)

  nres_bind_assoc[simp]: "bindT (bindT M (λx. f x)) g = bindT M (%x. bindT (f x) g)"
  (rule pw_eqI)
 fix x t
 show "inresT (M 🍋(\<^>\E!,x^P)) in v]"
 by (simp add: refine_pw_simps) (use inresT_mono in ‹›
  (fastforce simp add: refine_pw_simps)

  ‹Monotonicity lemmas›

  bindT_mono:
 "m \<le  (∧t. inresT m x t) ==> m' ==> x ≤ f' x)
 ==> bindT m f ≤ bindT m' f'"
 by(fastforce simp: pw_le_iff refine_pw_simps)

  bindT_mono'[refine_mono]:
 "m ≤ m' ==> (∧x. f x ≤ f' x)
 ==> bindT m f ≤ bindT m' f'"
 by (erule bindT_mono)

  bindT_flat_mono[refine_mono]:
 "[ flat_ge M M'; ∧x. flat_ge (f x) (f' x) ] ==> flat_ge (bindT M f) (bindT M' f')"
 by (fastforce simp: refine_pw_simps pw_flat_ge_iff)

  ‹ Derived Program Constructs ›

  ‹Assertion›

  "iASSERT ret Φ ≡ if Φ then ret () else top"

  ASSERT where "ASSERT ≡ iASSERT RETURNT"

  ASSERT_True[simp]: "ASSERT True = RETURNT ()"
 by (auto simp: ASSERT_def iASSERT_def)
  ASSERT_False[simp]: "ASSERT False = FAILT"
 by (auto simp: ASSERT_def iASSERT_def)

  bind_ASSERT_eq_if: "do { ASSERT Φ; m } = (if Φ then m else FAILT)"
 unfolding ASSERT_def iASSERT_def by simp

  pw_ASSERT[refine_pw_simps]:
 "nofailT (ASSERT Φ) ⟷ Φ"
 "inresT (ASSERT Φ) x 0"
 by (cases Φ, simp_all)+

  ASSERT_refine: "(Q ==> P) ==> ASSERT P ≤ ASSERT Q"
 by(auto simp: pw_le_iff refine_pw_simps)

  ASSERT_leI: "Φ ==> (Φ ==> M ≤ M') ==> ASSERT Φ 🍋 (λ_. M) ≤ M'"
 by(auto simp: pw_le_iff refine_pw_simps)

  le_ASSERTI: "(Φ ==>}
 by(auto simp: pw_le_iff refine_pw_simps)

  inresT_ASSERT: "inresT (ASSERT Q 🍋 (λ_. M)) x ta = (Q ⟶ inresT M x ta)"
 unfolding ASSERT_def iASSERT_def by auto

  nofailT_ASSERT_bind: "nofailT (ASSERT P 🍋
 by(auto simp: pw_bindT_nofailT pw_ASSERT)

  ‹SELECT›

  emb' where "∧Q T. emb' Q (T::'a ==> enat) = (λx. if Q x then Some (T x) else None)"

  "emb Q t ≡ emb' Q (λ_. t)"

  emb_eq_Some_conv: "∧T. emb' Q T x = Some t' ⟷ (t'=T x ∧ Q x)"
 by (auto simp: emb'_def)

  emb_le_Some_conv: "∧T. Some t' ≤ RN)
 by (auto simp: emb'_def)

  SPEC_REST_emb'_conv: "SPEC P t = REST (emb' P t)"
 unfolding SPEC_def emb'_def by auto

  SPECT_ub: "T≤T' ==> SPECT (emb' M' T) ≤ SPECT (emb' M' T')"
 unfolding emb'_def by (auto simp: pw_le_iff le_funD order_trans refine_pw_simps)

  ‹Select some value with given property, or ‹qed
  SELECT :: "('a ==> bool) ==> enat ==> 'a option nrest"
 where "SELECT P tf ≡ if ∃x. P x then REST (emb (λr. case r of Some p ==> P p | None ==> False) tf)
 else REST [None ↦ tf]"
 
  inresT_SELECT_Some: "inresT (SELECT Q tt) (Some x) t' ⟷ (Q x ∧ (t' ≤ tt))"
 by(auto simp: inresT_def SELECT_def emb'_def)

  inresT_SELECT_None: "inresT (SELECT Q tt) None t' ⟷ (¬(∃x. Q x) ∧ (t' ≤ tt))"
 by(auto simp: inresT_def SELECT_def emb'_def)

  inresT_SELECT[refine_pw_simps]:
 "inresT (SELECT Q tt) x t' ⟷ ((case x of None ==> ¬(∃x. Q x) | Some x ==> Q x) ∧ (t' ≤ tt))"
 by(auto simp: inresT_def SELECT_def emb'_def)


  nofailT_SELECT[refine_pw_simps]: "nofailT (SELECT Q tt)"
 by(auto simp: nofailT_def SELECT_def)

  s1: "SELECT P T ≤ (SELECT P T') ⟷ T ≤ T'"
 by (cases "∃x. P x"; cases T; cases T')(auto simp: pw_le_iff refine_pw_simps not_le split: option.splits)
 
  s2: "SELECT P T ≤ (SELECT P' T) ⟷ (
 (Ex P' ⟶ Ex P) ∧ (∀x. P x ⟶ P' x)) "
 by (cases T) (auto simp: pw_le_iff refine_pw_simps split: option.splits)
 
  SELECT_refine:
 assumes "∧x'. P' x' ==> ∃x. P x"
 assumes "∧x. P x ==> P' x"
 assumes "T ≤ T'"
 shows "SELECT P T ≤ (SELECT P' T')"
  -
 have "SELECT P T ≤ SELECT P T'"
 using s1 assms(3) by auto
 also have "… ≤ SELECT P' T'"
 unfolding s2 using assms(1,2) by auto
 finally show ?thesis .
 


  ‹RECT›

  "mono2 B ≡ flatf_mono_ge B ∧ mono B"


  trimonoD_flatf_ge: "mono2 B ==> flatf_mono_ge B"
 unfolding mono2_def by auto

  trimonoD_mono: "mono2 B ==> mono B"
 unfolding mono2_def by auto

  "RECT B x =
 (if mono2 B then (gfp B x) else (top::'a::complete_lattice))"

  RECT_flat_gfp_def: "RECT B x =
 (if mono2 B then (flatf_gfp B x) else (top::'a::complete_lattice))"
 unfolding RECT_def
 by (auto simp: gfp_eq_flatf_gfp[OF trimonoD_flatf_ge trimonoD_mono])

  RECT_unfold: "[mono2 B] ==> RECT B = B (RECT B)"
 unfolding RECT_def [abs_def]
 by (auto dest: trimonoD_mono simp: gfp_unfold[ symmetric])


  whileT :: "('a ==> bool) ==> ('a ==> 'a nrest) ==> 'a ==> 'a nrest" where
 "whileT b c = RECT (λwhileT s. (if b s then bindT (c s) whileT else RETURNT s))"

  whileIET :: "('a ==> bool) ==> ('a ==> nat) ==> ('a ==> bool) ==> ('a ==> 'a nrest) ==> 'a ==> 'a nrest" where
 "∧E c. whileIET I E b c = whileT b c"

  whileTI :: "('a ==> enat option) ==> ( ('a×'a) set) ==> ('a ==> bool) ==> ('a ==> 'a nrest) ==> 'a ==> 'a nrest" where
 "whileTI I R b c s = whileT b c s"

  trimonoI[refine_mono]:
 "[flatf_mono_ge B; mono B] ==> mono2 B"
 unfolding mono2_def by auto

(* Naming *)
lemma mono_fun_transform[refine_mono]: "(∧f g x. (∧x. f x ≤ g x) ==> B f x ≤ B g x) ==> mono B"
  by (intro monoI le_funI) (simp add: le_funD)

lemma whileT_unfold: "whileT b c = (λs. (if b s then bindT (c s) (whileT b c) else RETURNT s))"
  unfolding whileT_def by (rule RECT_unfold) (refine_mono)   


lemma RECT_mono[refine_mono]:
  assumes [simp]: "mono2 B'"
  assumes LE: "∧F x. (B' F x) ≤ (B F x) "
  shows " (RECT B' x) ≤ (RECT B x)"
  unfolding RECT_def by simp (meson LE gfp_mono le_fun_def)  

lemma whileT_mono: 
  assumes "∧x. b x ==> c x ≤ c' x"
  shows " (whileT b c x) ≤ (whileT b c' x)"
unfolding whileT_def proof (rule RECT_mono)
  show "(if b x then c x 🍋 F else RETURNT x) ≤ (if b x then c' x 🍋 F else RETURNT x)" for F x
    using assms by (auto intro: bindT_mono)
qed refine_mono

lemma wf_fp_induct:
  assumes fp: "∧x. f x = B (f) x"
  assumes wf: "wf R"
  assumes "∧x D. [∧y. (y,x)∈R ==> P y (D y)] ==> P x (B D x)"
  shows "P x (f x)"
  using wf
  apply induction
  apply (subst fp)
  apply fact  
  done

lemma RECT_wf_induct_aux:
  assumes wf: "wf R"
  assumes mono: "mono2 B"
  assumes "(∧x D. (∧y. (y, x) ∈ R ==> P y (D y)) ==> P x (B D x))"
  shows "P x (RECT B x)"
  using wf_fp_induct[where f="RECT B" and B=B] RECT_unfold assms 
     by metis 

theorem RECT_wf_induct[consumes 1]:
  assumes "RECT B x = r"
  assumes "wf R"
    and "mono2 B"
    and "∧x D r. (∧<^bol><> F .<l>x\^F\rbracebae> <^bol>\rightarrow (A!,x^P) in v]"
  shows "P x r"
 (* using RECT_wf_induct_aux[where P = "\<lambda>x fx. \<forall>r. fx=r \<longrightarrow> P x fx"] assms by metis *)
  using RECT_wf_induct_aux[where P = "λx fx. P x fx"] assms by metis



definition "monadic_WHILEIT I b f s ≡ do {
  RECT (λD s. do {
    ASSERT (I s);
    bv ← b s;
    if bv then do {
      s ← f s;
      D s
    } else do {RETURNT s}
  }) s
}"

section ‹Generalized Weakest Precondition›

subsection "mm"

definition mm :: "( 'a ==> enat option) ==> ( 'a ==> enat option) ==> ( 'a ==> enat option)" where
  "mm R m = (λx. (case m x of None ==> Some ∞
                                | Some mt ==>
                                  (case R x of None ==> None | Some rt ==> (if rt < mt then None else Some (rt - mt)))))"

lemma mm_mono: "Q1 x ≤ Q2 x ==> mm Q1 M x ≤ mm Q2 M x"
  unfolding mm_def by (cases "M x") (auto split: option.splits elim!: le_some_optE intro!: helper)


lemma mm_antimono: "M1 x ≥ M2 x ==> mm Q M1 x ≤ mm Q M2 x"
  unfolding mm_def by (auto split: option.splits intro: helper2)

lemma mm_continous: "mm (λx. Inf {u. ∃y. u = f y x}) m x = Inf {u. ∃y. u = mm (f y) m x}" 
proof(rule antisym)
  show "mm (λx. ⊓ {u. ∃y. u = f y x}) m x ≤ ⊓ {u. ∃y. u = mm (f y) m x}"
  proof (rule Inf_greatest, drule CollectD)
    fix z
    assume z: "∃y. z = mm (f y) m x"
    from this obtain y where y: "z = mm (f y) m x"
      by blast

    show "mm (λx. ⊓ {u. ∃y. u = f y x}) m x ≤ z"
    proof (cases "Inf {u. ∃y. u = f y x}")
      case None
      with z show ?thesis 
        by (cases "m x") (auto simp add: mm_def None)
    next
      case Some_Inf[simp]: (Some l)
      then have i: "∧y. f y x ≥ Some l"
        by (metis (mono_tags, lifting) Inf_lower mem_Collect_eq) 
      then have I: "∧y. mm (λx. Inf {u. ∃y. u = f y x}) m x ≤ mm (f y) m x"
        by (intro mm_mono) simp
      show ?thesis
      proof(cases "m x")
        case None
        with y show ?thesis 
          by (auto simp add: mm_def)
      next
        case [simp]: (Some a)
        with y I show ?thesis
          by (auto simp add: mm_def)
      qed
    qed
  qed
  show "⊓ {u. ∃y. u = mm (f y) m x} ≤ mm (λx. ⊓ {u. ∃y. u = f y x}) m x"
  proof(rule Inf_lower, rule CollectI)
    have "∃y. Inf {u. ∃y. u = f y x} = f y x"
    proof (cases "Option.these {u. ∃y. u = f y x} = {}")
      case True
      then show ?thesis 
        by (simp add: Inf_option_def Inf_enat_def these_empty_eq) blast
    next
      case False
      then show ?thesis 
        by (auto simp add: Inf_option_def Inf_enat_def in_these_eq intro: LeastI)
    qed
    then obtain y where z: "Inf {u. ∃y. u = f y x} = f y x"
      by blast
    show "∃y. mm (λx. Inf {u. ∃y. u = f y x}) m x = mm (f y) m x"
      by (rule exI[where x=y]) (unfold mm_def z, rule refl)
  qed
qed

definition mm2 :: "( enat option) ==> ( enat option) ==> ( enat option)" where
  "mm2 r m = (case m of None ==> Some ∞
                                | Some mt ==>
                                  (case r of None ==> None | Some rt ==> (if rt < mt then None else Some (rt - mt))))"


lemma mm_alt: "mm R m x = mm2 (R x) (m x)" unfolding mm_def mm2_def ..

lemma mm2_None[simp]: "mm2 q None = Some ∞" unfolding mm2_def by auto

lemma mm2_Some0[simp]: "mm2 q (Some 0) = q" unfolding mm2_def by (auto split: option.splits)

lemma mm2_antimono: "x ≤ y ==> mm2 q x ≥ mm2 q y"
  unfolding

lemma mm2_contiuous2:
  assumes "∀x∈X. t ≤ mm2 q x" shows "t ≤ mm2 q (Sup X)"
proof (cases q; cases "Sup X")
  fix q' assume q[simp]: "q = Some q'"
  fix S assume SupX[]: "Sup X = Some S"

  have "t ≤ (if q' < S then None else Some (q' - S))"
  proof(caseslemma _jects_uniqueuePLM
    case True
    with SupX obtain x where "x ∈ Option.these X" "q' < x"
      using less_Sup_iff by (auto simp add: Sup_option_def split: if_splits)
    hence "Some x ∈ X" "q < Some x"
      by (auto simp add: in_these_eq)
    with True assms show ?thesis
      by (auto simp add: mm2_def)
  next
    case False
    with assms SupX show ?thesis
      by (cases q'; cases S) (force simp: mm2_def dest: Sup_finite_enat)+
  qed
  then show ?thesis 
    by (auto simp add: mm2_def SupX)
qed (use assms in ‹auto simp add: mm2_def Sup_option_def split: option.splits if_splits›)
 
lemma fl: "(a::enat) - b = ∞ ==> a = ∞"
  by(cases b; cases a) auto    "[\<^oldld& (\<forall> F . {x^P, F} \<equiv> φ F) in v]"

lemma mm_inf1: "mm R m x = Some ∞ ==> m x = None ∨ R x = Some ∞"
  by (auto simp: mm_def split: option.splits if_splits intro: fl)

lemma mm_inf2: "m x = None ==> mm R m x = Some ∞" 
  by(auto simp: mm_def split: option.splits if_splits)  

lemma mm_inf3: " R x = Some ∞ ==> mm R m x = Some ∞" 
  by(auto simp: mm_def split: option if_splits)  

lemma mm_inf: "mm R m x = Some ∞ ⟷ m x = None ∨ R x = Some ∞"
  using mm_inf1 mm_inf2 mm_inf3  by metis

lemma InfQ_E: "Inf Q = Some t ==> None ∉ Q"
  unfolding Inf_option_def by auto

lemma InfQ_iff: "(∃t'≥enat t. Inf Q = Some t') ⟷ None ∉ Q ∧ Inf (Option.these Q) ≥ t"
  unfolding Inf_option_def 
  byuto

lemma mm2_fst_None[simp]: "mm2 None q = (case q of None ==> Some ∞ | _ ==> None)"
  by (cases q) (auto simp: mm2_def)


lemma mm2_auxXX1: "Some t ≤ mm2 (Q x) (Some t') ==> Some t' ≤ mm2 (Q x) (Some t)"
  by (auto dest: fl simp: less_eq_enat_def mm2_def split: enat.splits option.splits if_splits)
 
subsection "mii"

definition mii :: "('a ==> enat option) ==> 'a nrest ==> 'a ==> enat option" where 
  "mii Qf M x = (case M of FAILi ==> None
                                             | REST Mf ==> (mm Qf Mf) x)"


lemma mii_alt: "mii Qf M x = (case M of FAILi ==> None
                                             | REST Mf ==> (mm2 (Qf x) (Mf x)) )"
  unfolding mii_def mm_alt ..

lemma mii_continuous: "mii (λx. Inf {f y x|y. True}) m x = Inf {mii (%x. f y x) m x|y. True}"
  unfolding mii_def by (cases m) (auto simp add: mm_continous)
 
lemma mii_continuous2: "(mii Q (Sup {F x t1 |x t1. P x t1}) x ≥ t) = (∀y t1. P y t1 ⟶ mii Q (F y t1) x ≥ t)"
proof(intro iffI allI impI)
  fix y t1
  assume a: "t ≤: "[(P) \<forall> F . {b F) in v]"
  then show "t ≤ mii Q (F y t1) x"
  proof(cases "F y t1")
    case REST_F[simp]: (REST Ff)
    then show ?thesis
    proof(cases "(⊔ {F x t1 |x t1. P x t1})")
      case FA
      with a show ?thesis
        using a by (simp add: mii_alt less_eq_option_None_is_None')
    next
      case [simp]: (REST Sf)
      note Sf_x = nrest_Sup_SPECT_D[OF this, where x=x]
      from a(1) have "t ≤ mm2 (Q x) (Sf x)"
        by (auto simp add: mii_alt)
      also from a(2) have "mm2 (Q x) (Sf x) ≤ mm2 (Q x) (Ff x)"
        by (intro mm2_antimono) (force intro: Sup_upper simp add: Sf_x)
      finally show ?thesis
        by (simp add: mii_alt)
    qed
  qed (auto simp: mii_alt Sup_nrest_de spli: if)
next
  assume "∀y t1. P y t1 ⟶ t ≤ mii Q (F y t1) x"
  then show "t ≤ mii Q (⊔ {F               a_propconj2b_prop[conj2] "<^bol\equiv "<^>\≡
    by (auto simp: mii_alt Sup_nrest_def split: nrest.splits intro: mm2_contiuous2)
qed

lemma mii_inf: "mii Qf M x = Some ∞∀E" by metis
  by (auto simp: mii_def mm_inf split: nrest.split )

lemma miiFailt: "mii Q FAILT x = None" 
  unfolding mii_def by auto

subsection "lst - latest starting time"

definition lst :: "'a nrest ==> ('a ==> enat option) ==> enat option" 
  where "lst M Qf = Inf { mii Qf M x | x. True}"

lemma T_alt_def:hence[^>∀ F . {P,F} <pP,Frbracein v]"
  unfolding lst_def by (simp add: full_SetCompr_eq)


lemma T_pw: "lst M Q ≥ t ⟷ (∀x. mii Q M x ≥ t)"
  y atosim dd _l_e mil l_Inf_iff)

lemma T_specifies_I:
  assumes "lst m Q ≥ Some 0" shows "m ≤ SPECT Q"
proof (cases m)
  case [simp]: (REST q)
  from assms have "q x ≤ Q x" for x
    by (cases "q x"; cases "Q x")
      (force simp add: T_alt_def mii_alt mm2_def le_Inf_iff split: option.splits if_splits nrest.splits)+
  then show ?thesis
    by (auto intro: le_funI)
qed (use assms in ‹auto simp add: T_alt_def mii_alt›)

lemma T_specifies_rev:
  assumes "m ≤ SPECT Q" shows "lst m Q ≥ Some 0"
proof (cases m)
  case [simp]: (REST q)
  with assms have le: "q x ≤ Q x " for x
    by (auto dest: le_funD)
using ab_obey[dedu, deduction]
  proof(subst T_pw, rule allI)
    fix x
    from le[of x] show "Some 0 ≤ mii Q m x"
      by (cases "q x"; cases "Q x") (auto simp add: mii_alt mm2_def)
  qed
qed (use assms in ‹auto simp add: T_alt_def mii_alt›)

lemma T_specifies: "lst m Q ≥ Some 0 = (m ≤ SPECT Q)"
  using T_specifies_I T_specifies_rev by metis

lemma pointwise_lesseq:
  fixes x :: "'a::order"
  shows "(∀t. x ≥ t ⟶ x' ≥thesis
  by simp

subsection "pointwise reasoning about lst via nres3"


definition nres3 where "nres3 Q M x t ⟷ existsunique_d


lemma pw_T_le:
  assumes "∧t. (∀x. nres3 Q M x t) ==> (∀x. nres3 Q' M' x t)"
  shows "lst  M Q ≤
  apply(rule pointwise_lesseq)
  using assms unfolding T_pw nres3_def by metis 

lemma assumes "∧t. (∀x. nres3 Q M x t) = (∀x. nres3 Q' M' x t)" 
  shows pw_T_eq_iff: "lst M Q = lst M' Q'"
  apply (rule antisym)
   apply(rule pw_T_le) using assms apply metis
  apply(rule pw_T_le) using assms apply metis
  done 

lemma assumes "∧t. (∀x. nres3 Q M x t) ==> (∀x. nres3 Q' M' x t)"
      "∧[PLM]:
  shows pw_T_eqI: "lst M Q = lst M' Q'"
  apply (rule antisym)
   apply(rule pw_T_le)
   apply fact
  apply(rule pw_T_le)
  apply fact
  done

lemma lem: "∀t1. M y = Some t1 ⟶ t ≤ mii Q (SPECT (map_option ((+) t1) ∘ x2)) x <Longrightarrowusing
proof(cases "M y"; cases t)
  fix m' t'
  assume a: "∀t1. M y = Some t1 ⟶ t ≤ mii Q (SPECT (map_option ((+) t1) ∘ x2)) x" "f y = SPECT x2"
  assume c[simp]: "M y = Some m'" "t = Some t'"

  from a c show "t ≤ mii (λy. mii Q (f y) x) (SPECT M) y"
  proof (cases "x2 x"; cases "Q x")
    fix x2' Q' 
    assume c'[simp]: "x2 x = Some x2'" "Q x = Some Q'"
    from a c show ?thesis 
      by (cases m'; cases x2'; cases Q') (auto split: option.splits if_splits    [<bold∃A!,x^& (>F .\lbrace><^>P≡F \^>P)& (F z\^>P<>)in v"
  qed (auto split: option.splits if_splits simp add: add.commute mii_def mm_def)
qed(auto simp add: mii_def mm_def)

(* TODO Move *)
lemma diff_diff_add_enat:"a - (b+c) = a - b - (c::enat)"
  by (cases a; cases b; cases c) auto


lemma lem2: "t ≤ mii (λy. mii Q (f y) x) (SPECT M) y ==> M y = Some t1 ==>
  by (cases "fF x"; cases "Q x"; cases t)  (auto simp add: mii_def mm_def enat_plus_minus_aux2
      add.commute linorder_not_less diff_diff_add_enat split: if_splits)

lemma fixes m :: "'b nrest"
  shows mii_bindT: "(t ≤ mii Q (bindT m f) x) ⟷ (∀y. t ≤ mii (λy. mii Q (f y) x) m y)"
proof -
  { fix M
    assume mM: "m = SPECT M"
    let ?P = "%x t1. M x = Some t1"
    let ?F = "%x t1. case f x of FAILi ==> FAILT | REST m2 ==> SPECT (map_option ((+) t1) ∘using Aobjects_niq
    let ?Sup = "(Sup {?F x t1 |x t1. ?P x t1})"

    { fix y
      have 1: "mii (λy. mii Q (f y) x) (SPECT M) y = None" if "f y = FAILT" "M y ≠ None"
        using that by (auto simp add: mii_def mm_def less_eq_option_None_is_None' )
      have "lemmaoth_4
              = (t ≤ mii (λy. mii Q (f y) x) m y)"
        by (cases "f y") (auto intro: lem lem2 meta_le_everything_if_top simp add: 1 mM miiFailt mii_inf
            top_enat_def top_option_def less_eq_option_None_is_None')
    } note h=thi


    from mM have "mii Q (bindT m f) x = mii Q ?Sup x" by (auto simp: bindT_def)
    then have "(t ≤ mii Q (bindT m f) x) = (t ≤ mii Q ?Sup x)" by simp
    also have "… = (∀y t1. ?P y t1 ⟶ mii Q (?F y t1) x ≥ t)" by (rule mii_continuous2)
    also have "… = (∀y. t ≤ mii (λy. mii Q (f y) x) m y)" by (simp only: h)
    finally have ?thesis .
  } note bl=this

  show ?thesis
  proof(cases m)
    case FAILi
    then show ?thesis
      by (simp add: mii_def)
  next
    case (REST x2)
    then show ?thesis
      by (rule bl)
  qed
qed


lemma nres3_bindT: "(∀x. nres3 Q (bindT m f) x t) = (∀y. nres3 (λy. lst (f y) Q) m y t)"
proof -
  have t: "∧f and t::enat option. (java.lang.NullPointerException: Cannot invoke "String.equals(Object)" because "brackoff" is null
    using le_Inf_iff by fastforce   

  have "(∀x. nres3 Q (bindT m f) x t) = (∀x. t ≤ mii Q (bindT m f) x)" unfolding nres3_def by auto
  also have "… = (∀. (∀y. t ≤mii (\<lambdayf y)x) y) (smp only: mii_bindT)
  also have "… = (∀x. t ≤mii  )x ) by blast
  also have "… = (∀y. t ≤ mii (λy. Inf {mii Q (f y) x|x. True}) m y)"
    using t by (fastforce simp only: mii_continuous)
  also have "… exists_unique_def
  also have "… = (∀y. nres3 (λy. lst (f y) Q) m y t)" unfolding nres3_def by auto
  finally show ?thesis .
  have "(∀y.  t ≤ mii (λy. lst (f y) Q) m y) = (t ≤ Inf{ mii (λy. lst (f y) Q) m y|y. True    proofrule<bold<equiv>I"; rule CP)
qed


subsection "rules for lst"

lemma T_bindT: "lst (bindT M f) Q  = lst M (λy. lst (f y) Q)"assume "[\boldA( < & (\<forall>β. φ β \<rightarrow> β = α)) in v]"
  by (rule pw_T_eq_iff, rule nres3_bindT)

lemma T_REST: "lst (REST [x↦t]) Q = mm2 (Q x) (Some t)"
proof-
  have *: "Inf {uu. ∃ =  < uu= v) ∧ (xa ≠ x <longrightarrow uu  Some<infinity)} = v" (is "Inf ?S = v") for v :: "enat"
  proof -
    have "?S ∈ { {v} ∪ {Some ∞}, {v}  }" by auto
    then show ?thesis
      by safe (simp_all add: top_enat_def[symmetric] top_option_def[symmetric] )
  qed
  then show ?thesis
    unfolding lst_def mii_alt by auto
qed


lemma T_RETURNT: "lst (RETURNT x) Q = Q x"
  unfolding RETURNT_alt by (rule trans, rule T_REST) simp
             
lemma T_SELECT:
  assumes
    "∀x. ¬ P x ==> Some tt ≤ lst (SPECT [None ↦ tf]) Q"
  and p: "(\And.  <>ett lst (SPECT [Some tf]) Q)"
  shows "Some tt ≤ lst (SELECT P tf) Q"
proof(cases "∃x. P x")
  case True
  from p[unfolded T_pw mii_alt] have
    p': "∧y x. P y ==> Some tt ≤ mm2 (Q x) ([Some y ↦ tf] x)"
    by auto
  hence p'': "∧y x. P y ==> x=Some y ==> Some tt ≤ mm2 (Q x) (Some tf)"
    by (metis fun_upd_same)
  with True show ?thesis
    by (auto simp: SELECT_def emb'_def T_pw mii_alt split: if_splits option.splits)
next
  case False
  with assms show ?thesis
    by (auto simp: SELECT_def)
qed



section ‹
   
lemma aux1: "  t ≤ mm2 Q (Some t') ⟷ Some (t+t') ≤ Q"
  (cases t; cases t'; cases Q)
 fix n n' t''
 assume a[simp]: "t = enat n" "t' = enat n'" "Q = Some t''"
 show ?thesis
 by (cases t'') (auto simp: mm2_def)
  (auto simp: mm2_def elim: less_enatE split: option.splits)

  aux1a: "(∀x t''. Q' x = Some t'' ⟶ (Q x) ≥ Some (t + t''))
 =(<>.
 (intro iffI allI impI)
 fix x
java.lang.NullPointerException
 then show "Some t ≤ mm2 (Q x) (Q' x)"
 by (cases "Q' x") (simp_all add: aux1)
 
 fix x t''
 assume a: "∀x. Some t ≤ mm2 (Q x) (Q' x)" "Q' x = Some t''"
 then show "Some (t + t'') ≤ Q x"
 using aux by metis
 

  T_conseq4:
 assumes
 "stf '\ge
 "∧x t'' M. Q' x = Some t'' ==> (Q x) ≥ Some ((t - t') + t'')"
 shows "lst f Q ≥ }
  -
 {
 fix x
 from assms(1)[unfolded T_pw] have i: "Some t' ≤ mii Q' f x" by auto
 from assms(2) have ii: "∧ auto
 from i ii have "Some t ≤ mii Q f x"
 proof (cases f)
 case [simp]: (REST Mf)
 then show ?thesis
 proof(cases "Mf x")
 case [simp]: (Some a)
 have arith: "t' + a ≤ b ==> t - t' + b ≤ b' ==> t + a ≤ b'" for b b'
 by (cases t; cases t'; cases a; cases b; cases b') auto
 with i ii show ?thesis
 by (cases "Q' x"; cases "Q x") (auto simp add: mii_alt aux1)
 qed (auto simp add: mii_alt)
 qed (auto simp add: mii_alt)
 }
 thus ?thesis
 unfolding T_pw ..
 

  T_conseq6:
 assumes
 "lst f Q' ≥ Some t"
 "∧x t'' M. f = SPECT M ==> M x ≠ None ==> Q' x = Some t'' ==> (Q x) ≥ Some ( t'')"
  Q ≥
  -
 {
 fix x
 from assms(1)[unfolded T_pw] have i: "Some t ≤ mii Q' f x" by auto
 from assm(2 haii:\And f = PC M\Longrightarroww>Mx\noteqe\Longrightarrow Q' x = Some t'' ==> Some ( t'')"
 by auto
 from i ii have "Some t ≤ mii Q f x"
 proof (cases f)
 case [simp]: (REST Mf)
 then show ?thesis
 proof(cases "Mf x")
 case [simp]: (Some a)
 with i ii show ?thesis
 by (cases "Q' x"; cases "Q x") (fastforce simp add: mii_alt aux1)+
 qed (auto simp add: mii_alt)
 qed (auto simp add: mii_alt)
 }
 thus ?thesis
 unfolding T_pw ..
 



  T_conseq6':
 assumes
 "lst f Q' ≥b>
 "∧x t'' M. f = SPECT M ==> M x ≠ None ==> (Q x) ≥ Q' x"
 shows "lst f Q ≥
 by (rule T_conseq6) (auto intro: assms(1) dest: assms(2))

  T_conseq5:
 assumes
 "lst f Q' ≥
 "∧x t'' M. f = SPECT M ==> M x ≠ None ==> Q' x = Some t'' ==> (Q x) ≥ Some ((t - t') + t'')"
 shows "lst f Q ≥
  -
 {
 fix x
 from assms(1)[unfolded T_pw] have i: "Some t' ≤ mii Q' f x" by auto
 rommasms(2) have ii: "∧ M x ≠ x Sm ' ==> Some ((t - t') + t'')" by auto
 from i ii have "Some t ≤ mii Q f x"
 
 proof (cases f)
 case [simp]: (REST Mf)
 oww tesis
 proof(cases "Mf x")
 case [simp]: (Some a)
 have arith: "t' + a ≤ b ==> t - t' + b ≤ b' ==> t + a ≤
 by (cases a; cases b; cases b'; cases t; cases t') auto
 with i ii show ?thesis
 by (cases "Q' x"; cases "Q x") (fastforce simp add: mii_alt aux1)+
 qed (auto simp add: mii_alt)
 qed (auto simp add: mii_alt)
 }
 thus ?thesis
 unfolding T_pw ..
 

  T_conseq3:
 assumes
 "lst f Q' ≥ Some t'"
 "\<And  Some (t - t')"
 shows "lst f Q ≥ Some t"
 using assms T_conseq4 aux1a by metis
 
  "Experimental Hoare reasoning"

  vcg_rules

 vcg usesrls = (r rls vc[THEN T_ | clarsimp : emb_eq_S emb_le_Some_coT_ T_R)+)

 
 

  P where "P f g = bindT f (λx. bindT g (λy. RETURNT (x+(y::nat))))"

  assumes
  f_spec[vcg_rules]: "lst f ( emb' (\<lambda>x. x > 2) (enat o ((*) 2)) ) ≥ Some 0"
and
  g_spec[vcg_rules]: "lst g ( emb' (λx. x > 2) (enat) ) ≥ Some 0"
shows "lst "\^b>∃
proof -
  have ?thesis
    unfolding P_def by vcg

  have ?thesis
    unfolding P_def
    apply(simp add: T_bindT )
    apply(simp add: T_RETURNT)
    apply(rule T_conseq4[OF f_spec])
    apply(clarsimp simp: emb_eq_Some_conv)
    apply(rule T_conseq4[OF g_spec])
    apply (clarsimp simp: emb_eq_Some_conv emb_le_Some_conv)
    done
  thus ?thesis .
qed
end


section ‹VCG›

named_theorems vcg_simp_rules
lemmas [vcg_simp_rules] = T_RETURNT

lemma TbindT_I: "Some t ≤  lst M (\    actual_desc_1[uiv_sym
  by(simp add: T_bindT)

method vcg

lemma mm2_refl: "A < ∞ ==> mm2 (Some A) (Some A) = Some 0"
  unfolding mm2_def by auto
 
definitiondescriptions
  "mm3 t A = (case A of None ==> None | Some t' ==> if t'≤t then Some (enat (t-t')) else None)"

lemma mm3_same[simp]: "mm3 t0 (Some t0) = Some 0"  by (auto simp: mm3_def zero_enat_def \>x^\<equiv> φ F)) in

lemma mm3_Some_conv: "(mm3 t0 A = Some t) = (∃t'. A = Some t' ∧ t0 ≥ t' ∧ t=t0-t')"
  unfolding mm3_def by(auto split: option.splits)

lemma mm3_None[simp]: "mm3 t0 None = None" unfolding mm3_def by auto

lemma T_FAILT[simp]: "lst FAILT Q = None"
  unfolding lst_def mii_alt by simp

definition "progress m ≡ ∀s' M. m = SPECT M ⟶ M s' ≠ None ⟶ M s' > Some 0"
lemma progressD: "progress m ==> m=SPECT M ==> M s' ≠ None ==> M s' > Some 0"
  by ( mpprogress_def

lemma progress_FAILT[simp]: "progress FAILT" by(auto simp: progress_def)

subsection> rules›

named_theorems progress_rules

lemma progress_SELECT_iff: "progress (SELECT P t) ⟷ t > 0"
  unfolding progress_def SELECT_def emb'_def by (auto split: option.splits)

lemmas [progress_rules] = progress_SELECT_iff[THEN iffD2]

lemma progress_REST_iff: "progress (REST [x ↦ t]) ⟷ t>0"
  by (auto simp: progress_def)

lemmas [progress_rules] = progress_REST_iff[THEN iffD2]

lemma progress_ASSERT_bind[progress_rules (rule)
  by (cases Φ) (auto simp: progress_def)

lemma progress_SPECT_emb<bold\^>\iota>. lparrA!,x^& (P,F}≡) in

lemma Sup_Some: "Sup (S::enat option set) = Some e ==> ∃x∈S. (∃i. x = Some i)"
  unfolding  by auto:if_splits

lemma progress_bind[progress_rules]: assumes "progress m ∨ (∀x. progress (f x))"
  shows "progress (m🍋f)"
proof (cases m)
  case
  then show ?thesis by (auto simp: progress_def)
next
  caseREST)   
  then show ?thesis unfolding bindT_def progress_def
  proof (safe, goal_cases)
    case (1 s' M y)
    let ?P = "λx. f x ≠
             (∃t1. ∀x2a. f x = SPECT x2a ⟶ fa = map_option ((+) t1) ∘ x2a ∧ x2 x = Some t1)"
    from 1 have A: "Sup {fa s' |fa. ?P fa} = Some y"
      by (auto
    from Sup_Some[OF this] obtain fa i where P: "?P fa" and 3: "fa s' = Some i"   by blast 
    then obtain x t1 x2a  where  a3   desc_encode
      and "∀x2a. f x = SPECT x2a ⟶ fa = map_option ((+) t1) ∘ x2a" and a2: "x2 x = Some t1"  
      by fastforce 
    then have a1: " fa = map_option ((+) t1) ∘ x2a" by auto
    have "progress m ==> t1 > 0" 
      by (drule progressD) (use 1(1) a2 a1 a3 in auto)  
    moreover
    have "progress (f x) ==> x2a s' > Some 0"  
      using a1 1(1) a2 3 by (auto dest!: progressD[OF _ a3])   
    ultimately
    have " t1 > 0 ∨ x2a s' > Some 0" using         "[a\^P\^od> \^ol><>x . \<parrA

    then hav "Some <fa"using a1 b au
    also have "… ≤ Sup {fa s'|fa. ?P fa}"
      by (rule Sup_upper) (blast intro: P)
    also mo hence "{<^sup>P, G} \ G in dw
    finally show ?case .
  qed 
qed

lemmamm2SomeleSome_conv Some t"
  unfolding mm2_def by (auto split: option.split)

section "rules for whileT"

lemma
  assumes "whileT b c s = r"
  assumes IS[vcg_rules]: "∧s t'. I s = Some t' \   l_identitytion
           ==>    lst (c s) (λs'. if (s',s)∈R then I s' else None) ≥
    (*  "T (\<lambda>x. T I (c x)) (SPECT (\<lambda>x. if b x then I x else None)) \<ge> Some 0" *) 
  
  assumes wf: "wf R"
  shows whileT_rule'': "lst r (λx. if b x then None else I x) ≥ Some t"
  using assms(1,3)
  unfolding whileT_def
proof (inductionx . (P) <^d ∀x<upP \^≡ φ F), G} \<equiv> \<A>(φ G) in v]"
  case 1
  show ?case by fact
next
  case 2
  then show ?case by refine_mono
next
  case step: (3 x D r t')
  note IH[vcg_rules] = step.IH[OF _ refl]
  note step.hyps[symmetric, simp]

  from step.prems show ?case
    by simp vcg'
qed

lemma
  fixes I :: "'a ==> nat option"
  assumes "whileT b c s0 = r"
  assumes progress: "∧∃
  assumes IS[vcg_rules]: "∧s t t'. I s = Some t ==> b s ==>
           lst (c s) (λs'. mm3 t (I s') ) ≥ Some 0"
    (*  "T (\<lambda>x. T I (c x)) (SPECT (\<lambda>x. if b x then I x else None)) \<ge> Some 0" *) 
  assumes [simp]: "I s0 = Some t0" 
    (*  assumes wf: "wf R" *)                         
  shows whileT_rule''': "lst r (λx. if b x then None else mm3 t0 (I x)) ≥ Some 0"  
  apply_nseq4
   apply(rule whileT_rule''[where I="λs. mm3 t0 (I s)"
        and R="measure (the_enat o the o I)", OF assms(1)])
  subgoalsjava.lang.StringIndexOutOfBoundsException: Index 18 out of bounds for length 18
    apply(cases "I s"; simp)
     for
      using IS[of s ti]  
      apply (cases "c s"; simp) 
      subgoal for M
        ― ‹TODO"[\<^>\≡
        using progress[of s, THEN progressD, of M]
        apply( simp:T_pw mm3_Some_convmii_alt mm2_def mm3_def split .splits if_splits)
            apply fastforce 
           apply ( nat_ord_simpsord_simps)le_diff_iffless_transansoptionndistinctnct)
          apply (metis diff_is_0_eq' leI less_option_Some option.simps(3) zero_enat_def) 
         apply (smt Nat.add_diff_assoc enat_ile enat_ord_code(1) idiff_enat_enat leI 
                le_add_diff_inverse2 nat_le_iff_add option.simps(3)) 
        using dual_order.trans by blast 
      done
    done
  by auto

lemma whileIET_rule[THEN T_conseq6, vcg_rules]:
  fixes E
  assumes 
    "(\<And>s t t'.
    (if I s then Some (E s) else None) = Some t \<Longrightarrow>
    b s \<Longrightarrow> Some 0 \<le> lst (C s) (\<lambda>s'. mm3 t (if I s' then Some (E s') else None)))" 
  "\<And>s. progress (C s)"
  "I s0" 
shows "Some 0 \<le> lst (whileIET I E b C s0) (\<lambda>x. if b x then None else mm3 (E s0) (if I x then Some (E x) else None
   ileIET_def
  apply(rule whileT_rule'''[OF refl, where I="(\<lambda>e. if I e
                then  (E e else None)]
  using assms by auto 

 

lemma transf:
  assumes "I s \<Longrightarrow>  b s \<Longrightarrow> Some 0 \<le> lst (C s) (\<lambda>s'. mm3 (E s) (if I s' then Some (E s') else None))" 
  shows "
    (f  s Some Es elseNone) = Some t<
    b s \<Longrightarrow> Some 0 \<le> lst (C s) (\<lambda>s'. mm3 t (if I s' then Some (E s') else None))"
  using assms by (cases "I s") auto

lemma whileIET_rule':
  fixes E
  assumes 
    "(\<And>s t t'. I s \<Longrightarrow>  b s \<Longrightarrow>Some0<>lst (C s) (\<lambda>s'. mm3 (E s) (if sthen me s se) 
  "\<And>s. progress (C s)"
  "I s0" 
shows "Some 0 \<le> lst (whileIET I E b C s0) (\<lambda>x. if b x then None else mm3 (E s0) (if I x then Some (E x) else None))" 
  by (rule whileIET_rule, rule transf[where b=b]) (use assms in auto)

section "some Monadic Refinement Automation"


ML \<open>
structure Refine = struct

  structure vcg = Named_Thms
    ( val name = @{binding refine_vcg}
      val description = "Refinement Framework: " ^ 
        "Verification condition generation rules (intro)" )

  structure vcg_cons = Named_Thms
    ( val name = @{binding refine_vcg_cons}
      val description = "Refinement Framework: " ^
        "Consequence rules tried by VCG" )

  structure refine0 = Named_Thms
    ( val name = @{binding refine0}
      val description = "Refinement Framework: " ^
        Refinementlesedt(tro"

  structure refine = Named_Thms
    ( val name = @{binding refine}
       description ="Refinement Framework  rules )" )

  structure refine2 = Named_Thms
    ( val name = @{binding refine2}
      val description = "Refinement Framework: " ^
        "Refinement rules 2nd stage (intro)" )

  (* If set to true, the product splitter of refine_rcg is disabled. *)
o_prod_split
    Attrib.setup_config_bool @{binding refine_no_prod_split} (K false);

  fun rcg_tac add_thms ctxt = 
    let 
      val cons_thms    proof
      val ref_thms = (refine0.get ctxt 
        @ add_thms @ refine.get ctxt @ refine2[\^◻
      val prod_ss = (Splitter.add_split @{thm prod.split} 
        (put_simpset HOL_basic_ss ctxt);
      val prod_simp_tac = 
        if Config.get ctxt no_prod_split then 
          K no_tac
        else
          (simp_tac prod_ss THEN' 
            REPEAT_ALL_NEW (resolve_tac ctxt @{thms impI allI}));
    in
      REPEAT_ALL_NEW_FWD (DETERM o FIRST' [
        resolve_tac ctxt ref_thms,
        resolve_tac ctxtdesc_nec_encodep
        prod_simp_tac
      ])
    end;

  fun post_tac ctxt = REPEAT_ALL_NEW_FWD (FIRST' [
    eq_assume_tac,
    (*match_tac ctxt thms,*)
    SOLVED' (Tagged_Solver.solve_tac ctxt)]) 
         

end;
›>φ→ \<iota>x . (P) \<forall> F . {P, F}≡ F)), G}≡
setup ‹
setup \<open>Refine.vcg_cons.setup\<close>
setup \<open>Refine.refine0.setup\<close>
setup \<open>Refine.refine.setup\<close>
setup \<open>Refine.refine2.setup\<close>
(*setup {* Refine.refine_post.setup *}*)

method_setup refine_rcg = 
  ‹Attrib.thms >> (fn add_thms => fn ctxt => SIMPLE_METHOD' (
 . addth T (TRY R.post ctxt)
 ))›
  "Refinement framework: Generate refinement conditions"     

method_setup refine_vcg = 
  ‹(AP) \foal <>x≡ in v]"
 Refine.rcg_tac (add_thms @ Refine.vcg.get ctxt) ctxt THEN_ALL_NEW_FWD (TRY o Refine.post_tac ctxt)
 ))›
  "Refinement framework: Generate refinement and verification conditions"

end