(*  Title:      HOL/Library/Phantom_Type.thy
    Author:     Andreas Lochbihler
*)

section {* A generic phantom type *}

theory Phantom_Type
imports Main
begin

datatype ('a, 'b) phantom = phantom (of_phantom: 'b)

lemma type_definition_phantom': "type_definition of_phantom phantom UNIV"
by(unfold_locales) simp_all

lemma phantom_comp_of_phantom [simp]: "phantom \<circ> of_phantom = id"
  and of_phantom_comp_phantom [simp]: "of_phantom \<circ> phantom = id"
by(simp_all add: o_def id_def)

syntax "_Phantom" :: "type \<Rightarrow> logic" ("(1Phantom/(1'(_')))")
translations
  "Phantom('t)" => "CONST phantom :: _ \<Rightarrow> ('t, _) phantom"

typed_print_translation {*
  let
    fun phantom_tr' ctxt (Type (@{type_name fun}, [_, Type (@{type_name phantom}, [T, _])])) ts =
          list_comb
            (Syntax.const @{syntax_const "_Phantom"} $ Syntax_Phases.term_of_typ ctxt T, ts)
      | phantom_tr' _ _ _ = raise Match;
  in [(@{const_syntax phantom}, phantom_tr')] end
*}

lemma of_phantom_inject [simp]:
  "of_phantom x = of_phantom y \<longleftrightarrow> x = y"
by(cases x y rule: phantom.exhaust[case_product phantom.exhaust]) simp

end


section \<open>Syntax and proof rules for stratified diagrams\<close>

theory Ribbons_Stratified imports
  Ribbons_Interfaces
  Proofchain
begin

text \<open>We define the syntax of stratified diagrams. We give proof rules
  for stratified diagrams, and prove them sound with respect to the
  ordinary rules of separation logic.\<close>

subsection \<open>Syntax of stratified diagrams\<close>

datatype sdiagram = SDiagram "(cell \<times> interface) list"
and cell =
  Filler "interface"
| Basic "interface" "command" "interface"
| Exists_sdia "string" "sdiagram"
| Choose_sdia "interface" "sdiagram" "sdiagram" "interface"
| Loop_sdia "interface" "sdiagram" "interface"

datatype_compat sdiagram cell

type_synonym row = "cell \<times> interface"

text \<open>Extracting the command from a stratified diagram.\<close>
fun
  com_sdia :: "sdiagram \<Rightarrow> command" and
  com_cell :: "cell \<Rightarrow> command"
where
  "com_sdia (SDiagram \<rho>s) = foldr (;;) (map (com_cell \<circ> fst) \<rho>s) Skip"
| "com_cell (Filler P) = Skip"
| "com_cell (Basic P c Q) = c"
| "com_cell (Exists_sdia x D) = com_sdia D"
| "com_cell (Choose_sdia P D E Q) = Choose (com_sdia D) (com_sdia E)"
| "com_cell (Loop_sdia P D Q) = Loop (com_sdia D)"

text \<open>Extracting the program variables written by a stratified diagram.\<close>
fun
  wr_sdia :: "sdiagram \<Rightarrow> string set" and
  wr_cell :: "cell \<Rightarrow> string set"
where
  "wr_sdia (SDiagram \<rho>s) = (\<Union>r \<in> set \<rho>s. wr_cell (fst r))"
| "wr_cell (Filler P) = {}"
| "wr_cell (Basic P c Q) = wr_com c"
| "wr_cell (Exists_sdia x D) = wr_sdia D"
| "wr_cell (Choose_sdia P D E Q) = wr_sdia D \<union> wr_sdia E"
| "wr_cell (Loop_sdia P D Q) = wr_sdia D"

text \<open>The program variables written by a stratified diagram correspond to
  those written by the commands therein.\<close>
lemma wr_sdia_is_wr_com:
  fixes \<rho>s :: "row list"
  and \<rho> :: row
  shows "(wr_sdia D = wr_com (com_sdia D))"
  and "(wr_cell \<gamma> = wr_com (com_cell \<gamma>))"
  and "(\<Union>\<rho> \<in> set \<rho>s. wr_cell (fst \<rho>))
    = wr_com (foldr (;;) (map (\<lambda>(\<gamma>,F). com_cell \<gamma>) \<rho>s) Skip)"
  and "wr_cell (fst \<rho>) = wr_com (com_cell (fst \<rho>))"
apply (induct D and \<gamma> and \<rho>s and \<rho> rule: compat_sdiagram.induct compat_cell.induct
  compat_cell_interface_prod_list.induct compat_cell_interface_prod.induct)
apply (auto simp add: wr_com_skip wr_com_choose
  wr_com_loop wr_com_seq split_def o_def)
done

subsection \<open>Proof rules for stratified diagrams\<close>

inductive
  prov_sdia :: "[sdiagram, interface, interface] \<Rightarrow> bool" and
  prov_row :: "[row, interface, interface] \<Rightarrow> bool" and
  prov_cell :: "[cell, interface, interface] \<Rightarrow> bool"
where
  SRibbon: "prov_cell (Filler P) P P"
| SBasic: "prov_triple (asn P, c, asn Q) \<Longrightarrow> prov_cell (Basic P c Q) P Q"
| SExists: "prov_sdia D P Q
    \<Longrightarrow> prov_cell (Exists_sdia x D) (Exists_int x P) (Exists_int x Q)"
| SChoice: "\<lbrakk> prov_sdia D P Q ; prov_sdia E P Q \<rbrakk>
    \<Longrightarrow> prov_cell (Choose_sdia P D E Q) P Q"
| SLoop: "prov_sdia D P P \<Longrightarrow> prov_cell (Loop_sdia P D P) P P"
| SRow: "\<lbrakk> prov_cell \<gamma> P Q ; wr_cell \<gamma> \<inter> rd_int F = {} \<rbrakk>
    \<Longrightarrow> prov_row (\<gamma>, F) (P \<otimes> F) (Q \<otimes> F)"
| SMain: "\<lbrakk> chain_all (\<lambda>(P,\<rho>,Q). prov_row \<rho> P Q) \<Pi> ; 0 < chainlen \<Pi> \<rbrakk>
    \<Longrightarrow> prov_sdia (SDiagram (comlist \<Pi>)) (pre \<Pi>) (post \<Pi>)"

subsection \<open>Soundness\<close>

lemma soundness_strat_helper:
  "(prov_sdia D P Q \<longrightarrow> prov_triple (asn P, com_sdia D, asn Q)) \<and>
   (prov_row \<rho> P Q \<longrightarrow> prov_triple (asn P, com_cell (fst \<rho>), asn Q)) \<and>
   (prov_cell \<gamma> P Q \<longrightarrow> prov_triple (asn P, com_cell \<gamma>, asn Q))"
proof (induct rule: prov_sdia_prov_row_prov_cell.induct)
  case (SRibbon P)
  show ?case by (auto simp add: prov_triple.skip)
next
  case (SBasic P c Q)
  thus ?case by auto
next
  case (SExists D P Q x)
  thus ?case by (auto simp add: prov_triple.exists)
next
  case (SChoice D P Q E)
  thus ?case by (auto simp add: prov_triple.choose)
next
  case (SLoop D P)
  thus ?case by (auto simp add: prov_triple.loop)
next
  case (SRow \<gamma> P Q F)
  thus ?case
  by (simp add: prov_triple.frame rd_int_is_rd_ass wr_sdia_is_wr_com(2))
next
  case (SMain \<Pi>)
  thus ?case
  apply (unfold com_sdia.simps)
  apply (intro seq_fold[of _ \<Pi>])
  apply (simp_all add: len_comlist_chainlen)[3]
  apply (induct \<Pi>, simp)
  apply (case_tac i, auto simp add: fst3_simp thd3_simp)
  done
qed

corollary soundness_strat:
  assumes "prov_sdia D P Q"
  shows "prov_triple (asn P, com_sdia D, asn Q)"
using assms soundness_strat_helper by auto

end


theory Proofs6
  imports Requirements VCTheoryLemmas
begin

definition inv6 where "inv6 s \<equiv> R6 s \<and> extraInv s"

theorem proof_6_1: "VC1 inv6 s0"
  apply(unfold VC1_def inv6_def R6_def extraInv_def)
  by auto

theorem proof_6_2: "VC2 R6 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC2_def inv6_def R6_def extraInv_def)
  by auto

theorem proof_6_9: "VC9 R6 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC9_def inv6_def R6_def extraInv_def)
  by auto

theorem proof_6_14: "VC14 R6 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC14_def inv6_def R6_def extraInv_def)
  by auto

theorem proof_6_15: "VC15 R6 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC15_def inv6_def R6_def extraInv_def)
  by auto

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      Generalise.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2005-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

theory Generalise imports "HOL-Statespace.DistinctTreeProver"
begin

lemma protectRefl: "PROP Pure.prop (PROP C) \<Longrightarrow> PROP Pure.prop (PROP C)"
  by (simp add: prop_def)

lemma protectImp:
 assumes i: "PROP Pure.prop (PROP P \<Longrightarrow> PROP Q)"
 shows "PROP Pure.prop (PROP Pure.prop P \<Longrightarrow> PROP Pure.prop Q)"
proof -
  {
    assume P: "PROP Pure.prop P"
    from i [unfolded prop_def, OF P [unfolded prop_def]]
    have "PROP Pure.prop Q"
      by (simp add: prop_def)
  }
  note i' = this
  show "PROP ?thesis"
    apply (rule protectI)
    apply (rule i')
    apply assumption
    done
qed

lemma generaliseConj:
  assumes i1: "PROP Pure.prop (PROP Pure.prop (Trueprop P) \<Longrightarrow> PROP Pure.prop (Trueprop Q))"
  assumes i2: "PROP Pure.prop (PROP Pure.prop (Trueprop P') \<Longrightarrow> PROP Pure.prop (Trueprop Q'))"
  shows "PROP Pure.prop (PROP Pure.prop (Trueprop (P \<and> P')) \<Longrightarrow> (PROP Pure.prop (Trueprop (Q \<and> Q'))))"
  using i1 i2
  by (auto simp add: prop_def)

lemma generaliseAll:
 assumes i: "PROP Pure.prop (\<And>s. PROP Pure.prop (Trueprop (P s)) \<Longrightarrow> PROP Pure.prop (Trueprop (Q s)))"
 shows "PROP Pure.prop (PROP Pure.prop (Trueprop (\<forall>s. P s)) \<Longrightarrow> PROP Pure.prop (Trueprop (\<forall>s. Q s)))"
  using i
  by (auto simp add: prop_def)

lemma generalise_all:
 assumes i: "PROP Pure.prop (\<And>s. PROP Pure.prop (PROP P s) \<Longrightarrow> PROP Pure.prop (PROP Q s))"
 shows "PROP Pure.prop ((PROP Pure.prop (\<And>s. PROP P s)) \<Longrightarrow> (PROP Pure.prop (\<And>s. PROP Q s)))"
  using i
  proof (unfold prop_def)
    assume i1: "\<And>s. (PROP P s) \<Longrightarrow> (PROP Q s)"
    assume i2: "\<And>s. PROP P s"
    show "\<And>s. PROP Q s"
      by (rule i1) (rule i2)
  qed

lemma generaliseTrans:
  assumes i1: "PROP Pure.prop (PROP P \<Longrightarrow> PROP Q)"
  assumes i2: "PROP Pure.prop (PROP Q \<Longrightarrow> PROP R)"
  shows "PROP Pure.prop (PROP P \<Longrightarrow> PROP R)"
  using i1 i2
  proof (unfold prop_def)
    assume P_Q: "PROP P \<Longrightarrow> PROP Q"
    assume Q_R: "PROP Q \<Longrightarrow> PROP R"
    assume P: "PROP P"
    show "PROP R"
      by (rule Q_R [OF P_Q [OF P]])
  qed

lemma meta_spec:
  assumes "\<And>x. PROP P x"
  shows "PROP P x" by fact

lemma meta_spec_protect:
  assumes g: "\<And>x. PROP P x"
  shows "PROP Pure.prop (PROP P x)"
using g
by (auto simp add: prop_def)

lemma generaliseImp:
  assumes i: "PROP Pure.prop (PROP Pure.prop (Trueprop P) \<Longrightarrow> PROP Pure.prop (Trueprop Q))"
  shows "PROP Pure.prop (PROP Pure.prop (Trueprop (X \<longrightarrow> P)) \<Longrightarrow> PROP Pure.prop (Trueprop (X \<longrightarrow> Q)))"
  using i
  by (auto simp add: prop_def)

lemma generaliseEx:
 assumes i: "PROP Pure.prop (\<And>s. PROP Pure.prop (Trueprop (P s)) \<Longrightarrow> PROP Pure.prop (Trueprop (Q s)))"
 shows "PROP Pure.prop (PROP Pure.prop (Trueprop (\<exists>s. P s)) \<Longrightarrow> PROP Pure.prop (Trueprop (\<exists>s. Q s)))"
  using i
  by (auto simp add: prop_def)

lemma generaliseRefl: "PROP Pure.prop (PROP Pure.prop (Trueprop P) \<Longrightarrow> PROP Pure.prop (Trueprop P))"
  by (auto simp add: prop_def)

lemma generaliseRefl': "PROP Pure.prop (PROP P \<Longrightarrow> PROP P)"
  by (auto simp add: prop_def)

lemma generaliseAllShift:
  assumes i: "PROP Pure.prop (\<And>s. P \<Longrightarrow> Q s)"
  shows "PROP Pure.prop (PROP Pure.prop (Trueprop P) \<Longrightarrow> PROP Pure.prop (Trueprop (\<forall>s. Q s)))"
  using i
  by (auto simp add: prop_def)

lemma generalise_allShift:
  assumes i: "PROP Pure.prop (\<And>s. PROP P \<Longrightarrow> PROP Q s)"
  shows "PROP Pure.prop (PROP Pure.prop (PROP P) \<Longrightarrow> PROP Pure.prop (\<And>s. PROP Q s))"
  using i
  proof (unfold prop_def)
    assume P_Q: "\<And>s. PROP P \<Longrightarrow> PROP Q s"
    assume P: "PROP P"
    show "\<And>s. PROP Q s"
      by (rule P_Q [OF P])
  qed

lemma generaliseImpl:
  assumes i: "PROP Pure.prop (PROP Pure.prop P \<Longrightarrow> PROP Pure.prop Q)"
  shows "PROP Pure.prop ((PROP Pure.prop (PROP X \<Longrightarrow> PROP P)) \<Longrightarrow> (PROP Pure.prop (PROP X \<Longrightarrow> PROP Q)))"
  using i
  proof (unfold prop_def)
    assume i1: "PROP P \<Longrightarrow> PROP Q"
    assume i2: "PROP X \<Longrightarrow> PROP P"
    assume X: "PROP X"
    show "PROP Q"
      by (rule i1 [OF i2 [OF X]])
  qed

ML_file "generalise_state.ML"

end


(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section \<open>Markov Decision Processes\<close>

theory Markov_Decision_Process
  imports Discrete_Time_Markov_Chain
begin

definition "some_elem s = (SOME x. x \<in> s)"

lemma some_elem_ne: "s \<noteq> {} \<Longrightarrow> some_elem s \<in> s"
  unfolding some_elem_def by (auto intro: someI)

subsection \<open>Configurations\<close>

text \<open>

We want to construct a \emph{non-free} codatatype
  \<open>'s cfg = Cfg (state: 's) (action: 's pmf) (cont: 's \<Rightarrow> 's cfg)\<close>.
with the restriction
  @{term "state (cont cfg s) = s"}

\<close>

hide_const cont

codatatype 's scheduler = Scheduler (action_sch: "'s pmf") (cont_sch: "'s \<Rightarrow> 's scheduler")

lemma equivp_rel_prod: "equivp R \<Longrightarrow> equivp Q \<Longrightarrow> equivp (rel_prod R Q)"
  by (auto intro!: equivpI prod.rel_symp prod.rel_transp prod.rel_reflp elim: equivpE)

coinductive eq_scheduler :: "'s scheduler \<Rightarrow> 's scheduler \<Rightarrow> bool"
where
  "\<And>D. action_sch sc1 = D \<Longrightarrow> action_sch sc2 = D \<Longrightarrow>
    (\<forall>s\<in>D. eq_scheduler (cont_sch sc1 s) (cont_sch sc2 s)) \<Longrightarrow> eq_scheduler sc1 sc2"

lemma eq_scheduler_refl[intro]: "eq_scheduler sc sc"
  by (coinduction arbitrary: sc) auto

quotient_type 's cfg = "'s \<times> 's scheduler" / "rel_prod (=) eq_scheduler"
proof (intro equivp_rel_prod equivpI reflpI sympI transpI)
  show "eq_scheduler sc1 sc2 \<Longrightarrow> eq_scheduler sc2 sc1" for sc1 sc2 :: "'s scheduler"
    by (coinduction arbitrary: sc1 sc2) (auto elim: eq_scheduler.cases)
  show "eq_scheduler sc1 sc2 \<Longrightarrow> eq_scheduler sc2 sc3 \<Longrightarrow> eq_scheduler sc1 sc3"
    for sc1 sc2 sc3 :: "'s scheduler"
    by (coinduction arbitrary: sc1 sc2 sc3)
       (subst (asm) (1 2) eq_scheduler.simps, auto)
qed auto

lift_definition state :: "'s cfg \<Rightarrow> 's" is "fst"
  by auto

lift_definition action :: "'s cfg \<Rightarrow> 's pmf" is "\<lambda>(s, sc). action_sch sc"
  by (force elim: eq_scheduler.cases)

lift_definition cont :: "'s cfg \<Rightarrow> 's \<Rightarrow> 's cfg" is
  "\<lambda>(s, sc) t. if t \<in> action_sch sc then (t, cont_sch sc t) else
    (t, cont_sch sc (some_elem (action_sch sc)))"
  apply (simp add: rel_prod_conv split: prod.splits)
  apply (subst (asm) eq_scheduler.simps)
  apply (auto simp: Let_def set_pmf_not_empty[THEN some_elem_ne])
  done

lift_definition Cfg :: "'s \<Rightarrow> 's pmf \<Rightarrow> ('s \<Rightarrow> 's cfg) \<Rightarrow> 's cfg" is
  "\<lambda>s D c. (s, Scheduler D (\<lambda>t. snd (c t)))"
  by (auto simp: rel_prod_conv split_beta' eq_scheduler.simps[of "Scheduler _  _"])

lift_definition cfg_corec :: "'s \<Rightarrow> ('a \<Rightarrow> 's pmf) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'a)  \<Rightarrow> 'a \<Rightarrow> 's cfg" is
  "\<lambda>s D C x. (s, corec_scheduler D (\<lambda>x s. Inr (C x s)) x)"  .

lemma state_Cfg[simp]: "state (Cfg s d' c') = s"
  by transfer simp

lemma action_Cfg[simp]: "action (Cfg s d' c') = d'"
  by transfer simp

lemma cont_Cfg[simp]: "t \<in> set_pmf d' \<Longrightarrow> state (c' t) = t \<Longrightarrow> cont (Cfg s d' c') t = c' t"
  by transfer (auto simp add: rel_prod_conv split: prod.split)

lemma state_cfg_corec[simp]: "state (cfg_corec s d c x) = s"
  by transfer auto

lemma action_cfg_corec[simp]: "action (cfg_corec s d c x) = d x"
  by transfer auto

lemma cont_cfg_corec[simp]: "t \<in> set_pmf (d x) \<Longrightarrow> cont (cfg_corec s d c x) t = cfg_corec t d c (c x t)"
  by transfer auto

lemma cfg_coinduct[consumes 1, case_names state action cont, coinduct pred]:
  "X c d \<Longrightarrow> (\<And>c d. X c d \<Longrightarrow> state c = state d) \<Longrightarrow> (\<And>c d. X c d \<Longrightarrow> action c = action d) \<Longrightarrow>
    (\<And>c d t. X c d \<Longrightarrow> t \<in> set_pmf (action c) \<Longrightarrow> X (cont c t) (cont d t)) \<Longrightarrow> c = d"
proof (transfer, clarsimp)
  fix X :: "('a \<times> 'a scheduler) \<Rightarrow> ('a \<times> 'a scheduler) \<Rightarrow> bool" and B s1 s2 sc1 sc2
  assume X: "X (s1, sc1) (s2, sc2)" and "rel_fun cr_cfg (rel_fun cr_cfg (=)) X B"
    and 1: "\<And>s1 sc1 s2 sc2. X (s1, sc1) (s2, sc2) \<Longrightarrow> s1 = s2"
    and 2: "\<And>s1 sc1 s2 sc2. X (s1, sc1) (s2, sc2) \<Longrightarrow> action_sch sc1 = action_sch sc2"
    and 3: "\<And>s1 sc1 s2 sc2 t. X (s1, sc1) (s2, sc2) \<Longrightarrow> t \<in> set_pmf (action_sch sc2) \<Longrightarrow>
      X (t, cont_sch sc1 t) (t, cont_sch sc2 t)"
  from X show "eq_scheduler sc1 sc2"
    by (coinduction arbitrary: s1 s2 sc1 sc2)
       (blast dest: 2 3)
qed

coinductive rel_cfg :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a cfg \<Rightarrow> 'b cfg \<Rightarrow> bool" for P :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
where
  "P (state cfg1) (state cfg2) \<Longrightarrow>
    rel_pmf (\<lambda>s t. rel_cfg P (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg2) \<Longrightarrow>
    rel_cfg P cfg1 cfg2"

lemma rel_cfg_state: "rel_cfg P cfg1 cfg2 \<Longrightarrow> P (state cfg1) (state cfg2)"
  by (auto elim: rel_cfg.cases)

lemma rel_cfg_cont:
  "rel_cfg P cfg1 cfg2 \<Longrightarrow>
    rel_pmf (\<lambda>s t. rel_cfg P (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg2)"
  by (auto elim: rel_cfg.cases)

lemma rel_cfg_action:
  assumes P: "rel_cfg P cfg1 cfg2" shows "rel_pmf P (action cfg1) (action cfg2)"
proof (rule pmf.rel_mono_strong)
  show "rel_pmf (\<lambda>s t. rel_cfg P (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg2)"
    using P by (rule rel_cfg_cont)
qed (auto dest: rel_cfg_state)

lemma rel_cfg_eq: "rel_cfg (=) cfg1 cfg2 \<longleftrightarrow> cfg1 = cfg2"
proof safe
  show "rel_cfg (=) cfg1 cfg2 \<Longrightarrow> cfg1 = cfg2"
  proof (coinduction arbitrary: cfg1 cfg2)
    case cont
    have "action cfg1 = action cfg2"
      using \<open>rel_cfg (=) cfg1 cfg2\<close> by (auto dest: rel_cfg_action simp: pmf.rel_eq)
    then have "rel_pmf (\<lambda>s t. rel_cfg (=) (cont cfg1 s) (cont cfg2 t)) (action cfg1) (action cfg1)"
      using cont by (auto dest: rel_cfg_cont)
    then have "rel_pmf (\<lambda>s t. rel_cfg (=) (cont cfg1 s) (cont cfg2 t) \<and> s = t) (action cfg1) (action cfg1)"
      by (rule pmf.rel_mono_strong) (auto dest: rel_cfg_state)
    then have "pred_pmf (\<lambda>s. rel_cfg (=) (cont cfg1 s) (cont cfg2 s)) (action cfg1)"
      unfolding pmf.pred_rel by (rule pmf.rel_mono_strong) (auto simp: eq_onp_def)
    with \<open>t \<in> action cfg1\<close> show ?case
      by (auto simp: pmf.pred_set)
  qed (auto dest: rel_cfg_state rel_cfg_action simp: pmf.rel_eq)
  show "rel_cfg (=) cfg2 cfg2"
    by (coinduction arbitrary: cfg2) (auto intro!: rel_pmf_reflI)
qed

subsection \<open>Configuration with Memoryless Scheduler\<close>

definition "memoryless_on f s = cfg_corec s f (\<lambda>_ t. t) s"

lemma
  shows state_memoryless_on[simp]: "state (memoryless_on f s) = s"
    and action_memoryless_on[simp]: "action (memoryless_on f s) = f s"
    and cont_memoryless_on[simp]: "t \<in> (f s) \<Longrightarrow> cont (memoryless_on f s) t = memoryless_on f t"
  by (simp_all add: memoryless_on_def)

definition K_cfg :: "'s cfg \<Rightarrow> 's cfg pmf" where
  "K_cfg cfg = map_pmf (cont cfg) (action cfg)"

lemma set_K_cfg: "set_pmf (K_cfg cfg) = cont cfg ` set_pmf (action cfg)"
  by (simp add: K_cfg_def)

lemma nn_integral_K_cfg: "(\<integral>\<^sup>+cfg. f cfg \<partial>K_cfg cfg) = (\<integral>\<^sup>+s. f (cont cfg s) \<partial>action cfg)"
  by (simp add: K_cfg_def map_pmf_rep_eq nn_integral_distr)

subsection \<open>MDP Kernel and Induced Configurations\<close>

locale Markov_Decision_Process =
  fixes K :: "'s \<Rightarrow> 's pmf set"
  assumes K_wf: "\<And>s. K s \<noteq> {}"
begin

definition "E = (SIGMA s:UNIV. \<Union>D\<in>K s. set_pmf D)"

coinductive cfg_onp :: "'s \<Rightarrow> 's cfg \<Rightarrow> bool" where
  "\<And>s. state cfg = s \<Longrightarrow> action cfg \<in> K s \<Longrightarrow> (\<And>t. t \<in> action cfg \<Longrightarrow> cfg_onp t (cont cfg t)) \<Longrightarrow>
    cfg_onp s cfg"

definition "cfg_on s = {cfg. cfg_onp s cfg}"

lemma
  shows cfg_onD_action[intro, simp]: "cfg \<in> cfg_on s \<Longrightarrow> action cfg \<in> K s"
    and cfg_onD_cont[intro, simp]: "cfg \<in> cfg_on s \<Longrightarrow> t \<in> action cfg \<Longrightarrow> cont cfg t \<in> cfg_on t"
    and cfg_onD_state[simp]: "cfg \<in> cfg_on s \<Longrightarrow> state cfg = s"
    and cfg_onI: "state cfg = s \<Longrightarrow> action cfg \<in> K s \<Longrightarrow> (\<And>t. t \<in> action cfg \<Longrightarrow> cont cfg t \<in> cfg_on t) \<Longrightarrow> cfg \<in> cfg_on s"
  by (auto simp: cfg_on_def intro: cfg_onp.intros elim: cfg_onp.cases)

lemma cfg_on_coinduct[coinduct set: cfg_on]:
  assumes "P s cfg"
  assumes "\<And>cfg s. P s cfg \<Longrightarrow> state cfg = s"
  assumes "\<And>cfg s. P s cfg \<Longrightarrow> action cfg \<in> K s"
  assumes "\<And>cfg s t. P s cfg \<Longrightarrow> t \<in> action cfg \<Longrightarrow> P t (cont cfg t)"
  shows "cfg \<in> cfg_on s"
  using assms cfg_onp.coinduct[of P s cfg] by (simp add: cfg_on_def)

lemma memoryless_on_cfg_onI:
  assumes "\<And>s. f s \<in> K s"
  shows "memoryless_on f s \<in> cfg_on s"
  by (coinduction arbitrary: s) (auto intro: assms)

lemma cfg_of_cfg_onI:
  "D \<in> K s \<Longrightarrow> (\<And>t. t \<in> D \<Longrightarrow> c t \<in> cfg_on t) \<Longrightarrow> Cfg s D c \<in> cfg_on s"
  by (rule cfg_onI) auto

definition "arb_act s = (SOME D. D \<in> K s)"

lemma cfg_on_not_empty[intro, simp]: "cfg_on s \<noteq> {}"
  by (auto intro: memoryless_on_cfg_onI arb_actI)

sublocale MC: MC_syntax K_cfg .

abbreviation St :: "'s stream measure" where
  "St \<equiv> stream_space (count_space UNIV)"

subsection \<open>Trace Space\<close>

definition "T cfg = distr (MC.T cfg) St (smap state)"

sublocale T: prob_space "T cfg" for cfg
  by (simp add: T_def MC.T.prob_space_distr)

lemma space_T[simp]: "space (T cfg) = space St"
  by (simp add: T_def)

lemma sets_T[simp]: "sets (T cfg) = sets St"
  by (simp add: T_def)

lemma measurable_T1[simp]: "measurable (T cfg) N = measurable St N"
  by (simp add: T_def)

lemma measurable_T2[simp]: "measurable N (T cfg) = measurable N St"
  by (simp add: T_def)

lemma nn_integral_T:
  assumes [measurable]: "f \<in> borel_measurable St"
  shows "(\<integral>\<^sup>+X. f X \<partial>T cfg) = (\<integral>\<^sup>+cfg'. (\<integral>\<^sup>+x. f (state cfg' ## x) \<partial>T cfg') \<partial>K_cfg cfg)"
  by (simp add: T_def MC.nn_integral_T[of _ cfg] nn_integral_distr)

lemma T_eq:
  "T cfg = (measure_pmf (K_cfg cfg) \<bind> (\<lambda>cfg'. distr (T cfg') St (\<lambda>\<omega>. state cfg' ## \<omega>)))"
proof (rule measure_eqI)
  fix A assume "A \<in> sets (T cfg)"
  then show "emeasure (T cfg) A =
    emeasure (measure_pmf (K_cfg cfg) \<bind> (\<lambda>cfg'. distr (T cfg') St (\<lambda>\<omega>. state cfg' ## \<omega>))) A"
    by (subst emeasure_bind[where N=St])
       (auto simp: space_subprob_algebra nn_integral_distr nn_integral_indicator[symmetric] nn_integral_T[of _ cfg]
             simp del: nn_integral_indicator intro!: prob_space_imp_subprob_space T.prob_space_distr)
qed simp

lemma T_memoryless_on: "T (memoryless_on ct s) = MC_syntax.T ct s"
proof -
  interpret ct: MC_syntax ct .
  have "T \<circ> (memoryless_on ct) = MC_syntax.T ct"
  proof (rule ct.T_bisim[symmetric])
    fix s show "(T \<circ> memoryless_on ct) s =
        measure_pmf (ct s) \<bind> (\<lambda>s. distr ((T \<circ> memoryless_on ct) s) St ((##) s))"
      by (auto simp add: T_eq[of "memoryless_on ct s"] K_cfg_def map_pmf_rep_eq bind_distr[where K=St]
                         space_subprob_algebra T.prob_space_distr prob_space_imp_subprob_space
               intro!: bind_measure_pmf_cong)
  qed (simp_all, intro_locales)
  then show ?thesis by (simp add: fun_eq_iff)
qed

lemma nn_integral_T_lfp:
  assumes [measurable]: "case_prod g \<in> borel_measurable (count_space UNIV \<Otimes>\<^sub>M borel)"
  assumes cont_g: "\<And>s. sup_continuous (g s)"
  assumes int_g: "\<And>f cfg. f \<in> borel_measurable (stream_space (count_space UNIV)) \<Longrightarrow>
    (\<integral>\<^sup>+\<omega>. g (state cfg) (f \<omega>) \<partial>T cfg) = g (state cfg) (\<integral>\<^sup>+\<omega>. f \<omega> \<partial>T cfg)"
  shows "(\<integral>\<^sup>+\<omega>. lfp (\<lambda>f \<omega>. g (shd \<omega>) (f (stl \<omega>))) \<omega> \<partial>T cfg) =
    lfp (\<lambda>f cfg. \<integral>\<^sup>+t. g (state t) (f t) \<partial>K_cfg cfg) cfg"
proof (rule nn_integral_lfp)
  show "\<And>s. sets (T s) = sets St"
      "\<And>F. F \<in> borel_measurable St \<Longrightarrow> (\<lambda>a. g (shd a) (F (stl a))) \<in> borel_measurable St"
    by auto
next
  fix s and F :: "'s stream \<Rightarrow> ennreal" assume "F \<in> borel_measurable St"
  then show "(\<integral>\<^sup>+ a. g (shd a) (F (stl a)) \<partial>T s) =
           (\<integral>\<^sup>+ cfg. g (state cfg) (integral\<^sup>N (T cfg) F) \<partial>K_cfg s)"
    by (rewrite nn_integral_T) (simp_all add: int_g)
qed (auto intro!: order_continuous_intros cont_g[THEN sup_continuous_compose])

lemma emeasure_Collect_T:
  assumes [measurable]: "Measurable.pred St P"
  shows "emeasure (T cfg) {x\<in>space St. P x} =
    (\<integral>\<^sup>+cfg'. emeasure (T cfg') {x\<in>space St. P (state cfg' ## x)} \<partial>K_cfg cfg)"
  using MC.emeasure_Collect_T[of "\<lambda>x. P (smap state x)" cfg]
  by (simp add: nn_integral_distr emeasure_Collect_distr T_def)

definition E_sup :: "'s \<Rightarrow> ('s stream \<Rightarrow> ennreal) \<Rightarrow> ennreal"
where
  "E_sup s f = (\<Squnion>cfg\<in>cfg_on s. \<integral>\<^sup>+x. f x \<partial>T cfg)"

lemma E_sup_const: "0 \<le> c \<Longrightarrow> E_sup s (\<lambda>_. c) = c"
  using T.emeasure_space_1 by (simp add: E_sup_def)

lemma E_sup_mult_right:
  assumes [measurable]: "f \<in> borel_measurable St" and [simp]: "0 \<le> c"
  shows "E_sup s (\<lambda>x. c * f x) = c * E_sup s f"
  by (simp add: nn_integral_cmult E_sup_def SUP_mult_left_ennreal)

lemma E_sup_mono:
  "(\<And>\<omega>. f \<omega> \<le> g \<omega>) \<Longrightarrow> E_sup s f \<le> E_sup s g"
  unfolding E_sup_def by (intro SUP_subset_mono order_refl nn_integral_mono)

lemma E_sup_add:
  assumes [measurable]: "f \<in> borel_measurable St" "g \<in> borel_measurable St"
  shows "E_sup s (\<lambda>x. f x + g x) \<le> E_sup s f + E_sup s g"
proof -
  have "E_sup s (\<lambda>x. f x + g x) = (\<Squnion>cfg\<in>cfg_on s. (\<integral>\<^sup>+x. f x \<partial>T cfg) + (\<integral>\<^sup>+x. g x \<partial>T cfg))"
    by (simp add: E_sup_def nn_integral_add)
  also have "\<dots> \<le> (\<Squnion>cfg\<in>cfg_on s. \<integral>\<^sup>+x. f x \<partial>T cfg) + (\<Squnion>cfg\<in>cfg_on s. (\<integral>\<^sup>+x. g x \<partial>T cfg))"
    by (auto simp: SUP_le_iff intro!: add_mono SUP_upper)
  finally show ?thesis
    by (simp add: E_sup_def)
qed

lemma E_sup_add_left:
  assumes [measurable]: "f \<in> borel_measurable St"
  shows "E_sup s (\<lambda>x. f x + c) = E_sup s f + c"
  by (simp add: nn_integral_add E_sup_def T.emeasure_space_1[simplified] ennreal_SUP_add_left)

lemma E_sup_add_right:
  "f \<in> borel_measurable St \<Longrightarrow> E_sup s (\<lambda>x. c + f x) = c + E_sup s f"
  using E_sup_add_left[of f s c] by (simp add: add.commute)

lemma E_sup_SUP:
  assumes [measurable]: "\<And>i. f i \<in> borel_measurable St" and [simp]: "incseq f"
  shows "E_sup s (\<lambda>x. \<Squnion>i. f i x) = (\<Squnion>i. E_sup s (f i))"
  by (auto simp add: E_sup_def nn_integral_monotone_convergence_SUP intro: SUP_commute)

lemma E_sup_iterate:
  assumes [measurable]: "f \<in> borel_measurable St"
  shows "E_sup s f = (\<Squnion>D\<in>K s. \<integral>\<^sup>+ t. E_sup t (\<lambda>\<omega>. f (t ## \<omega>)) \<partial>measure_pmf D)"
proof -
  let ?v = "\<lambda>t. \<integral>\<^sup>+x. f (state t ## x) \<partial>T t"
  let ?p = "\<lambda>t. E_sup t (\<lambda>\<omega>. f (t ## \<omega>))"
  have "E_sup s f = (\<Squnion>cfg\<in>cfg_on s. \<integral>\<^sup>+t. ?v t \<partial>K_cfg cfg)"
    unfolding E_sup_def by (intro SUP_cong refl) (subst nn_integral_T, simp_all add: cfg_on_def)
  also have "\<dots> = (\<Squnion>D\<in>K s. \<integral>\<^sup>+t. ?p t \<partial>measure_pmf D)"
  proof (intro antisym SUP_least)
    fix cfg :: "'s cfg" assume cfg: "cfg \<in> cfg_on s"
    then show "(\<integral>\<^sup>+ t. ?v t \<partial>K_cfg cfg) \<le> (SUP D\<in>K s. \<integral>\<^sup>+t. ?p t \<partial>measure_pmf D)"
      by (auto simp: E_sup_def nn_integral_K_cfg AE_measure_pmf_iff
               intro!: nn_integral_mono_AE SUP_upper2)
  next
    fix D assume D: "D \<in> K s" show "(\<integral>\<^sup>+t. ?p t \<partial>D) \<le> (SUP cfg \<in> cfg_on s. \<integral>\<^sup>+ t. ?v t \<partial>K_cfg cfg)"
    proof cases
      assume p_finite: "\<forall>t\<in>D. ?p t < \<infinity>"
      show ?thesis
      proof (rule ennreal_le_epsilon)
        fix e :: real assume "0 < e"
        have "\<forall>t\<in>D. \<exists>cfg\<in>cfg_on t. ?p t \<le> ?v cfg + e"
        proof
          fix t assume "t \<in> D"
          moreover have "(SUP cfg \<in> cfg_on t. ?v cfg) = ?p t"
            unfolding E_sup_def by (simp add: cfg_on_def)
          ultimately have "(SUP cfg \<in> cfg_on t. ?v cfg) \<noteq> \<infinity>"
            using p_finite by auto
          from SUP_approx_ennreal[OF \<open>0<e\<close> _ refl this]
          show "\<exists>cfg\<in>cfg_on t. ?p t \<le> ?v cfg + e"
            by (auto simp add: E_sup_def intro: less_imp_le)
        qed
        then obtain cfg' where v_cfg': "\<And>t. t \<in> D \<Longrightarrow> ?p t \<le> ?v (cfg' t) + e" and
          cfg_on_cfg': "\<And>t. t \<in> D \<Longrightarrow> cfg' t \<in> cfg_on t"
          unfolding Bex_def bchoice_iff by blast

        let ?cfg = "Cfg s D cfg'"
        have cfg: "K_cfg ?cfg = map_pmf cfg' D"
          by (auto simp add: K_cfg_def fun_eq_iff cfg_on_cfg' intro!: map_pmf_cong)

        have "(\<integral>\<^sup>+ t. ?p t \<partial>D) \<le> (\<integral>\<^sup>+t. ?v (cfg' t) + e \<partial>D)"
          by (intro nn_integral_mono_AE) (simp add: v_cfg' AE_measure_pmf_iff)
        also have "\<dots> = (\<integral>\<^sup>+t. ?v (cfg' t) \<partial>D) + e"
          using \<open>0 < e\<close> measure_pmf.emeasure_space_1[of D]
          by (subst nn_integral_add) (auto intro: cfg_on_cfg' )
        also have "(\<integral>\<^sup>+t. ?v (cfg' t) \<partial>D) = (\<integral>\<^sup>+t. ?v t \<partial>K_cfg ?cfg)"
          by (simp add: cfg map_pmf_rep_eq nn_integral_distr)
        also have "\<dots> \<le> (SUP cfg\<in>cfg_on s. (\<integral>\<^sup>+t. ?v t \<partial>K_cfg cfg))"
          by (auto intro!: SUP_upper intro!: cfg_of_cfg_onI D cfg_on_cfg')
        finally show "(\<integral>\<^sup>+ t. ?p t \<partial>D) \<le> (SUP cfg \<in> cfg_on s. \<integral>\<^sup>+ t. ?v t \<partial>K_cfg cfg) + e"
          by (blast intro: add_mono)
      qed
    next
      assume "\<not> (\<forall>t\<in>D. ?p t < \<infinity>)"
      then obtain t where "t \<in> D" "?p t = \<infinity>"
        by (auto simp: not_less top_unique)
      then have "\<infinity> = pmf (D) t * ?p t"
        by (auto simp: ennreal_mult_top set_pmf_iff)
      also have "\<dots> = (SUP cfg \<in> cfg_on t. pmf (D) t * ?v cfg)"
        unfolding E_sup_def
        by (auto simp: SUP_mult_left_ennreal[symmetric])
      also have "\<dots> \<le> (SUP cfg \<in> cfg_on s. \<integral>\<^sup>+ t. ?v t \<partial>K_cfg cfg)"
        unfolding E_sup_def
      proof (intro SUP_least SUP_upper2)
        fix cfg :: "'s cfg" assume cfg: "cfg \<in> cfg_on t"

        let ?cfg = "Cfg s D ((memoryless_on arb_act) (t := cfg))"
        have C: "K_cfg ?cfg = map_pmf ((memoryless_on arb_act) (t := cfg)) D"
          by (auto simp add: K_cfg_def fun_eq_iff intro!: map_pmf_cong simp: cfg)

        show "?cfg \<in> cfg_on s"
          by (auto intro!: cfg_of_cfg_onI D cfg memoryless_on_cfg_onI)
        have "ennreal (pmf (D) t) * (\<integral>\<^sup>+ x. f (state cfg ## x) \<partial>T cfg) =
          (\<integral>\<^sup>+t'. (\<integral>\<^sup>+ x. f (state cfg ## x) \<partial>T cfg) * indicator {t} t' \<partial>D)"
          by (auto simp add:  max_def emeasure_pmf_single intro: mult_ac)
        also have "\<dots> = (\<integral>\<^sup>+cfg. ?v cfg * indicator {t} (state cfg) \<partial>K_cfg ?cfg)"
          unfolding C using cfg
          by (auto simp add: nn_integral_distr map_pmf_rep_eq split: split_indicator
                   simp del: nn_integral_indicator_singleton
                   intro!: nn_integral_cong)
        also have "\<dots> \<le> (\<integral>\<^sup>+cfg. ?v cfg \<partial>K_cfg ?cfg)"
          by (auto intro!: nn_integral_mono  split: split_indicator)
        finally show "ennreal (pmf (D) t) * (\<integral>\<^sup>+ x. f (state cfg ## x) \<partial>T cfg)
           \<le> (\<integral>\<^sup>+ t. \<integral>\<^sup>+ x. f (state t ## x) \<partial>T t \<partial>K_cfg ?cfg)" .
      qed
      finally show ?thesis
        by (simp add: top_unique del: Sup_eq_top_iff SUP_eq_top_iff)
    qed
  qed
  finally show ?thesis .
qed

lemma E_sup_bot: "E_sup s \<bottom> = 0"
  by (auto simp add: E_sup_def bot_ennreal)

lemma E_sup_lfp:
  fixes g
  defines "l \<equiv> \<lambda>f \<omega>. g (shd \<omega>) (f (stl \<omega>))"
  assumes measurable_g[measurable]: "case_prod g \<in> borel_measurable (count_space UNIV \<Otimes>\<^sub>M borel)"
  assumes cont_g: "\<And>s. sup_continuous (g s)"
  assumes int_g: "\<And>f cfg. f \<in> borel_measurable St \<Longrightarrow>
     (\<integral>\<^sup>+ \<omega>. g (state cfg) (f \<omega>) \<partial>T cfg) = g (state cfg) (integral\<^sup>N (T cfg) f)"
  shows "(\<lambda>s. E_sup s (lfp l)) = lfp (\<lambda>f s. \<Squnion>D\<in>K s. \<integral>\<^sup>+t. g t (f t) \<partial>measure_pmf D)"
proof (rule lfp_transfer_bounded[where \<alpha>="\<lambda>F s. E_sup s F" and f=l and P="\<lambda>f. f \<in> borel_measurable St"])
  show "sup_continuous (\<lambda>f s. \<Squnion>x\<in>K s. \<integral>\<^sup>+ t. g t (f t) \<partial>measure_pmf x)"
    using cont_g[THEN sup_continuous_compose] by (auto intro!: order_continuous_intros)
  show "sup_continuous l"
    using cont_g[THEN sup_continuous_compose] by (auto intro!: order_continuous_intros simp: l_def)
  show "\<And>F. (\<lambda>s. E_sup s \<bottom>) \<le> (\<lambda>s. \<Squnion>D\<in>K s. \<integral>\<^sup>+ t. g t (F t) \<partial>measure_pmf D)"
    using K_wf by (auto simp: E_sup_bot le_fun_def intro: SUP_upper2 )
next
  fix f :: "'s stream \<Rightarrow> ennreal" assume f: "f \<in> borel_measurable St"
  moreover
  have "E_sup s (\<lambda>\<omega>. g s (f \<omega>)) = g s (E_sup s f)" for s
    unfolding E_sup_def using int_g[OF f]
    by (subst SUP_sup_continuous_ennreal[OF cont_g, symmetric])
       (auto intro!: SUP_cong simp del: cfg_onD_state dest: cfg_onD_state[symmetric])
  ultimately show "(\<lambda>s. E_sup s (l f)) = (\<lambda>s. \<Squnion>D\<in>K s. \<integral>\<^sup>+ t. g t (E_sup t f) \<partial>measure_pmf D)"
    by (subst E_sup_iterate) (auto simp: l_def int_g fun_eq_iff intro!: SUP_cong nn_integral_cong)
qed (auto simp: bot_fun_def l_def SUP_apply[abs_def] E_sup_SUP)

definition "P_sup s P = (\<Squnion>cfg\<in>cfg_on s. emeasure (T cfg) {x\<in>space St. P x})"

lemma P_sup_eq_E_sup:
  assumes [measurable]: "Measurable.pred St P"
  shows "P_sup s P = E_sup s (indicator {x\<in>space St. P x})"
  by (auto simp add: P_sup_def E_sup_def intro!: SUP_cong nn_integral_cong)

lemma P_sup_True[simp]: "P_sup t (\<lambda>\<omega>. True) = 1"
  using T.emeasure_space_1
  by (auto simp add: P_sup_def SUP_constant)

lemma P_sup_False[simp]: "P_sup t (\<lambda>\<omega>. False) = 0"
  by (auto simp add: P_sup_def SUP_constant)

lemma P_sup_SUP:
  fixes P :: "nat \<Rightarrow> 's stream \<Rightarrow> bool"
  assumes "mono P" and P[measurable]: "\<And>i. Measurable.pred St (P i)"
  shows "P_sup s (\<lambda>x. \<exists>i. P i x) = (\<Squnion>i. P_sup s (P i))"
proof -
  have "P_sup s (\<lambda>x. \<Squnion>i. P i x) = (\<Squnion>cfg\<in>cfg_on s. emeasure (T cfg) (\<Union>i. {x\<in>space St. P i x}))"
    by (auto simp: P_sup_def intro!: SUP_cong arg_cong2[where f=emeasure])
  also have "\<dots> = (\<Squnion>cfg\<in>cfg_on s. \<Squnion>i. emeasure (T cfg) {x\<in>space St. P i x})"
    using \<open>mono P\<close> by (auto intro!: SUP_cong SUP_emeasure_incseq[symmetric] simp: mono_def le_fun_def)
  also have "\<dots> = (\<Squnion>i. P_sup s (P i))"
    by (subst SUP_commute) (simp add: P_sup_def)
  finally show ?thesis
    by simp
qed

lemma P_sup_lfp:
  assumes Q: "sup_continuous Q"
  assumes f: "f \<in> measurable St M"
  assumes Q_m: "\<And>P. Measurable.pred M P \<Longrightarrow> Measurable.pred M (Q P)"
  shows "P_sup s (\<lambda>x. lfp Q (f x)) = (\<Squnion>i. P_sup s (\<lambda>x. (Q ^^ i) \<bottom> (f x)))"
  unfolding sup_continuous_lfp[OF Q]
  apply simp
proof (rule P_sup_SUP)
  fix i show "Measurable.pred St (\<lambda>x. (Q ^^ i) \<bottom> (f x))"
    apply (intro measurable_compose[OF f])
    by (induct i) (auto intro!: Q_m)
qed (intro mono_funpow sup_continuous_mono[OF Q] mono_compose[where f=f])

lemma P_sup_iterate:
  assumes [measurable]: "Measurable.pred St P"
  shows "P_sup s P = (\<Squnion>D\<in>K s. \<integral>\<^sup>+ t. P_sup t (\<lambda>\<omega>. P (t ## \<omega>)) \<partial>measure_pmf D)"
proof -
  have [simp]: "\<And>x s. indicator {x \<in> space St. P x} (x ## s) = indicator {s \<in> space St. P (x ## s)} s"
    by (auto simp: space_stream_space split: split_indicator)
  show ?thesis
    using E_sup_iterate[of "indicator {x\<in>space St. P x}" s] by (auto simp: P_sup_eq_E_sup)
qed

definition "E_inf s f = (\<Sqinter>cfg\<in>cfg_on s. \<integral>\<^sup>+x. f x \<partial>T cfg)"

lemma E_inf_const: "0 \<le> c \<Longrightarrow> E_inf s (\<lambda>_. c) = c"
  using T.emeasure_space_1 by (simp add: E_inf_def)

lemma E_inf_mono:
  "(\<And>\<omega>. f \<omega> \<le> g \<omega>) \<Longrightarrow> E_inf s f \<le> E_inf s g"
  unfolding E_inf_def by (intro INF_superset_mono order_refl nn_integral_mono)

lemma E_inf_iterate:
  assumes [measurable]: "f \<in> borel_measurable St"
  shows "E_inf s f = (\<Sqinter>D\<in>K s. \<integral>\<^sup>+ t. E_inf t (\<lambda>\<omega>. f (t ## \<omega>)) \<partial>measure_pmf D)"
proof -
  let ?v = "\<lambda>t. \<integral>\<^sup>+x. f (state t ## x) \<partial>T t"
  let ?p = "\<lambda>t. E_inf t (\<lambda>\<omega>. f (t ## \<omega>))"
  have "E_inf s f = (\<Sqinter>cfg\<in>cfg_on s. \<integral>\<^sup>+t. ?v t \<partial>K_cfg cfg)"
    unfolding E_inf_def by (intro INF_cong refl) (subst nn_integral_T, simp_all add: cfg_on_def)
  also have "\<dots> = (\<Sqinter>D\<in>K s. \<integral>\<^sup>+t. ?p t \<partial>measure_pmf D)"
  proof (intro antisym INF_greatest)
    fix cfg :: "'s cfg" assume cfg: "cfg \<in> cfg_on s"
    then show "(INF D\<in>K s. \<integral>\<^sup>+t. ?p t \<partial>measure_pmf D) \<le> (\<integral>\<^sup>+ t. ?v t \<partial>K_cfg cfg)"
      by (auto simp add: E_inf_def nn_integral_K_cfg AE_measure_pmf_iff intro!: nn_integral_mono_AE INF_lower2)
  next
    fix D assume D: "D \<in> K s" show "(INF cfg \<in> cfg_on s. \<integral>\<^sup>+ t. ?v t \<partial>K_cfg cfg) \<le> (\<integral>\<^sup>+t. ?p t \<partial>D)"
    proof (rule ennreal_le_epsilon)
      fix e :: real assume "0 < e"
      have "\<forall>t\<in>D. \<exists>cfg\<in>cfg_on t. ?v cfg \<le> ?p t + e"
      proof
        fix t assume "t \<in> D"
        show "\<exists>cfg\<in>cfg_on t. ?v cfg \<le> ?p t + e"
        proof cases
          assume "?p t = \<infinity>" with cfg_on_not_empty[of t] show ?thesis
            by (auto simp: top_add simp del: cfg_on_not_empty)
        next
          assume p_finite: "?p t \<noteq> \<infinity>"
          note \<open>t \<in> D\<close>
          moreover have "(INF cfg \<in> cfg_on t. ?v cfg) = ?p t"
            unfolding E_inf_def by (simp add: cfg_on_def)
          ultimately have "(INF cfg \<in> cfg_on t. ?v cfg) \<noteq> \<infinity>"
            using p_finite by auto
          from INF_approx_ennreal[OF \<open>0 < e\<close> refl this]
          show "\<exists>cfg\<in>cfg_on t. ?v cfg \<le> ?p t + e"
            by (auto simp: E_inf_def intro: less_imp_le)
        qed
      qed
      then obtain cfg' where v_cfg': "\<And>t. t \<in> D \<Longrightarrow> ?v (cfg' t) \<le> ?p t + e" and
        cfg_on_cfg': "\<And>t. t \<in> D \<Longrightarrow> cfg' t \<in> cfg_on t"
        unfolding Bex_def bchoice_iff by blast

      let ?cfg = "Cfg s D cfg'"

      have cfg: "K_cfg ?cfg = map_pmf cfg' D"
        by (auto simp add: K_cfg_def cfg_on_cfg' intro!: map_pmf_cong)

      have "?cfg \<in> cfg_on s"
        by (auto intro: D cfg_on_cfg' cfg_of_cfg_onI)
      then have "(INF cfg \<in> cfg_on s. \<integral>\<^sup>+ t. ?v t \<partial>K_cfg cfg) \<le> (\<integral>\<^sup>+ t. ?p t + e \<partial>D)"
        by (rule INF_lower2) (auto simp: cfg map_pmf_rep_eq nn_integral_distr v_cfg' AE_measure_pmf_iff intro!: nn_integral_mono_AE)
      also have "\<dots> = (\<integral>\<^sup>+ t. ?p t \<partial>D) + e"
        using \<open>0 < e\<close> by (simp add: nn_integral_add measure_pmf.emeasure_space_1[simplified])
      finally show "(INF cfg \<in> cfg_on s. \<integral>\<^sup>+ t. ?v t \<partial>K_cfg cfg) \<le> (\<integral>\<^sup>+ t. ?p t \<partial>D) + e" .
    qed
  qed
  finally show ?thesis .
qed

lemma emeasure_T_const[simp]: "emeasure (T s) (space St) = 1"
  using T.emeasure_space_1[of s] by simp

lemma E_inf_greatest:
  "(\<And>cfg. cfg \<in> cfg_on s \<Longrightarrow> x \<le> (\<integral>\<^sup>+x. f x \<partial>T cfg)) \<Longrightarrow> x \<le> E_inf s f"
  unfolding E_inf_def by (rule INF_greatest)

lemma E_inf_lower2:
  "cfg \<in> cfg_on s \<Longrightarrow> (\<integral>\<^sup>+x. f x \<partial>T cfg) \<le> x \<Longrightarrow> E_inf s f \<le> x"
  unfolding E_inf_def by (rule INF_lower2)

text \<open>
  Maybe the following statement can be generalized to infinite @{term "K s"}.
\<close>

lemma E_inf_lfp:
  fixes g
  defines "l \<equiv> \<lambda>f \<omega>. g (shd \<omega>) (f (stl \<omega>))"
  assumes measurable_g[measurable]: "case_prod g \<in> borel_measurable (count_space UNIV \<Otimes>\<^sub>M borel)"
  assumes cont_g: "\<And>s. sup_continuous (g s)"
  assumes int_g: "\<And>f cfg. f \<in> borel_measurable St \<Longrightarrow>
     (\<integral>\<^sup>+ \<omega>. g (state cfg) (f \<omega>) \<partial>T cfg) = g (state cfg) (integral\<^sup>N (T cfg) f)"
  assumes K_finite: "\<And>s. finite (K s)"
  shows "(\<lambda>s. E_inf s (lfp l)) = lfp (\<lambda>f s. \<Sqinter>D\<in>K s. \<integral>\<^sup>+t. g t (f t) \<partial>measure_pmf D)"
proof (rule antisym)
  let ?F = "\<lambda>F s. \<Sqinter>D\<in>K s. \<integral>\<^sup>+ t. g t (F t) \<partial>measure_pmf D"
  let ?I = "\<lambda>D. (\<integral>\<^sup>+t. g t (lfp ?F t) \<partial>measure_pmf D)"
  have mono_F: "mono ?F"
    using sup_continuous_mono[OF cont_g]
    by (force intro!: INF_mono nn_integral_mono monoI simp: mono_def le_fun_def)
  define ct where "ct s = (SOME D. D \<in> K s \<and> (lfp ?F s = ?I D))" for s
  { fix s
    have "finite (?I ` K s)"
      by (auto intro: K_finite)
    then obtain D where "D \<in> K s" "?I D = Min (?I ` K s)"
      by (auto simp: K_wf dest!: Min_in)
    note this(2)
    also have "\<dots> = (INF D \<in> K s. ?I D)"
      using K_wf by (subst Min_Inf) (auto intro: K_finite)
    also have "\<dots> = lfp ?F s"
      by (rewrite in "_ = \<hole>" lfp_unfold[OF mono_F]) auto
    finally have "\<exists>D. D \<in> K s \<and> (lfp ?F s = ?I D)"
      using \<open>D \<in> K s\<close> by auto
    then have "ct s \<in> K s \<and> (lfp ?F s = ?I (ct s))"
      unfolding ct_def by (rule someI_ex)
    then have "ct s \<in> K s" "lfp ?F s = ?I (ct s)"
      by auto }
  note ct = this
  then have ct_cfg_on[simp]: "\<And>s. memoryless_on ct s \<in> cfg_on s"
    by (intro memoryless_on_cfg_onI) simp
  then show "(\<lambda>s. E_inf s (lfp l)) \<le> lfp ?F"
  proof (intro le_funI, rule E_inf_lower2)
    fix s
    define P where "P f cfg = \<integral>\<^sup>+ t. g (state t) (f t) \<partial>K_cfg cfg" for f cfg
    have "integral\<^sup>N (T (memoryless_on ct s)) (lfp l) = lfp P (memoryless_on ct s)"
      unfolding P_def l_def using measurable_g cont_g int_g by (rule nn_integral_T_lfp)
    also have "\<dots> = (SUP i. (P ^^ i) \<bottom>) (memoryless_on ct s)"
      by (rewrite sup_continuous_lfp)
         (auto intro!: order_continuous_intros cont_g[THEN sup_continuous_compose] simp: P_def)
    also have "\<dots> = (SUP i. (P ^^ i) \<bottom> (memoryless_on ct s))"
      by (simp add: image_comp)
    also have "\<dots> \<le> lfp ?F s"
    proof (rule SUP_least)
      fix i show "(P ^^ i) \<bottom> (memoryless_on ct s) \<le> lfp ?F s"
      proof (induction i arbitrary: s)
        case 0 then show ?case
          by simp
      next
        case (Suc n)
        have "(P ^^ Suc n) \<bottom> (memoryless_on ct s) =
          (\<integral>\<^sup>+ t. g t ((P ^^ n) \<bottom> (memoryless_on ct t)) \<partial>ct s)"
          by (auto simp add: P_def K_cfg_def AE_measure_pmf_iff intro!: nn_integral_cong_AE)
        also have "\<dots> \<le> (\<integral>\<^sup>+ t. g t (lfp ?F t) \<partial>ct s)"
          by (intro nn_integral_mono sup_continuous_mono[OF cont_g, THEN monoD] Suc)
        also have "\<dots> = lfp ?F s"
          by (rule  ct(2) [symmetric])
        finally show ?case .
      qed
    qed
    finally show "integral\<^sup>N (T (memoryless_on ct s)) (lfp l) \<le> lfp ?F s" .
  qed

  have cont_l: "sup_continuous l"
    by (auto simp: l_def intro!: order_continuous_intros cont_g[THEN sup_continuous_compose])

  show "lfp ?F \<le> (\<lambda>s. E_inf s (lfp l))"
  proof (intro lfp_lowerbound le_funI)
    fix s show "(\<Sqinter>x\<in>K s. \<integral>\<^sup>+ t. g t (E_inf t (lfp l)) \<partial>measure_pmf x) \<le> E_inf s (lfp l)"
    proof (rewrite in "_ \<le> \<hole>" E_inf_iterate)
      show l: "lfp l \<in> borel_measurable St"
        using cont_l by (rule borel_measurable_lfp) (simp add: l_def)
      show "(\<Sqinter>D\<in>K s. \<integral>\<^sup>+ t. g t (E_inf t (lfp l)) \<partial>measure_pmf D) \<le>
        (\<Sqinter>D\<in>K s. \<integral>\<^sup>+ t. E_inf t (\<lambda>\<omega>. lfp l (t ## \<omega>)) \<partial>measure_pmf D)"
      proof (rule INF_mono nn_integral_mono bexI)+
        fix t D assume "D \<in> K s"
        { fix cfg assume "cfg \<in> cfg_on t"
          have "(\<integral>\<^sup>+ \<omega>. g (state cfg) (lfp l \<omega>) \<partial>T cfg) = g (state cfg) (\<integral>\<^sup>+ \<omega>. (lfp l \<omega>) \<partial>T cfg)"
            using l by (rule int_g)
          with \<open>cfg \<in> cfg_on t\<close> have *: "(\<integral>\<^sup>+ \<omega>. g t (lfp l \<omega>) \<partial>T cfg) = g t (\<integral>\<^sup>+ \<omega>. (lfp l \<omega>) \<partial>T cfg)"
            by simp }
        then
        have *: "g t (\<Sqinter>cfg\<in>cfg_on t. integral\<^sup>N (T cfg) (lfp l)) \<le> (\<Sqinter>cfg\<in>cfg_on t. \<integral>\<^sup>+ \<omega>. g t (lfp l \<omega>) \<partial>T cfg)"
          apply simp
          apply (rule INF_greatest)
          apply (rule sup_continuous_mono[OF cont_g, THEN monoD])
          apply (rule INF_lower)
          apply assumption
          done
        show "g t (E_inf t (lfp l)) \<le> E_inf t (\<lambda>\<omega>. lfp l (t ## \<omega>))"
          apply (rewrite in "_ \<le> \<hole>" lfp_unfold[OF sup_continuous_mono[OF cont_l]])
          apply (rewrite in "_ \<le> \<hole>" l_def)
          apply (simp add: E_inf_def *)
          done
      qed
    qed
  qed
qed

definition "P_inf s P = (\<Sqinter>cfg\<in>cfg_on s. emeasure (T cfg) {x\<in>space St. P x})"

lemma P_inf_eq_E_inf:
  assumes [measurable]: "Measurable.pred St P"
  shows "P_inf s P = E_inf s (indicator {x\<in>space St. P x})"
  by (auto simp add: P_inf_def E_inf_def intro!: SUP_cong nn_integral_cong)

lemma P_inf_True[simp]: "P_inf t (\<lambda>\<omega>. True) = 1"
  using T.emeasure_space_1
  by (auto simp add: P_inf_def SUP_constant)

lemma P_inf_False[simp]: "P_inf t (\<lambda>\<omega>. False) = 0"
  by (auto simp add: P_inf_def SUP_constant)

lemma P_inf_gfp:
  assumes Q: "inf_continuous Q"
  assumes f: "f \<in> measurable St M"
  assumes Q_m: "\<And>P. Measurable.pred M P \<Longrightarrow> Measurable.pred M (Q P)"
  shows "P_inf s (\<lambda>x. gfp Q (f x)) = (\<Sqinter>i. P_inf s (\<lambda>x. (Q ^^ i) \<top> (f x)))"
  unfolding inf_continuous_gfp[OF Q]
  apply simp
proof (rule P_inf_INF)
  fix i show "Measurable.pred St (\<lambda>x. (Q ^^ i) \<top> (f x))"
    apply (intro measurable_compose[OF f])
    by (induct i) (auto intro!: Q_m)
next
  show "decseq (\<lambda>i x. (Q ^^ i) \<top> (f x))"
    using inf_continuous_mono[OF Q, THEN funpow_increasing[rotated]]
    unfolding decseq_def le_fun_def by auto
qed

lemma P_inf_iterate:
  assumes [measurable]: "Measurable.pred St P"
  shows "P_inf s P = (\<Sqinter>D\<in>K s. \<integral>\<^sup>+ t. P_inf t (\<lambda>\<omega>. P (t ## \<omega>)) \<partial>measure_pmf D)"
proof -
  have [simp]: "\<And>x s. indicator {x \<in> space St. P x} (x ## s) = indicator {s \<in> space St. P (x ## s)} s"
    by (auto simp: space_stream_space split: split_indicator)
  show ?thesis
    using E_inf_iterate[of "indicator {x\<in>space St. P x}" s] by (auto simp: P_inf_eq_E_inf)
qed

end

subsection \<open>Finite MDPs\<close>

locale Finite_Markov_Decision_Process = Markov_Decision_Process K for K :: "'s \<Rightarrow> 's pmf set" +
  fixes S :: "'s set"
  assumes S_not_empty: "S \<noteq> {}"
  assumes S_finite: "finite S"
  assumes K_closed: "\<And>s. s \<in> S \<Longrightarrow> (\<Union>D\<in>K s. set_pmf D) \<subseteq> S"
  assumes K_finite: "\<And>s. s \<in> S \<Longrightarrow> finite (K s)"
begin

lemma action_closed: "s \<in> S \<Longrightarrow> cfg \<in> cfg_on s \<Longrightarrow> t \<in> action cfg \<Longrightarrow> t \<in> S"
  using cfg_onD_action[of cfg s] K_closed[of s] by auto

lemma set_pmf_closed: "s \<in> S \<Longrightarrow> D \<in> K s \<Longrightarrow> t \<in> D \<Longrightarrow> t \<in> S"
  using K_closed by auto

lemma Pi_closed: "ct \<in> Pi S K \<Longrightarrow> s \<in> S \<Longrightarrow> t \<in> ct s \<Longrightarrow> t \<in> S"
  using set_pmf_closed by auto

lemma set_pmf_finite: "s \<in> S \<Longrightarrow> D \<in> K s \<Longrightarrow> finite D"
  using K_closed by (intro finite_subset[OF _ S_finite]) auto

definition "valid_cfg = (\<Union>s\<in>S. cfg_on s)"

lemma valid_cfgI: "s \<in> S \<Longrightarrow> cfg \<in> cfg_on s \<Longrightarrow> cfg \<in> valid_cfg"
  by (auto simp: valid_cfg_def)

lemma valid_cfgD: "cfg \<in> valid_cfg \<Longrightarrow> cfg \<in> cfg_on (state cfg)"
  by (auto simp: valid_cfg_def)

lemma
  shows valid_cfg_state_in_S: "cfg \<in> valid_cfg \<Longrightarrow> state cfg \<in> S"
    and valid_cfg_action: "cfg \<in> valid_cfg \<Longrightarrow> s \<in> action cfg \<Longrightarrow> s \<in> S"
    and valid_cfg_cont: "cfg \<in> valid_cfg \<Longrightarrow> s \<in> action cfg \<Longrightarrow> cont cfg s \<in> valid_cfg"
  by (auto simp: valid_cfg_def intro!: bexI[of _ s] intro: action_closed)

lemma valid_K_cfg[intro]: "cfg \<in> valid_cfg \<Longrightarrow> cfg' \<in> K_cfg cfg \<Longrightarrow> cfg' \<in> valid_cfg"
  by (auto simp add: K_cfg_def valid_cfg_cont)

definition "simple ct = memoryless_on (\<lambda>s. if s \<in> S then ct s else arb_act s)"

lemma simple_cfg_on[simp]: "ct \<in> Pi S K \<Longrightarrow> simple ct s \<in> cfg_on s"
  by (auto simp: simple_def intro!: memoryless_on_cfg_onI)

lemma simple_valid_cfg[simp]: "ct \<in> Pi S K \<Longrightarrow> s \<in> S \<Longrightarrow> simple ct s \<in> valid_cfg"
  by (auto intro: valid_cfgI)

lemma cont_simple[simp]: "s \<in> S \<Longrightarrow> t \<in> set_pmf (ct s) \<Longrightarrow> cont (simple ct s) t = simple ct t"
  by (simp add: simple_def)

lemma state_simple[simp]: "state (simple ct s) = s"
  by (simp add: simple_def)

lemma action_simple[simp]: "s \<in> S \<Longrightarrow> action (simple ct s) = ct s"
  by (simp add: simple_def)

lemma simple_valid_cfg_iff: "ct \<in> Pi S K \<Longrightarrow> simple ct s \<in> valid_cfg \<longleftrightarrow> s \<in> S"
  using cfg_onD_state[of "simple ct s"] by (auto simp add: valid_cfg_def intro!: bexI[of _ s])

end

end


section \<open> Theory of Invariants \<close>

theory utp_des_invariants
  imports utp_des_theory
begin

text \<open> The theory of invariants formalises operation and state invariants based on the theory
  of designs. For more information, please see the associated paper~\cite[Section~4]{Cavalcanti2012}. \<close>

subsection \<open> Operation Invariants \<close>

definition "OIH(\<psi>)(D) = (D \<and> ($ok \<and> \<not> D\<^sup>f \<Rightarrow> \<psi>))"

declare OIH_def [upred_defs]

lemma OIH_design:
  assumes "D is H1_H2"
  shows "OIH(\<psi>)(D) = ((\<not> D\<^sup>f) \<turnstile> (D\<^sup>t \<and> \<psi>))"
proof -
  from assms have "OIH(\<psi>)(D) = (((\<not> D\<^sup>f) \<turnstile> D\<^sup>t) \<and> ($ok \<and> \<not> D\<^sup>f \<Rightarrow> \<psi>))"
    by (metis H1_H2_commute H1_H2_is_design H1_idem Healthy_def' OIH_def)
  also have "... = (($ok \<and> \<not> D\<^sup>f \<Rightarrow> $ok\<acute> \<and> D\<^sup>t) \<and> ($ok \<and> \<not> D\<^sup>f \<Rightarrow> \<psi>))"
    by (simp add: design_def)
  also have "... = ((\<not> D\<^sup>f) \<turnstile> (D\<^sup>t \<and> \<psi>))"
    by (pred_auto)
  finally show ?thesis .
qed

lemma OIH_idem:
  assumes "D is H1_H2" "$ok\<acute> \<sharp> \<psi>"
  shows "OIH(\<psi>)(OIH(\<psi>)(D)) = OIH(\<psi>)(D)"
  using assms
  by (simp add: OIH_design design_is_H1_H2 unrest) (simp add: design_def usubst, rel_auto)

lemma OIH_of_design:
  "$ok\<acute> \<sharp> P \<Longrightarrow> OIH(\<psi>)(P \<turnstile> Q) = (P \<turnstile> (Q \<and> \<psi>))"
  by (simp add: OIH_def design_def usubst, rel_auto)

subsection \<open> State Invariants \<close>

definition "ISH(\<psi>)(D) = (D \<or> ($ok \<and> \<not> D\<^sup>f \<and> \<lceil>\<psi>\<rceil>\<^sub>< \<Rightarrow> $ok\<acute> \<and> D\<^sup>t))"

declare ISH_def [upred_defs]

lemma ISH_design: "ISH(\<psi>)(D) = (\<not> D\<^sup>f \<and> \<lceil>\<psi>\<rceil>\<^sub><) \<turnstile> D\<^sup>t"
  by (rel_auto, metis+)

lemma ISH_idem: "ISH(\<psi>)(ISH(\<psi>)(D)) = ISH(\<psi>)(D)"
  by (simp add: ISH_design usubst design_def, pred_auto)

lemma ISH_of_design:
  "\<lbrakk> $ok\<acute> \<sharp> P; $ok\<acute> \<sharp> Q \<rbrakk> \<Longrightarrow> ISH(\<psi>)(P \<turnstile> Q) = ((P \<and> \<lceil>\<psi>\<rceil>\<^sub><) \<turnstile> Q)"
  by (simp add: ISH_design design_def usubst, pred_auto)

definition "OSH(\<psi>)(D) = (D \<and> ($ok \<and> \<not> D\<^sup>f \<and> \<lceil>\<psi>\<rceil>\<^sub>< \<Rightarrow> \<lceil>\<psi>\<rceil>\<^sub>>))"

declare OSH_def [upred_defs]

lemma OSH_as_OIH:
  "OSH(\<psi>)(D) = OIH(\<lceil>\<psi>\<rceil>\<^sub>< \<Rightarrow> \<lceil>\<psi>\<rceil>\<^sub>>)(D)"
  by (simp add: OSH_def OIH_def, pred_auto)

lemma OSH_design:
  assumes "D is H1_H2"
  shows "OSH(\<psi>)(D) = ((\<not> D\<^sup>f) \<turnstile> (D\<^sup>t \<and> (\<lceil>\<psi>\<rceil>\<^sub>< \<Rightarrow> \<lceil>\<psi>\<rceil>\<^sub>>)))"
  by (simp add: OSH_as_OIH OIH_design assms)

lemma OSH_of_design:
  "\<lbrakk> $ok\<acute> \<sharp> P; $ok\<acute> \<sharp> Q \<rbrakk> \<Longrightarrow> OSH(\<psi>)(P \<turnstile> Q) = (P \<turnstile> (Q \<and> (\<lceil>\<psi>\<rceil>\<^sub>< \<Rightarrow> \<lceil>\<psi>\<rceil>\<^sub>>)))"
  by (simp add: OSH_design design_is_H1_H2 unrest, simp add: design_def usubst, pred_auto)

definition "SIH(\<psi>) = ISH(\<psi>) \<circ> OSH(\<psi>)"

declare SIH_def [upred_defs]

lemma SIH_of_design:
  "\<lbrakk> $ok\<acute> \<sharp> P; $ok\<acute> \<sharp> Q; ok \<sharp> \<psi> \<rbrakk> \<Longrightarrow> SIH(\<psi>)(P \<turnstile> Q) = ((P \<and> \<lceil>\<psi>\<rceil>\<^sub><) \<turnstile> (Q \<and> \<lceil>\<psi>\<rceil>\<^sub>>))"
  by (simp add: SIH_def OSH_of_design ISH_of_design unrest, pred_auto)

end


theory Coll_Test
imports
  "../../Refine_Dflt"
  "Succ_Graph"
begin

declare [[autoref_trace_failed_id]]

context begin interpretation autoref_syn .

schematic_goal "(?c::?'c,
  RETURN (({(1::nat,2::nat),(3,4)}):::(\<langle>\<langle>nat_rel,nat_rel\<rangle>prod_rel\<rangle>(map2set_rel (ahm_rel ?bhc))) )
)\<in>?R"
  apply autoref_monadic
  done

term dflt_ahs_rel

schematic_goal "(?c::?'c, \<lambda>(a::'a::hashable) (b::'a::hashable).
  ({(a,b)}:::\<langle>?Rk::(?'b::hashable\<times>_) set\<rangle>dflt_ahs_rel)
)\<in>?R"
  apply (autoref (keep_goal))
  done

subsection "Foreach-Loops"
schematic_goal "(?c::?'c,
  FOREACH {1,2,3::nat} (\<lambda>i s. RETURN (i+s)) 0
)\<in>?R"
  apply autoref_monadic
  done

schematic_goal "(?c::?'c,
  FOREACH (map_to_set [1::nat\<mapsto>True, 2\<mapsto>False]) (\<lambda>(k,v) s. RETURN (k+s)) 0
)\<in>?R"
  apply autoref_monadic
  done

(* TODO: generic algorithm for bounded hash code of sets! *)
schematic_goal "(?c::?'c,
  FOREACH
    (map_to_set ([{1::nat}\<mapsto>True, {2}\<mapsto>False]:::\<langle>\<langle>nat_rel\<rangle>dflt_rs_rel,bool_rel\<rangle>(rbt_map_rel ?cmp)))
    (\<lambda>(k,v) s. RETURN (v\<and>s)) False
)\<in>?R"
  apply autoref_monadic
  done

subsection "Array Hash Map Tests"

schematic_goal
  "(?f::?'c, \<lambda>m. (m)(1::nat\<mapsto>2::nat)) \<in> ?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  "(?f::?'c, \<lambda>m. (m:::\<langle>Id,Id\<rangle>dflt_ahm_rel)(1::nat\<mapsto>2::nat)) \<in> ?R"
apply (autoref (keep_goal))
done

schematic_goal
  "(?f::?'c, Map.empty:::\<langle>Id,Id\<rangle>dflt_ahm_rel) \<in> ?R"
apply (autoref)
done

schematic_goal
  fixes mi m
  (* TODO: Obviously, we cannot override the tyREL-rule for
    "nat\<rightharpoonup>nat" with this: *)
  assumes [autoref_rules]: "(mi,m)\<in>\<langle>nat_rel,nat_rel\<rangle>dflt_ahm_rel"
  shows "(?f::?'c,
    RETURN (card (dom (m:::\<langle>nat_rel,nat_rel\<rangle>dflt_ahm_rel)))) \<in> ?R"
  apply (autoref_monadic)
  done

(* Optimizations *)

subsection "List Map Tests"

definition foo::"(nat\<rightharpoonup>nat) nres" where "foo \<equiv>
  do {
    let X = Map.empty;
    ASSERT (1 \<notin> dom X);
    RETURN (X(1 \<mapsto> 2))
  }"

schematic_goal list_map_update_dj_test:
  "(?f::?'c, foo ::: \<langle>\<langle>Id,Id\<rangle>list_map_rel\<rangle>nres_rel) \<in> ?R"
  unfolding foo_def
  apply autoref_monadic
  done

schematic_goal
  "(?f::?'c, [1::nat \<mapsto> 2::nat, 3\<mapsto>4] ::: \<langle>nat_rel,nat_rel\<rangle>list_map_rel) \<in> ?R"
  apply autoref
  done

schematic_goal list_map_test:
  "(?f::?'c, RETURN (([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<langle>nat_rel,nat_rel\<rangle>list_map_rel) |`(-{1}))) \<in> ?R"
apply (autoref_monadic)
done
concrete_definition list_map_test uses list_map_test
value list_map_test

(* Why does this work:*)
schematic_goal
  "(?f::?'c, RETURN (card (dom ([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<langle>nat_rel,nat_rel\<rangle>list_map_rel)))) \<in> ?R"
apply (autoref_monadic)
done

(* But this doesn't? This is not specific to list_map;
   it doesn't work with dflt_rbt_rel either.*)
(*schematic_lemma
  "(?f::?'c, RETURN (dom ([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<langle>nat_rel,nat_rel\<rangle>list_map_rel))) \<in> ?R"
apply (autoref_monadic)
done*)

subsection "Array-Map Tests"

term "{1,2::nat} \<union> {3,4}"

schematic_goal array_set_test_code:
  "(?f::?'c, RETURN (({1,2::nat} \<union> {3,4}
       ::: \<langle>nat_rel\<rangle>iam_set_rel )))\<in>?R"
by (autoref_monadic (trace))

concrete_definition array_set_test uses array_set_test_code
print_theorems
value array_set_test

schematic_goal
  "(?f::?'c, RETURN (({1} ::: \<langle>nat_rel\<rangle>dflt_rs_rel) = {}))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_goal
  "(?f::?'c, RETURN (card {1,2,3::nat}))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_goal
  "(?f::?'c, RETURN (\<forall>x\<in>{1,2,3::nat}. x<4))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_goal
  "(?f::?'c, RETURN (\<exists>x\<in>{1,2,3::nat}. x<4))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_goal
  "(?f::?'c, RETURN (({1} ::: \<langle>nat_rel\<rangle>iam_set_rel) = {}))\<in>?R"
  apply (autoref_monadic (trace))
  done

schematic_goal
  assumes [autoref_rules]: "(f,f')\<in>nat_rel\<rightarrow>Rb"
  shows "(?f::?'c,f' 3)\<in>?R"
  by (autoref)

schematic_goal "(?f::?'c,
  RETURN (({1,2::nat} \<times> {3,4::nat}) ::: \<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

schematic_goal "(?f::?'c,
  RETURN ({1,2::nat} \<inter> ({3,4::nat}) ::: \<langle>Id\<rangle>list_set_rel)
)\<in>?R"
  by autoref_monadic

schematic_goal "(?f::?'c,
  RETURN ({1,2::nat} \<inter> ({3,4::nat}) ::: \<langle>Id\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

schematic_goal "(?f::?'c,
  RETURN (card (dom ([ 1::nat \<mapsto> True, 2\<mapsto>False ] ::: \<langle>Id,Id\<rangle>dflt_rm_rel )))
)\<in>?R"
  by autoref_monadic

text {* A hairy case for the operator identification heuristics for maps: *}
schematic_goal
  shows "(?f::?'c,
  \<lambda>m (x::'a::linorder) (y::'b::linorder). case_option
    None
    (\<lambda>m'. m' y)
    (m x)
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal
  shows "(?f::?'c,
  \<lambda>m (x::'a::hashable) (y::'b::hashable). case_option
    None
    (\<lambda>m'. m' y)
    (m x)
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  shows "(?f::?'c,
  \<lambda>m (x::'a::hashable) (y::'b::linorder). case_option
    None
    (\<lambda>m'. m' y)
    (m (x:::Id))
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  {1,2::'a::numeral} \<times> {3,4::'a}
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  {1,2::'a::{numeral,hashable}} \<times> ({3,4::'a} ::: \<langle>Id\<rangle>dflt_ahs_rel)
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  {1,2::nat} \<times> {3,4::nat}
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  {1,2::nat} \<inter> {3,4::nat}
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  RETURN (({1,2::nat} \<times> {3,4::nat}) ::: \<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

(* TODO: ty_REL hint is ignored. Reason: Seems to not properly work with GAs! *)
schematic_goal
  notes [autoref_tyrel] = ty_REL[where 'a = "(nat\<times>nat) set"
    and R="\<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel"]
  shows "(?f::?'c,
    RETURN (({1,2::nat} \<times> {3,4::nat}))
  )\<in>?R"
  by autoref_monadic

(* TODO: Iterator optimization does not capture
    foldli ((map fst \<circ> rbt_to_list) x)
pattern!
*)

text {* We have an optimized version for add on red-black trees *}
schematic_goal "(?f::?'c,
  [ 1::nat \<mapsto> True, 2::nat \<mapsto> False ] ++ [ 3::nat \<mapsto> True, 4::nat \<mapsto> False ]
)\<in>?R"
  by (autoref (keep_goal))

text {* The optimized version is also transfered through the map2set converter *}
schematic_goal "(?f::?'c,
  {1,2::nat} \<union> {3,4}
)\<in>?R"
  by (autoref (keep_goal))

text {* For list-sets, the generic version is used *}
schematic_goal "(?f::?'c,
  {1,2::nat} \<union> {3,4} ::: \<langle>Id\<rangle>list_set_rel
)\<in>?R"
  by (autoref (keep_goal))

lemma is_refgoal: "(c,a)\<in>R \<Longrightarrow> (c,a)\<in>R" .

schematic_goal "(?f::?'c,
  ({{1::nat}:::\<langle>Id\<rangle> map2set_rel dflt_rm_rel} )
  \<union> ({{2,3,4,5,5,6,7,8,98,9,0}})
)\<in>?R"
  by (autoref (keep_goal))

text {* The next two lemmas demonstrate optimization: The insert-operation
  is translated by @{term "op #"} *}
schematic_goal "(?f::?'c, {1,2,3,4::nat}:::\<langle>Id\<rangle>list_set_rel
  )\<in>?R"
  by (autoref (keep_goal))

schematic_goal
  "(?f::?'c, {{1},{2},{3},{4::nat}}:::\<langle>?R'::(?'d\<times>_) set\<rangle>list_set_rel
  )\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  SPEC (\<lambda>x. x\<in>({1,2,3::nat}:::\<langle>Id\<rangle>dflt_rs_rel))
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?f::?'c,
  \<lambda>s::nat set. {s} \<union> {{1,2,3}} = {{1}}
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?f::?'c,
  \<forall>(k,v)\<in>map_to_set [1::nat\<mapsto>2::nat]. k>v
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c, do {
  let s = ({1,2,3::nat}:::\<langle>Id\<rangle>dflt_rs_rel);
  FOREACH s (\<lambda>n s. RETURN (n+s)) 0
}
)\<in>?R"
  by autoref_monadic

schematic_goal "(?f::?'c, do {
  let s = ({{1,2,3::nat}, {}, {1,2}});
  FOREACH s (\<lambda>n s. RETURN (n \<union> s)) {}
}
)\<in>?R"
  by (autoref_monadic)

schematic_goal "(?f::?'c,
  ({{1::nat}} )
  \<union> ({{2,3,4,5,5,6,7,8,98,9,0}})
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  SPEC (\<lambda>x. x\<in>({1,2,3::nat}))
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?f::?'c,
  \<lambda>s::nat set. {s} \<union> {{1,2,3}} = {{1}}
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?f::?'c,
  \<forall>(k,v)\<in>map_to_set [1::nat\<mapsto>2::nat]. k>v
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?f::?'c,
  [ 1::nat \<mapsto> [ 2::nat \<mapsto> 3::nat, 1::nat \<mapsto> 3::nat ] ]
)\<in>?R"
  apply (autoref (keep_goal))
  done

end

text {* Indirect Annotation *}
consts
  rel_set1 :: rel_name
  rel_set2 :: rel_name

context begin interpretation autoref_syn .

definition
  "algo \<equiv> ( {1,2,3::nat}::#rel_set1, {1,2,3::nat}::#rel_set2 )"

schematic_goal
  notes [autoref_rel_indirect] =
    REL_INDIRECT[of rel_set1 "\<langle>Rk\<rangle>list_set_rel" for Rk]
    REL_INDIRECT[of rel_set2 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
  shows "(?f::?'c,algo) \<in> ?R"
  unfolding algo_def
  by (autoref)

schematic_goal
  notes [autoref_rel_indirect] =
    REL_INDIRECT[of rel_set1 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
    REL_INDIRECT[of rel_set2 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
  shows "(?f::?'c,algo) \<in> ?R"
  unfolding algo_def
  by (autoref)

text {* A witness of the red algorithm is a node on the stack and a path
  to this node *}
type_synonym 'v red_witness = "('v list \<times> 'v) option"
text {* Prepend node to red witness *}
fun prep_wit_red :: "'v \<Rightarrow> 'v red_witness \<Rightarrow> 'v red_witness" where
  "prep_wit_red v None = None"
| "prep_wit_red v (Some (p,u)) = Some (v#p,u)"

text {*
  Initial witness for node @{text "u"} with onstack successor @{text "v"}
  *}
definition red_init_witness :: "'v \<Rightarrow> 'v \<Rightarrow> 'v red_witness" where
  "red_init_witness u v = Some ([u],v)"

definition red_dfs where
  "red_dfs E onstack V u \<equiv>
    REC\<^sub>T (\<lambda>D (V,u). do {
      let V=(insert u V);

      (* Check whether we have a successor on stack *)
      brk \<leftarrow> FOREACH\<^sub>C (E``{u}) (\<lambda>brk. brk=None)
        (\<lambda>t _. if t\<in>onstack then RETURN (red_init_witness u t) else RETURN None)
        None;

      (* Recurse for successors *)
      case brk of
        None \<Rightarrow>
          FOREACH\<^sub>C ((E``{u})) (\<lambda>(V,brk). brk=None)
            (\<lambda>t (V,_).
              if t\<notin>V then do {
                (V,brk) \<leftarrow> D (V,t);
                RETURN (V,prep_wit_red u brk)
              } else RETURN (V,None))
            (V,None)
      | _ \<Rightarrow> RETURN (V,brk)
    }) (V,u)
  "

abbreviation "i_red_witness \<equiv> \<langle>\<langle>\<langle>i_nat\<rangle>\<^sub>ii_list,i_nat\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_option"
lemma [autoref_itype]:
  "red_init_witness ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_nat \<rightarrow>\<^sub>i i_red_witness"
  "prep_wit_red ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_red_witness \<rightarrow>\<^sub>i i_red_witness"
  by auto

abbreviation "red_witness_rel \<equiv> \<langle>\<langle>\<langle>nat_rel\<rangle>list_rel,nat_rel\<rangle>prod_rel\<rangle>option_rel"

lemma [autoref_rules_raw]:
  "(red_init_witness,red_init_witness) \<in> nat_rel\<rightarrow>nat_rel\<rightarrow>red_witness_rel"
  "(prep_wit_red,prep_wit_red) \<in> nat_rel \<rightarrow> red_witness_rel \<rightarrow> red_witness_rel"
  by (auto)

(*schematic_lemma
  "(?f, RECT (\<lambda>D x. D x)) \<in> (?R::(?'c\<times>_) set)"
  apply (autoref (keep_goal))
  done*)

schematic_goal red_dfs_impl:
  notes [[goals_limit = 1]]
  fixes u'::"nat" and V'::"nat set"
  assumes [autoref_rules]:
    "(u,u')\<in>nat_rel"
    "(V,V')\<in>\<langle>nat_rel\<rangle>dflt_rs_rel"
    "(onstack,onstack')\<in>\<langle>nat_rel\<rangle>dflt_rs_rel"
    "(E,E')\<in>\<langle>nat_rel\<rangle>slg_rel"
  shows "(?f, red_dfs E' onstack' V' u') \<in> (?R::(?'c\<times>_) set)"
  apply -
  unfolding red_dfs_def
  apply (autoref_monadic (trace))
  done

concrete_definition red_dfs_impl for E onstack V u uses red_dfs_impl

prepare_code_thms red_dfs_impl_def

export_code red_dfs_impl in SML

end
end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
Hoare reasoning and WP (weakest-precondition) generator rules for the option monad.

This list is almost certainly incomplete; add rules here as they are needed.
*)

theory OptionMonadWP
imports
  OptionMonadND
  WP
  No_Fail
begin

(* Hoare triples.
   TODO: design a sensible syntax for them. *)

(* Partial correctness. *)
definition ovalid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 'a option) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" where
  "ovalid P f Q \<equiv> \<forall>s r. P s \<and> f s = Some r \<longrightarrow> Q r s"
(* Total correctness. *)
definition ovalidNF :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 'a option) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" where
  "ovalidNF P f Q \<equiv> \<forall>s. P s \<longrightarrow> (f s \<noteq> None \<and> (\<forall>r. f s = Some r \<longrightarrow> Q r s))"
(* Termination. *)
definition no_ofail where "no_ofail P f \<equiv> \<forall>s. P s \<longrightarrow> f s \<noteq> None"

(*
This rule lets us apply ovalidNF machinery for proving no_ofail.
However, we ought to eventually write working wp rules for no_ofail (see below).
*)
lemma no_ofail_is_ovalidNF: "no_ofail P f \<equiv> ovalidNF P f (\<lambda>_ _. True)"
  by (simp add: no_ofail_def ovalidNF_def)
lemma ovalidNF_combine: "\<lbrakk> ovalid P f Q; no_ofail P f \<rbrakk> \<Longrightarrow> ovalidNF P f Q"
  by (auto simp: ovalidNF_def ovalid_def no_ofail_def)

(* use ovalid with f s = Some r *)
lemma use_ovalidE:
  "\<lbrakk>ovalid P f Q; P s; f s = Some r; Q r s \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (clarsimp simp: ovalid_def)

lemma use_ovalid:
  "\<lbrakk>ovalid P f Q; f s = Some r; P s \<rbrakk> \<Longrightarrow> Q r s"
  by (clarsimp simp: ovalid_def)

(* Annotating programs with loop invariant and measure. *)
definition owhile_inv ::
  "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'a option) \<Rightarrow> 'a
   \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> nat) \<Rightarrow> 's \<Rightarrow> 'a option"
  where "owhile_inv C B x I M = owhile C B x"

lemmas owhile_add_inv = owhile_inv_def[symmetric]

(* WP rules for ovalid. *)
lemma obind_wp[wp]:
  "\<lbrakk> \<And>r. ovalid (R r) (g r) Q; ovalid P f R \<rbrakk> \<Longrightarrow> ovalid P (obind f g) Q"
  by (simp add: ovalid_def obind_def split: option.splits, fast)

lemma oreturn_wp[wp]:
  "ovalid (P x) (oreturn x) P"
  by (simp add: ovalid_def)

lemma ocondition_wp[wp]:
  "\<lbrakk> ovalid L l Q; ovalid R r Q \<rbrakk>
   \<Longrightarrow> ovalid (\<lambda>s. if C s then L s else R s) (ocondition C l r) Q"
  by (auto simp: ovalid_def ocondition_def)

lemma ofail_wp[wp]:
  "ovalid (\<lambda>_. True) ofail Q"
  by (simp add: ovalid_def ofail_def)

lemma ovalid_K_bind_wp[wp]:
  "ovalid P f Q \<Longrightarrow> ovalid P (K_bind f x) Q"
  by simp

lemma asks_wp[wp]:
  "ovalid (\<lambda>s. P (f s) s) (asks f) P"
  by (simp add: split_def asks_def oreturn_def obind_def ovalid_def)

(* more direct form *)
lemma asks_SomeD:
  "\<lbrakk>asks f s = Some r; Q (f s) s\<rbrakk> \<Longrightarrow> Q r s"
  by (rule use_ovalid[OF asks_wp])

lemma ogets_wp[wp]:
  "ovalid (\<lambda>s. P (f s) s) (ogets f) P"
  by wp

lemma oguard_wp[wp]:
  "ovalid (\<lambda>s. f s \<longrightarrow> P () s) (oguard f) P"
  by (simp add: ovalid_def oguard_def)

lemma oskip_wp[wp]:
  "ovalid (\<lambda>s. P () s) oskip P"
  by (simp add: ovalid_def oskip_def)

lemma ovalid_case_prod[wp]:
  assumes "(\<And>x y. ovalid (P x y) (B x y) Q)"
  shows "ovalid (case v of (x, y) \<Rightarrow> P x y) (case v of (x, y) \<Rightarrow> B x y) Q"
  using assms unfolding ovalid_def by auto

lemma owhile_ovalid[wp]:
  "\<lbrakk>\<And>a. ovalid (\<lambda>s. I a s \<and> C a s) (B a) I;
    \<And>a s. \<lbrakk>I a s; \<not> C a s\<rbrakk> \<Longrightarrow> Q a s\<rbrakk>
   \<Longrightarrow> ovalid (I a) (owhile_inv C B a I M) Q"
  unfolding owhile_inv_def owhile_def ovalid_def
  apply clarify
  apply (frule_tac I = "\<lambda>a. I a s" in option_while_rule)
  apply auto
  done

definition ovalid_property where "ovalid_property P x = (\<lambda>s f. (\<forall>r. Some r = x s f \<longrightarrow> P r s))"

lemma ovalid_is_triple[wp_trip]:
  "ovalid P f Q = triple_judgement P f (ovalid_property Q (\<lambda>s f. f s))"
  by (auto simp: triple_judgement_def ovalid_def ovalid_property_def)

lemma ovalid_wp_comb1[wp_comb]:
  "\<lbrakk> ovalid P' f Q; ovalid P f Q'; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> ovalid P f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (simp add: ovalid_def)

lemma ovalid_wp_comb2[wp_comb]:
  "\<lbrakk> ovalid P f Q; \<And>s. P' s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow> ovalid P' f Q"
  by (auto simp: ovalid_def)

lemma ovalid_wp_comb3[wp_comb]:
  "\<lbrakk> ovalid P f Q; ovalid P' f Q' \<rbrakk> \<Longrightarrow> ovalid (\<lambda>s. P s \<and> P' s) f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (auto simp: ovalid_def)

(* WP rules for ovalidNF. *)
lemma obind_NF_wp[wp]:
  "\<lbrakk> \<And>r. ovalidNF (R r) (g r) Q; ovalidNF P f R \<rbrakk> \<Longrightarrow> ovalidNF P (obind f g) Q"
  by (auto simp: ovalidNF_def obind_def split: option.splits)

lemma oreturn_NF_wp[wp]:
  "ovalidNF (P x) (oreturn x) P"
  by (simp add: ovalidNF_def oreturn_def)

lemma ocondition_NF_wp[wp]:
  "\<lbrakk> ovalidNF L l Q; ovalidNF R r Q \<rbrakk>
   \<Longrightarrow> ovalidNF (\<lambda>s. if C s then L s else R s) (ocondition C l r) Q"
  by (simp add: ovalidNF_def ocondition_def)

lemma ofail_NF_wp[wp]:
  "ovalidNF (\<lambda>_. False) ofail Q"
  by (simp add: ovalidNF_def ofail_def)

lemma ovalidNF_K_bind_wp[wp]:
  "ovalidNF P f Q \<Longrightarrow> ovalidNF P (K_bind f x) Q"
  by simp

lemma ogets_NF_wp[wp]:
  "ovalidNF (\<lambda>s. P (f s) s) (ogets f) P"
  by (simp add: ovalidNF_def ogets_def)

lemma oguard_NF_wp[wp]:
  "ovalidNF (\<lambda>s. f s \<and> P () s) (oguard f) P"
  by (simp add: ovalidNF_def oguard_def)

lemma oskip_NF_wp[wp]:
  "ovalidNF (\<lambda>s. P () s) oskip P"
  by (simp add: ovalidNF_def oskip_def)

lemma ovalid_NF_case_prod[wp]:
  assumes "(\<And>x y. ovalidNF (P x y) (B x y) Q)"
  shows "ovalidNF (case v of (x, y) \<Rightarrow> P x y) (case v of (x, y) \<Rightarrow> B x y) Q"
  using assms unfolding ovalidNF_def by auto

lemma owhile_NF[wp]:
  "\<lbrakk>\<And>a. ovalidNF (\<lambda>s. I a s \<and> C a s) (B a) I;
    \<And>a m. ovalid (\<lambda>s. I a s \<and> C a s \<and> M a s = m) (B a) (\<lambda>r s. M r s < m);
    \<And>a s. \<lbrakk>I a s; \<not> C a s\<rbrakk> \<Longrightarrow> Q a s\<rbrakk>
   \<Longrightarrow> ovalidNF (I a) (owhile_inv C B a I M) Q"
  unfolding owhile_inv_def ovalidNF_def ovalid_def
  apply clarify
  apply (rule_tac I = I and M = "measure (\<lambda>r. M r s)" in owhile_rule)
       apply fastforce
      apply fastforce
     apply fastforce
    apply blast+
  done

definition ovalidNF_property where
  "ovalidNF_property P x = (\<lambda>s f. (x s f \<noteq> None \<and> (\<forall>r. Some r = x s f \<longrightarrow> P r s)))"

lemma ovalidNF_is_triple[wp_trip]:
  "ovalidNF P f Q = triple_judgement P f (ovalidNF_property Q (\<lambda>s f. f s))"
  by (auto simp: triple_judgement_def ovalidNF_def ovalidNF_property_def)

lemma ovalidNF_wp_comb1[wp_comb]:
  "\<lbrakk> ovalidNF P' f Q; ovalidNF P f Q'; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> ovalidNF P f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (simp add: ovalidNF_def)

lemma ovalidNF_wp_comb2[wp_comb]:
  "\<lbrakk> ovalidNF P f Q; \<And>s. P' s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow> ovalidNF P' f Q"
  by (simp add: ovalidNF_def)

lemma ovalidNF_wp_comb3[wp_comb]:
  "\<lbrakk> ovalidNF P f Q; ovalidNF P' f Q' \<rbrakk> \<Longrightarrow> ovalidNF (\<lambda>s. P s \<and> P' s) f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (simp add: ovalidNF_def)

(* FIXME: WP rules for no_ofail, which might not be correct. *)
lemma no_ofailD:
  "\<lbrakk> no_ofail P m; P s \<rbrakk> \<Longrightarrow> \<exists>y. m s = Some y"
  by (simp add: no_ofail_def)

lemma no_ofail_obind2[simp]:
  assumes f: "no_ofail P f"
  assumes v: "ovalid Q f R"
  assumes g: "\<And>r. no_ofail (R r) (g r)"
  shows "no_ofail (P and Q) (f |>> g)"
  using v g
  by (fastforce simp: no_ofail_def obind_def pred_conj_def ovalid_def dest: no_ofailD [OF f])

lemma no_ofail_ofail[wp]:
  "no_ofail \<bottom> ofail"
  by (simp add: no_ofail_def)

lemma no_ofail_asks_simp[simp]:
  "no_ofail P (asks f)"
  unfolding asks_def get_def oreturn_def obind_def no_ofail_def
  by simp

lemma no_ofail_asks[wp]:
  "no_ofail \<top> (asks f)"
  by simp

lemma no_ofail_ogets[wp]:
  "no_ofail \<top> (ogets f)"
  by simp

lemma no_ofail_obind[wp]:
  "\<lbrakk> \<And>r. no_ofail (P r) (g r); no_ofail Q f; ovalid Q f P \<rbrakk> \<Longrightarrow> no_ofail Q (obind f g)"
  by (auto simp: no_ofail_def obind_def ovalid_def)

lemma no_ofail_K_bind[wp]:
  "no_ofail P f \<Longrightarrow> no_ofail P (K_bind f x)"
  by simp

lemma no_ofail_oguard[wp]:
  "no_ofail (\<lambda>s. f s) (oguard f)"
  by (auto simp: no_ofail_def oguard_def)

lemma no_ofail_ocondition[wp]:
  "\<lbrakk> no_ofail L l; no_ofail R r \<rbrakk>
     \<Longrightarrow> no_ofail (\<lambda>s. if C s then L s else R s) (ocondition C l r)"
  by (simp add: no_ofail_def ocondition_def)

lemma no_ofail_oreturn[wp]:
  "no_ofail (\<lambda>_. True) (oreturn x)"
  by (simp add: no_ofail_def oreturn_def)

lemma no_ofail_oskip[wp]:
  "no_ofail (\<lambda>_. True) oskip"
  by (simp add: no_ofail_def oskip_def)

lemma no_ofail_oassert_opt[simp, wp]:
  "no_ofail (\<lambda>_. P \<noteq> None) (oassert_opt P)"
  by (simp add: no_ofail_def oassert_opt_def split: option.splits)

lemma no_ofail_owhen[wp]:
  "(P \<Longrightarrow> no_ofail Q f) \<Longrightarrow> no_ofail (if P then Q else \<top>) (owhen P f)"
  by (simp add: no_ofail_def owhen_def)

lemma no_ofail_ounless[wp]:
  "(\<not>P \<Longrightarrow> no_ofail Q f) \<Longrightarrow> no_ofail (if P then \<top> else Q) (ounless P f)"
  by (simp add: no_ofail_def ounless_def)

lemma no_ofail_oassert[simp, wp]:
  "no_ofail (\<lambda>_. P) (oassert P)"
  by (simp add: oassert_def no_ofail_def)

lemma no_ofail_gets_the:
  "no_ofail P f \<Longrightarrow> no_fail P (gets_the (f :: ('s, 'a) lookup))"
  by (fastforce simp: no_ofail_def no_fail_def gets_the_def gets_def
                      get_def assert_opt_def bind_def return_def fail_def
               split: option.split)

lemma no_ofail_is_triple[wp_trip]:
  "no_ofail P f = triple_judgement P f (\<lambda>s f. f s \<noteq> None)"
  by (auto simp: triple_judgement_def no_ofail_def)

lemma no_ofail_wp_comb1[wp_comb]:
  "\<lbrakk> no_ofail P f; \<And>s. P' s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow> no_ofail P' f"
  by (simp add: no_ofail_def)

lemma no_ofail_wp_comb2[wp_comb]:
  "\<lbrakk> no_ofail P f; no_ofail P' f \<rbrakk> \<Longrightarrow> no_ofail (\<lambda>s. P s \<and> P' s) f"
  by (simp add: no_ofail_def)

(* Lemmas relating ovalid and valid *)
lemma ovalid_gets_the:
  "ovalid P f Q \<Longrightarrow> \<lbrace>P\<rbrace> gets_the f \<lbrace>Q\<rbrace>"
  apply wpsimp
  apply (fastforce dest: use_ovalid)
  done

(* Some extra lemmas for our predicates. *)
lemma ovalid_grab_asm:
  "(G \<Longrightarrow> ovalid P f Q) \<Longrightarrow> ovalid (\<lambda>s. G \<and> P s) f Q"
  by (simp add: ovalid_def)

lemma ovalidNF_grab_asm:
  "(G \<Longrightarrow> ovalidNF P f Q) \<Longrightarrow> ovalidNF (\<lambda>s. G \<and> P s) f Q"
  by (simp add: ovalidNF_def)

lemma no_ofail_grab_asm:
  "(G \<Longrightarrow> no_ofail P f) \<Longrightarrow> no_ofail (\<lambda>s. G \<and> P s) f"
  by (simp add: no_ofail_def)

lemma ovalid_assume_pre:
  "(\<And>s. P s \<Longrightarrow> ovalid P f Q) \<Longrightarrow> ovalid P f Q"
  by (auto simp: ovalid_def)

lemma ovalidNF_assume_pre:
  "(\<And>s. P s \<Longrightarrow> ovalidNF P f Q) \<Longrightarrow> ovalidNF P f Q"
  by (simp add: ovalidNF_def)

lemma no_ofail_assume_pre:
  "(\<And>s. P s \<Longrightarrow> no_ofail P f) \<Longrightarrow> no_ofail P f"
  by (simp add: no_ofail_def)

lemma ovalid_pre_imp:
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; ovalid P f Q \<rbrakk> \<Longrightarrow> ovalid P' f Q"
  by (simp add: ovalid_def)

lemma ovalidNF_pre_imp:
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; ovalidNF P f Q \<rbrakk> \<Longrightarrow> ovalidNF P' f Q"
  by (simp add: ovalidNF_def)

lemma no_ofail_pre_imp:
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; no_ofail P f \<rbrakk> \<Longrightarrow> no_ofail P' f"
  by (simp add: no_ofail_def)

lemma ovalid_post_imp:
  "\<lbrakk> \<And>r s. Q r s \<Longrightarrow> Q' r s; ovalid P f Q \<rbrakk> \<Longrightarrow> ovalid P f Q'"
  by (simp add: ovalid_def)

lemma ovalidNF_post_imp:
  "\<lbrakk> \<And>r s. Q r s \<Longrightarrow> Q' r s; ovalidNF P f Q \<rbrakk> \<Longrightarrow> ovalidNF P f Q'"
  by (simp add: ovalidNF_def)

lemma ovalid_post_imp_assuming_pre:
  "\<lbrakk> \<And>r s. \<lbrakk> P s; Q r s \<rbrakk> \<Longrightarrow> Q' r s; ovalid P f Q \<rbrakk> \<Longrightarrow> ovalid P f Q'"
  by (simp add: ovalid_def)

lemma ovalidNF_post_imp_assuming_pre:
  "\<lbrakk> \<And>r s. \<lbrakk> P s; Q r s \<rbrakk> \<Longrightarrow> Q' r s; ovalidNF P f Q \<rbrakk> \<Longrightarrow> ovalidNF P f Q'"
  by (simp add: ovalidNF_def)

end