(* Title:   Compose_SST_SST.thy
   Author:  Akama Hitoshi
*)

section \<open>Composition of SST and SST\<close>

theory Compose_SST_SST
  imports Main HOL.List HOL.Option "../Core/Update" "../Core/Transducer" "../Core/SST" "../Core/Monoid_SST"
begin

subsection \<open>Definition of a strange transducer and its property\<close>

(* Combine two transition function (q \<times> x \<Rightarrow> q and q \<times> b \<Rightarrow> q) into a new trans fun *)
fun delta2f ::
  "('q, 'x) trans => ('q, 'b) trans => ('q, 'x + 'b) trans" where
  "delta2f f g (q, Inl x) = f (q, x)" |
  "delta2f f g (q, Inr a) = g (q, a)"

(* eta2f is a function described in Akama's graduate thesis *)
fun eta2f ::
  "('q2, 'y, 'b, 'c) SST.updator => ('q2, 'x + 'b, 'q2 \<times> 'x + ('y, 'c) update) Transducer.out" where
  "eta2f e2 (q2, Inl x) = [Inl (q2, x)]" |
  "eta2f e2 (q2, Inr b) = [Inr (e2 (q2, b))]"

definition \<Delta> :: "('q, 'b) trans
              \<Rightarrow> ('q, 'x) trans \<times> ('z, 'x, 'b) update' \<Rightarrow> ('q, 'z) trans"
  where "\<Delta> t = (\<lambda>(f, \<theta>). (\<lambda>(q, a). hat1 (delta2f f t) (q, \<theta> a)))"

definition H :: "('q2, 'b) trans \<Rightarrow> ('q2, 'x2, 'b, 'c) updator
              \<Rightarrow> ('q2, 'x1) trans \<times> ('z, 'x1, 'b) update' => ('q2 \<times> 'z, 'q2 \<times> 'x1, ('x2, 'c) update) update'"
  where "H tr to = (\<lambda>(f, \<theta>). (\<lambda>(q, a). Transducer.hat2 (delta2f f tr) (eta2f to) (q, \<theta> a)))"

proposition \<Delta>_assoc_string:
  "hat1 (delta2f (\<lambda>(q, a). hat1 (delta2f f tr) (q, theta a)) tr) (q, u) =
   hat1 (delta2f f tr) (q, hat_hom theta u)"
  by (induct u arbitrary: q rule: xa_induct, simp_all)

lemma \<Delta>_assoc: "\<Delta> t (f, \<phi> \<bullet> \<psi>) = \<Delta> t (\<Delta> t (f, \<phi>), \<psi>)"
  by (auto simp add: \<Delta>_def compU_apply \<Delta>_assoc_string)

proposition H_assoc_string:
  "hat_hom (\<lambda>(q2, x1). Transducer.hat2 (delta2f f t_trans) (eta2f t_out) (q2, theta x1))
     (Transducer.hat2 (delta2f (\<lambda>(q2, x1). hat1 (delta2f f t_trans) (q2, theta x1)) t_trans) (eta2f t_out) (q, u)) =
   Transducer.hat2 (delta2f f t_trans) (eta2f t_out) (q, hat_hom theta u)"
  by (induct u arbitrary: q rule: xa_induct, simp_all add: Transducer.eta_append)

lemma H_assoc: "H tr to (f, \<phi> \<bullet> \<psi>) = H tr to (f, \<phi>) \<bullet> H tr to (\<Delta> tr (f, \<phi>), \<psi>)"
  by (auto simp add: \<Delta>_def H_def compU_apply H_assoc_string)

subsection \<open>Construction\<close>

definition compose_\<delta> :: "('q1, 'x1, 'a, 'b) SST \<Rightarrow> ('q2, 'x2, 'b, 'c) SST \<Rightarrow>
                             ('q1 \<times> ('q2 \<times> 'x1 \<Rightarrow> 'q2), 'a) trans" where
  "compose_\<delta> sst1 sst2 =
     (\<lambda>((q1, f), a). (delta sst1 (q1, a), \<Delta> (delta sst2) (f, SST.eta sst1 (q1, a))))"

definition compose_\<eta> :: "('q1, 'x1, 'a, 'b) SST \<Rightarrow> ('q2, 'x2, 'b, 'c) SST \<Rightarrow>
                             ('q1 \<times> ('q2 \<times> 'x1 \<Rightarrow> 'q2), 'q2 \<times> 'x1, 'a, ('x2, 'c) update) updator" where
  "compose_\<eta> sst1 sst2 = (\<lambda>((q1, f), a). H (delta sst2) (eta sst2) (f, SST.eta sst1 (q1, a)))"

definition compose_final_update ::
  "('q1, 'x1, 'a, 'b) SST \<Rightarrow> ('q2, 'x2, 'b, 'c) SST \<Rightarrow>
   ('q1 \<times> ('q2 \<times> 'x1 \<Rightarrow> 'q2) \<Rightarrow> ('q2 \<times> 'x1 + ('x2, 'c) update) list option)" where
  "compose_final_update sst1 sst2 = (\<lambda>(q1, f).
     case SST.final sst1 q1 of
       Some u \<Rightarrow> Some (H (delta sst2) (SST.eta sst2) (f, \<lambda>x. u)
                        (initial sst2, ())) |
       None \<Rightarrow> None)"

definition compose_final_string ::
  "('q1, 'x1, 'a, 'b) SST \<Rightarrow> ('q2, 'x2, 'b, 'c) SST \<Rightarrow>
   ('q1 \<times> ('q2 \<times> 'x1 \<Rightarrow> 'q2) \<Rightarrow> ('x2 + 'c) list option)" where
  "compose_final_string sst1 sst2 = (\<lambda>(q1, f).
     case SST.final sst1 q1 of
       Some u \<Rightarrow> SST.final sst2 (\<Delta> (delta sst2) (f, \<lambda>x. u) (initial sst2, ())) |
       None \<Rightarrow> None)"

definition compose_SST_SST ::
  "('q1, 'x1, 'a, 'b) SST \<Rightarrow> ('q2, 'x2, 'b, 'c) SST \<Rightarrow>
   ('q1 \<times> ('q2 \<times> 'x1 \<Rightarrow> 'q2), 'q2 \<times> 'x1, 'x2, 'a, 'c) MSST" where
  "compose_SST_SST sst1 sst2 = \<lparr>
    initial = (initial sst1, \<lambda>(q2, x1). q2),
    delta   = compose_\<delta> sst1 sst2,
    eta     = compose_\<eta> sst1 sst2,
    final = compose_final_update sst1 sst2,
    final_string = compose_final_string sst1 sst2
   \<rparr>"

lemma compose_\<delta>_hat: "hat1 (compose_\<delta> sst1 sst2) ((q, f), w) =
        (delta_hat sst1 (q, w),
         \<Delta> (delta sst2) (f, SST.eta_hat sst1 (q, w)))"
proof (induct w arbitrary: q f)
  case Nil then show ?case by (simp add: idU_def \<Delta>_def)
next
  case (Cons a u) then show ?case by (simp add: compose_\<delta>_def \<Delta>_assoc)
qed

lemma compose_\<eta>_hat:
  "hat2 (compose_\<delta> sst1 sst2) (compose_\<eta> sst1 sst2) ((q, f), w) =
   H (delta sst2) (SST.eta sst2) (f, SST.eta_hat sst1 (q, w))"
proof (induct w arbitrary: q f)
  case Nil then show ?case by (simp add: idU_def H_def)
next
  case (Cons a u) then show ?case by (simp add: compose_\<delta>_def compose_\<eta>_def H_assoc)
qed

subsection \<open>Property of valuation\<close>

fun list_valuation :: "('x \<Rightarrow> 'a list) \<Rightarrow> ('x + 'a) list \<Rightarrow> 'a list" where
  "list_valuation \<mu> [] = []" |
  "list_valuation \<mu> (Inl x # w) = \<mu> x @ list_valuation \<mu> w" |
  "list_valuation \<mu> (Inr a # w) = a # list_valuation \<mu> w"

fun update_valuation :: "('x \<Rightarrow> ('y, 'b) update) \<Rightarrow> ('x + ('y, 'b) update) list \<Rightarrow> ('y, 'b) update" where
  "update_valuation \<mu> [] = idU" |
  "update_valuation \<mu> (Inl x # w) = \<mu> x \<bullet> update_valuation \<mu> w" |
  "update_valuation \<mu> (Inr m # w) = m \<bullet> update_valuation \<mu> w"

lemma valuate_list_valuation: "valuate u = list_valuation (\<lambda>x. []) u"
  by (induct u rule: xa_induct, simp_all)

lemma valuate_concatU_update_valuation: "concatU (valuate u) = update_valuation (\<lambda>x. idU) u"
  by (induct u rule: xa_induct, simp_all)

lemma valuation_delta_hat:
  assumes "\<forall>q x. hat1 t (q, \<mu> x) = f (q, x)"
  shows "hat1 t (q, list_valuation \<mu> (\<theta> x)) = \<Delta> t (f, \<theta>) (q, x)"
proof (simp add: \<Delta>_def)
  show "hat1 t (q, list_valuation \<mu> u) = hat1 (delta2f f t) (q, u)" for u
    using assms by (induct u arbitrary: q rule: xa_induct, simp_all)
qed

lemma valuate_delta_hat: "hat1 tr (q, valuate (\<theta> x)) = \<Delta> tr (\<lambda>(q, x). q, \<theta>) (q, x)"
  by (simp add: valuate_list_valuation valuation_delta_hat)

lemma valuation_eta_hat:
  assumes "\<forall>q x. hat1 tr (q, \<mu> x) = f (q, x)"
  assumes "\<forall>q x. hat2 tr to (q, \<mu> x) = g (q, x)"
  shows "hat2 tr to (q, list_valuation \<mu> (\<theta> x))
       = update_valuation g (H tr to (f, \<theta>) (q, x))"
proof (simp add: H_def)
  show "hat2 tr to (q, list_valuation \<mu> u)
       = update_valuation g (Transducer.hat2 (delta2f f tr) (eta2f to) (q, u))" for u
    by (induct u arbitrary: q rule: xa_induct, simp_all add: eta_append assms)
qed

lemma valuate_eta_hat: "SST.hat2 tr td (q, valuate (\<theta> x)) = concatU (valuate (H tr td (\<lambda>(q, x). q, \<theta>) (q, x)))"
  by (simp add: valuate_list_valuation[of "\<theta> x"] valuation_eta_hat valuate_concatU_update_valuation)

lemma reachable_then_exist_valuation:
  fixes sst1 :: "('q1, 'x1, 'a, 'b) SST"
  fixes sst2 :: "('q2, 'x2, 'b, 'c) SST"
  assumes "reachable (compose_SST_SST sst1 sst2) (q1, f)"
  shows "\<exists>\<mu>. \<forall>q2 x. delta_hat sst2 (q2, \<mu> x) = f (q2, x)"
proof -
  obtain w where w: "(q1, f) = delta_hat (compose_SST_SST sst1 sst2) (initial (compose_SST_SST sst1 sst2), w)"
    using assms by (auto simp add: reachable_def)
  then show ?thesis proof (induct w arbitrary: q1 f rule: rev_induct)
    case Nil
    show ?case proof (rule exI, intro allI)
      fix q2 x
      let ?mu = "\<lambda>x1. []"
      show "delta_hat sst2 (q2, ?mu x) = f (q2, x)"
        using Nil unfolding compose_SST_SST_def by simp
    qed
  next
    case (snoc a w)
    show ?case proof -
      let ?q1f' = "delta_hat (compose_SST_SST sst1 sst2) (initial (compose_SST_SST sst1 sst2), w)"
      let ?q1' = "fst ?q1f'"
      let ?f' = "snd ?q1f'"
      have "(?q1', ?f') = delta_hat (compose_SST_SST sst1 sst2) (initial (compose_SST_SST sst1 sst2), w)" by simp
      then have "\<exists>\<mu>. \<forall>q2 x. delta_hat sst2 (q2, \<mu> x) = ?f' (q2, x)" by (rule snoc(1))
      then obtain \<mu>' where mu: "\<forall>q2 x. delta_hat sst2 (q2, \<mu>' x) = ?f' (q2, x)" by auto
      let ?mu = "\<lambda>x1. list_valuation \<mu>' (SST.eta sst1 (?q1', a) x1)"
      have body: "\<forall>q2 x1. delta_hat sst2 (q2, ?mu x1) = f (q2, x1)"
        using snoc(2)
        apply (simp add: valuation_delta_hat[OF mu] compose_SST_SST_def compose_\<delta>_hat)
        apply (simp add: compose_\<delta>_def)
        done
      show ?thesis by (rule exI, rule body)
    qed
  qed
qed

subsection \<open>Main result\<close>

theorem can_compose_SST_SST:
  fixes sst1 :: "('q1, 'x1, 'a, 'b) SST"
  fixes sst2 :: "('q2, 'x2, 'b, 'c) SST"
  shows "Monoid_SST.run (compose_SST_SST sst1 sst2) w
       = Option.bind (SST.run sst1 w) (SST.run sst2)"
proof (cases "SST.final sst1 (delta_hat sst1 (initial sst1, w))")
  case None then show ?thesis
    by (simp add: compose_SST_SST_def SST.run_def Monoid_SST.run_def compose_final_update_def compose_\<delta>_hat)
next
  case Some_1: (Some output_final1)
  let ?output_of_1st_sst =
    "valuate ((SST.eta_hat sst1 (initial sst1, w) \<bullet> (\<lambda>x. output_final1)) ())"
  show ?thesis
  proof (cases "SST.final sst2 (delta_hat sst2 (initial sst2, ?output_of_1st_sst))")
    case None then show ?thesis
      by (simp add: SST.run_def Monoid_SST.run_def Transducer.run_def Some_1
          compose_SST_SST_def compose_\<delta>_hat compose_final_update_def compose_final_string_def valuate_delta_hat \<Delta>_assoc)
  next
    case Some_2: (Some output_final2) then show ?thesis
      by (simp add: SST.run_def Monoid_SST.run_def compose_SST_SST_def
               compose_final_update_def compose_final_string_def Transducer.run_def
               compose_\<delta>_hat compose_\<eta>_hat Some_2
                       \<Delta>_assoc valuate_delta_hat
                       compU_ignore
                       valuate_eta_hat
                       H_assoc
                       Some_1)
  qed
qed

subsection \<open>Examples\<close>

lemma "Monoid_SST.run (compose_SST_SST rev rev) [1, 2, 3] = Some [1, 2, 3]"
  apply (simp add: compose_SST_SST_def compose_\<delta>_def compose_\<eta>_def compose_final_update_def compose_final_string_def
        Monoid_SST.run_def SST.run_def rev_def compU_apply hat_hom_def update2hom_def fold_sum_def idU_def emptyU_def)
  apply (simp add: \<Delta>_def H_def idU_def emptyU_def compU_apply)
  done

end


(*  Title:      HOL/HOLCF/Domain_Aux.thy
    Author:     Brian Huffman
*)

section {* Domain package support *}

theory Domain_Aux
imports Map_Functions Fixrec
begin

subsection {* Continuous isomorphisms *}

text {* A locale for continuous isomorphisms *}

locale iso =
  fixes abs :: "'a \<rightarrow> 'b"
  fixes rep :: "'b \<rightarrow> 'a"
  assumes abs_iso [simp]: "rep\<cdot>(abs\<cdot>x) = x"
  assumes rep_iso [simp]: "abs\<cdot>(rep\<cdot>y) = y"
begin

lemma swap: "iso rep abs"
  by (rule iso.intro [OF rep_iso abs_iso])

lemma abs_below: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
proof
  assume "abs\<cdot>x \<sqsubseteq> abs\<cdot>y"
  then have "rep\<cdot>(abs\<cdot>x) \<sqsubseteq> rep\<cdot>(abs\<cdot>y)" by (rule monofun_cfun_arg)
  then show "x \<sqsubseteq> y" by simp
next
  assume "x \<sqsubseteq> y"
  then show "abs\<cdot>x \<sqsubseteq> abs\<cdot>y" by (rule monofun_cfun_arg)
qed

lemma rep_below: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
  by (rule iso.abs_below [OF swap])

lemma abs_eq: "(abs\<cdot>x = abs\<cdot>y) = (x = y)"
  by (simp add: po_eq_conv abs_below)

lemma rep_eq: "(rep\<cdot>x = rep\<cdot>y) = (x = y)"
  by (rule iso.abs_eq [OF swap])

lemma abs_strict: "abs\<cdot>\<bottom> = \<bottom>"
proof -
  have "\<bottom> \<sqsubseteq> rep\<cdot>\<bottom>" ..
  then have "abs\<cdot>\<bottom> \<sqsubseteq> abs\<cdot>(rep\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
  then have "abs\<cdot>\<bottom> \<sqsubseteq> \<bottom>" by simp
  then show ?thesis by (rule bottomI)
qed

lemma rep_strict: "rep\<cdot>\<bottom> = \<bottom>"
  by (rule iso.abs_strict [OF swap])

lemma abs_defin': "abs\<cdot>x = \<bottom> \<Longrightarrow> x = \<bottom>"
proof -
  have "x = rep\<cdot>(abs\<cdot>x)" by simp
  also assume "abs\<cdot>x = \<bottom>"
  also note rep_strict
  finally show "x = \<bottom>" .
qed

lemma rep_defin': "rep\<cdot>z = \<bottom> \<Longrightarrow> z = \<bottom>"
  by (rule iso.abs_defin' [OF swap])

lemma abs_defined: "z \<noteq> \<bottom> \<Longrightarrow> abs\<cdot>z \<noteq> \<bottom>"
  by (erule contrapos_nn, erule abs_defin')

lemma rep_defined: "z \<noteq> \<bottom> \<Longrightarrow> rep\<cdot>z \<noteq> \<bottom>"
  by (rule iso.abs_defined [OF iso.swap]) (rule iso_axioms)

lemma abs_bottom_iff: "(abs\<cdot>x = \<bottom>) = (x = \<bottom>)"
  by (auto elim: abs_defin' intro: abs_strict)

lemma rep_bottom_iff: "(rep\<cdot>x = \<bottom>) = (x = \<bottom>)"
  by (rule iso.abs_bottom_iff [OF iso.swap]) (rule iso_axioms)

lemma casedist_rule: "rep\<cdot>x = \<bottom> \<or> P \<Longrightarrow> x = \<bottom> \<or> P"
  by (simp add: rep_bottom_iff)

lemma compact_abs_rev: "compact (abs\<cdot>x) \<Longrightarrow> compact x"
proof (unfold compact_def)
  assume "adm (\<lambda>y. abs\<cdot>x \<notsqsubseteq> y)"
  with cont_Rep_cfun2
  have "adm (\<lambda>y. abs\<cdot>x \<notsqsubseteq> abs\<cdot>y)" by (rule adm_subst)
  then show "adm (\<lambda>y. x \<notsqsubseteq> y)" using abs_below by simp
qed

lemma compact_rep_rev: "compact (rep\<cdot>x) \<Longrightarrow> compact x"
  by (rule iso.compact_abs_rev [OF iso.swap]) (rule iso_axioms)

lemma compact_abs: "compact x \<Longrightarrow> compact (abs\<cdot>x)"
  by (rule compact_rep_rev) simp

lemma compact_rep: "compact x \<Longrightarrow> compact (rep\<cdot>x)"
  by (rule iso.compact_abs [OF iso.swap]) (rule iso_axioms)

lemma iso_swap: "(x = abs\<cdot>y) = (rep\<cdot>x = y)"
proof
  assume "x = abs\<cdot>y"
  then have "rep\<cdot>x = rep\<cdot>(abs\<cdot>y)" by simp
  then show "rep\<cdot>x = y" by simp
next
  assume "rep\<cdot>x = y"
  then have "abs\<cdot>(rep\<cdot>x) = abs\<cdot>y" by simp
  then show "x = abs\<cdot>y" by simp
qed

end

subsection {* Proofs about take functions *}

text {*
  This section contains lemmas that are used in a module that supports
  the domain isomorphism package; the module contains proofs related
  to take functions and the finiteness predicate.
*}

lemma deflation_abs_rep:
  fixes abs and rep and d
  assumes abs_iso: "\<And>x. rep\<cdot>(abs\<cdot>x) = x"
  assumes rep_iso: "\<And>y. abs\<cdot>(rep\<cdot>y) = y"
  shows "deflation d \<Longrightarrow> deflation (abs oo d oo rep)"
by (rule ep_pair.deflation_e_d_p) (simp add: ep_pair.intro assms)

lemma deflation_chain_min:
  assumes chain: "chain d"
  assumes defl: "\<And>n. deflation (d n)"
  shows "d m\<cdot>(d n\<cdot>x) = d (min m n)\<cdot>x"
proof (rule linorder_le_cases)
  assume "m \<le> n"
  with chain have "d m \<sqsubseteq> d n" by (rule chain_mono)
  then have "d m\<cdot>(d n\<cdot>x) = d m\<cdot>x"
    by (rule deflation_below_comp1 [OF defl defl])
  moreover from `m \<le> n` have "min m n = m" by simp
  ultimately show ?thesis by simp
next
  assume "n \<le> m"
  with chain have "d n \<sqsubseteq> d m" by (rule chain_mono)
  then have "d m\<cdot>(d n\<cdot>x) = d n\<cdot>x"
    by (rule deflation_below_comp2 [OF defl defl])
  moreover from `n \<le> m` have "min m n = n" by simp
  ultimately show ?thesis by simp
qed

lemma lub_ID_take_lemma:
  assumes "chain t" and "(\<Squnion>n. t n) = ID"
  assumes "\<And>n. t n\<cdot>x = t n\<cdot>y" shows "x = y"
proof -
  have "(\<Squnion>n. t n\<cdot>x) = (\<Squnion>n. t n\<cdot>y)"
    using assms(3) by simp
  then have "(\<Squnion>n. t n)\<cdot>x = (\<Squnion>n. t n)\<cdot>y"
    using assms(1) by (simp add: lub_distribs)
  then show "x = y"
    using assms(2) by simp
qed

lemma lub_ID_reach:
  assumes "chain t" and "(\<Squnion>n. t n) = ID"
  shows "(\<Squnion>n. t n\<cdot>x) = x"
using assms by (simp add: lub_distribs)

lemma lub_ID_take_induct:
  assumes "chain t" and "(\<Squnion>n. t n) = ID"
  assumes "adm P" and "\<And>n. P (t n\<cdot>x)" shows "P x"
proof -
  from `chain t` have "chain (\<lambda>n. t n\<cdot>x)" by simp
  from `adm P` this `\<And>n. P (t n\<cdot>x)` have "P (\<Squnion>n. t n\<cdot>x)" by (rule admD)
  with `chain t` `(\<Squnion>n. t n) = ID` show "P x" by (simp add: lub_distribs)
qed

subsection {* Finiteness *}

text {*
  Let a ``decisive'' function be a deflation that maps every input to
  either itself or bottom.  Then if a domain's take functions are all
  decisive, then all values in the domain are finite.
*}

definition
  decisive :: "('a::pcpo \<rightarrow> 'a) \<Rightarrow> bool"
where
  "decisive d \<longleftrightarrow> (\<forall>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>)"

lemma decisiveI: "(\<And>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>) \<Longrightarrow> decisive d"
  unfolding decisive_def by simp

lemma decisive_cases:
  assumes "decisive d" obtains "d\<cdot>x = x" | "d\<cdot>x = \<bottom>"
using assms unfolding decisive_def by auto

lemma decisive_bottom: "decisive \<bottom>"
  unfolding decisive_def by simp

lemma decisive_ID: "decisive ID"
  unfolding decisive_def by simp

lemma decisive_ssum_map:
  assumes f: "decisive f"
  assumes g: "decisive g"
  shows "decisive (ssum_map\<cdot>f\<cdot>g)"
apply (rule decisiveI, rename_tac s)
apply (case_tac s, simp_all)
apply (rule_tac x=x in decisive_cases [OF f], simp_all)
apply (rule_tac x=y in decisive_cases [OF g], simp_all)
done

lemma decisive_sprod_map:
  assumes f: "decisive f"
  assumes g: "decisive g"
  shows "decisive (sprod_map\<cdot>f\<cdot>g)"
apply (rule decisiveI, rename_tac s)
apply (case_tac s, simp_all)
apply (rule_tac x=x in decisive_cases [OF f], simp_all)
apply (rule_tac x=y in decisive_cases [OF g], simp_all)
done

lemma decisive_abs_rep:
  fixes abs rep
  assumes iso: "iso abs rep"
  assumes d: "decisive d"
  shows "decisive (abs oo d oo rep)"
apply (rule decisiveI)
apply (rule_tac x="rep\<cdot>x" in decisive_cases [OF d])
apply (simp add: iso.rep_iso [OF iso])
apply (simp add: iso.abs_strict [OF iso])
done

lemma lub_ID_finite:
  assumes chain: "chain d"
  assumes lub: "(\<Squnion>n. d n) = ID"
  assumes decisive: "\<And>n. decisive (d n)"
  shows "\<exists>n. d n\<cdot>x = x"
proof -
  have 1: "chain (\<lambda>n. d n\<cdot>x)" using chain by simp
  have 2: "(\<Squnion>n. d n\<cdot>x) = x" using chain lub by (rule lub_ID_reach)
  have "\<forall>n. d n\<cdot>x = x \<or> d n\<cdot>x = \<bottom>"
    using decisive unfolding decisive_def by simp
  hence "range (\<lambda>n. d n\<cdot>x) \<subseteq> {x, \<bottom>}"
    by auto
  hence "finite (range (\<lambda>n. d n\<cdot>x))"
    by (rule finite_subset, simp)
  with 1 have "finite_chain (\<lambda>n. d n\<cdot>x)"
    by (rule finite_range_imp_finch)
  then have "\<exists>n. (\<Squnion>n. d n\<cdot>x) = d n\<cdot>x"
    unfolding finite_chain_def by (auto simp add: maxinch_is_thelub)
  with 2 show "\<exists>n. d n\<cdot>x = x" by (auto elim: sym)
qed

lemma lub_ID_finite_take_induct:
  assumes "chain d" and "(\<Squnion>n. d n) = ID" and "\<And>n. decisive (d n)"
  shows "(\<And>n. P (d n\<cdot>x)) \<Longrightarrow> P x"
using lub_ID_finite [OF assms] by metis

subsection {* Proofs about constructor functions *}

text {* Lemmas for proving nchotomy rule: *}

lemma ex_one_bottom_iff:
  "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = P ONE"
by simp

lemma ex_up_bottom_iff:
  "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = (\<exists>x. P (up\<cdot>x))"
by (safe, case_tac x, auto)

lemma ex_sprod_bottom_iff:
 "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
  (\<exists>x y. (P (:x, y:) \<and> x \<noteq> \<bottom>) \<and> y \<noteq> \<bottom>)"
by (safe, case_tac y, auto)

lemma ex_sprod_up_bottom_iff:
 "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
  (\<exists>x y. P (:up\<cdot>x, y:) \<and> y \<noteq> \<bottom>)"
by (safe, case_tac y, simp, case_tac x, auto)

lemma ex_ssum_bottom_iff:
 "(\<exists>x. P x \<and> x \<noteq> \<bottom>) =
 ((\<exists>x. P (sinl\<cdot>x) \<and> x \<noteq> \<bottom>) \<or>
  (\<exists>x. P (sinr\<cdot>x) \<and> x \<noteq> \<bottom>))"
by (safe, case_tac x, auto)

lemma exh_start: "p = \<bottom> \<or> (\<exists>x. p = x \<and> x \<noteq> \<bottom>)"
  by auto

lemmas ex_bottom_iffs =
   ex_ssum_bottom_iff
   ex_sprod_up_bottom_iff
   ex_sprod_bottom_iff
   ex_up_bottom_iff
   ex_one_bottom_iff

text {* Rules for turning nchotomy into exhaust: *}

lemma exh_casedist0: "\<lbrakk>R; R \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P" (* like make_elim *)
  by auto

lemma exh_casedist1: "((P \<or> Q \<Longrightarrow> R) \<Longrightarrow> S) \<equiv> (\<lbrakk>P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> S)"
  by rule auto

lemma exh_casedist2: "(\<exists>x. P x \<Longrightarrow> Q) \<equiv> (\<And>x. P x \<Longrightarrow> Q)"
  by rule auto

lemma exh_casedist3: "(P \<and> Q \<Longrightarrow> R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> R)"
  by rule auto

lemmas exh_casedists = exh_casedist1 exh_casedist2 exh_casedist3

text {* Rules for proving constructor properties *}

lemmas con_strict_rules =
  sinl_strict sinr_strict spair_strict1 spair_strict2

lemmas con_bottom_iff_rules =
  sinl_bottom_iff sinr_bottom_iff spair_bottom_iff up_defined ONE_defined

lemmas con_below_iff_rules =
  sinl_below sinr_below sinl_below_sinr sinr_below_sinl con_bottom_iff_rules

lemmas con_eq_iff_rules =
  sinl_eq sinr_eq sinl_eq_sinr sinr_eq_sinl con_bottom_iff_rules

lemmas sel_strict_rules =
  cfcomp2 sscase1 sfst_strict ssnd_strict fup1

lemma sel_app_extra_rules:
  "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinr\<cdot>x) = \<bottom>"
  "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinl\<cdot>x) = x"
  "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinl\<cdot>x) = \<bottom>"
  "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinr\<cdot>x) = x"
  "fup\<cdot>ID\<cdot>(up\<cdot>x) = x"
by (cases "x = \<bottom>", simp, simp)+

lemmas sel_app_rules =
  sel_strict_rules sel_app_extra_rules
  ssnd_spair sfst_spair up_defined spair_defined

lemmas sel_bottom_iff_rules =
  cfcomp2 sfst_bottom_iff ssnd_bottom_iff

lemmas take_con_rules =
  ssum_map_sinl' ssum_map_sinr' sprod_map_spair' u_map_up
  deflation_strict deflation_ID ID1 cfcomp2

subsection {* ML setup *}

named_theorems domain_deflation "theorems like deflation a ==> deflation (foo_map$a)"
  and domain_map_ID "theorems like foo_map$ID = ID"

ML_file "Tools/Domain/domain_take_proofs.ML"
ML_file "Tools/cont_consts.ML"
ML_file "Tools/cont_proc.ML"
ML_file "Tools/Domain/domain_constructors.ML"
ML_file "Tools/Domain/domain_induction.ML"

end


theory StutterEquivalence
imports Samplers

begin

section {* Stuttering Equivalence *}

text {*
  Stuttering equivalence of two sequences is formally defined as the equality
  of their maximally reduced versions.
*}

definition stutter_equiv  (infix "\<approx>" 50) where
  "\<sigma> \<approx> \<tau> \<equiv> \<natural>\<sigma> = \<natural>\<tau>"

text {*
  Stuttering equivalence is an equivalence relation.
*}

lemma stutter_equiv_refl: "\<sigma> \<approx> \<sigma>"
  unfolding stutter_equiv_def ..

lemma stutter_equiv_sym [sym]: "\<sigma> \<approx> \<tau> \<Longrightarrow> \<tau> \<approx> \<sigma>"
  unfolding stutter_equiv_def by (rule sym)

lemma stutter_equiv_trans [trans]: "\<rho> \<approx> \<sigma> \<Longrightarrow> \<sigma> \<approx> \<tau> \<Longrightarrow> \<rho> \<approx> \<tau>"
  unfolding stutter_equiv_def by simp

text {*
  In particular, any sequence sampled by a stuttering sampler
  is stuttering equivalent to the original one.
*}
lemma sampled_stutter_equiv:
  assumes "stutter_sampler f \<sigma>"
  shows "\<sigma> \<circ> f \<approx> \<sigma>"
  using assms unfolding stutter_equiv_def by (rule sample_max_sample)

lemma stutter_reduced_equivalent: "\<natural>\<sigma> \<approx> \<sigma>"
  unfolding stutter_equiv_def by (rule stutter_reduced_reduced)

text {*
  For proving stuttering equivalence of two sequences, it is enough
  to exhibit two arbitrary sampling functions that equalize the reductions
  of the sequences. This can be more convenient than computing the
  maximal stutter-reduced version of the sequences.
*}

lemma stutter_equivI:
  assumes f: "stutter_sampler f \<sigma>" and g: "stutter_sampler g \<tau>"
      and eq: "\<sigma> \<circ> f = \<tau> \<circ> g"
  shows "\<sigma> \<approx> \<tau>"
proof -
  from f have "\<natural>\<sigma> = \<natural>(\<sigma> \<circ> f)" by (rule sample_max_sample[THEN sym])
  also from eq have "... = \<natural>(\<tau> \<circ> g)" by simp
  also from g have "... = \<natural>\<tau>" by (rule sample_max_sample)
  finally show ?thesis by (unfold stutter_equiv_def)
qed

text {*
  The corresponding elimination rule is easy to prove, given that the
  maximal stuttering sampling function is a stuttering sampling function.
*}

lemma stutter_equivE:
  assumes eq: "\<sigma> \<approx> \<tau>"
  and p: "\<And>f g. \<lbrakk> stutter_sampler f \<sigma>; stutter_sampler g \<tau>; \<sigma> \<circ> f = \<tau> \<circ> g \<rbrakk> \<Longrightarrow> P"
  shows "P"
proof (rule p)
  from eq show "\<sigma> \<circ> (max_stutter_sampler \<sigma>) = \<tau> \<circ> (max_stutter_sampler \<tau>)"
    by (unfold stutter_equiv_def stutter_reduced_def)
qed (rule max_stutter_sampler)+

text {*
  Therefore we get the following alternative characterization: two
  sequences are stuttering equivalent iff there are stuttering sampling
  functions that equalize the two sequences.
*}
lemma stutter_equiv_eq:
  "\<sigma> \<approx> \<tau> = (\<exists>f g. stutter_sampler f \<sigma> \<and> stutter_sampler g \<tau> \<and> \<sigma> \<circ> f = \<tau> \<circ> g)"
  by (blast intro: stutter_equivI elim: stutter_equivE)

text {*
  The initial elements of stutter equivalent sequences are equal.
*}
lemma stutter_equiv_0:
  assumes "\<sigma> \<approx> \<tau>"
  shows "\<sigma> 0 = \<tau> 0"
proof -
  have "\<sigma> 0 = (\<natural>\<sigma>) 0" by (rule stutter_reduced_0[THEN sym])
  with assms[unfolded stutter_equiv_def] show ?thesis
    by (simp add: stutter_reduced_0)
qed

text {*
  Given any stuttering sampling function @{text f} for sequence @{text "\<sigma>"},
  any suffix of @{text "\<sigma>"} starting at index @{text "f n"} is stuttering
  equivalent to the suffix of the stutter-reduced version of @{text "\<sigma>"}
  starting at @{text "n"}.
*}

text {*
  Given a stuttering sampling function @{text f} and a point @{text "n"}
  within the interval from @{text "f k"} to @{text "f (k+1)"}, the suffix
  starting at @{text n} is stuttering equivalent to the suffix starting
  at @{text "f k"}.
*}
lemma stutter_equiv_within_interval:
  assumes f: "stutter_sampler f \<sigma>"
      and lo: "f k \<le> n" and hi: "n < f (Suc k)"
  shows "\<sigma>[n ..] \<approx> \<sigma>[f k ..]"
proof -
  have "stutter_sampler id (\<sigma>[n ..])" by (rule id_stutter_sampler)
  moreover
  from lo have "stutter_sampler (\<lambda>i. if i=0 then 0 else n + i - f k) (\<sigma>[f k ..])"
    (is "stutter_sampler ?f _")
  proof (auto simp: stutter_sampler_def strict_mono_def)
    fix i
    assume i: "i < Suc n - f k"
    from f show "\<sigma> (f k + i) = \<sigma> (f k)"
    proof (rule stutter_sampler_between)
      from i hi show "f k + i < f (Suc k)" by simp
    qed simp
  qed
  moreover
  have "(\<sigma>[n ..]) \<circ> id = (\<sigma>[f k ..]) \<circ> ?f"
  proof (rule ext, auto)
    from f lo hi show "\<sigma> n = \<sigma> (f k)" by (rule stutter_sampler_between)
  next
    fix i
    from lo show "\<sigma> (n+i) = \<sigma> (f k + (n + i - f k))" by simp
  qed
  ultimately show ?thesis by (rule stutter_equivI)
qed

text {*
  Given two stuttering equivalent sequences @{text "\<sigma>"} and @{text "\<tau>"},
  we obtain a zig-zag relationship as follows: for any suffix @{text "\<tau>[n..]"}
  there is a suffix @{text "\<sigma>[m..]"} such that:
  \begin{enumerate}
  \item @{text "\<sigma>[m..] \<approx> \<tau>[n..]"} and
  \item for every suffix @{text "\<sigma>[j..]"} where @{text "j<m"} there is a
    corresponding suffix @{text "\<tau>[k..]"} for some @{text "k<n"}.
  \end{enumerate}
*}
theorem stutter_equiv_suffixes_left:
  assumes "\<sigma> \<approx> \<tau>"
  obtains m where "\<sigma>[m..] \<approx> \<tau>[n..]" and "\<forall>j<m. \<exists>k<n. \<sigma>[j..] \<approx> \<tau>[k..]"
using assms proof (rule stutter_equivE)
  fix f g
  assume f: "stutter_sampler f \<sigma>"
     and g: "stutter_sampler g \<tau>"
     and eq: "\<sigma> \<circ> f = \<tau> \<circ> g"
  from g obtain i where i: "g i \<le> n" "n < g (Suc i)"
    by (rule stutter_sampler_interval)
  with g have "\<tau>[n..] \<approx> \<tau>[g i ..]"
    by (rule stutter_equiv_within_interval)
  also from g have "... \<approx> (\<tau> \<circ> g)[i ..]"
    by (rule suffix_stutter_equiv)
  also from eq have "... = (\<sigma> \<circ> f)[i ..]"
    by simp
  also from f have "... \<approx> \<sigma>[f i ..]"
    by (rule suffix_stutter_equiv[THEN stutter_equiv_sym])
  finally have "\<sigma>[f i ..] \<approx> \<tau>[n ..]"
    by (rule stutter_equiv_sym)
  moreover
  {
    fix j
    assume j: "j < f i"
    from f obtain a where a: "f a \<le> j" "j < f (Suc a)"
      by (rule stutter_sampler_interval)
    from a j have "f a < f i" by simp
    with f[THEN stutter_sampler_mono] have "a < i"
      by (simp add: strict_mono_less)
    with g[THEN stutter_sampler_mono] have "g a < g i"
      by (simp add: strict_mono_less)
    with i have 1: "g a < n" by simp

    from f a have "\<sigma>[j..] \<approx> \<sigma>[f a ..]"
      by (rule stutter_equiv_within_interval)
    also from f have "... \<approx> (\<sigma> \<circ> f)[a ..]"
      by (rule suffix_stutter_equiv)
    also from eq have "... = (\<tau> \<circ> g)[a ..]" by simp
    also from g have "... \<approx> \<tau>[g a ..]"
      by (rule suffix_stutter_equiv[THEN stutter_equiv_sym])
    finally have "\<sigma>[j ..] \<approx> \<tau>[g a ..]" .
    with 1 have "\<exists>k<n. \<sigma>[j..] \<approx> \<tau>[k ..]" by blast
  }
  moreover
  note that
  ultimately show ?thesis by blast
qed

theorem stutter_equiv_suffixes_right:
  assumes "\<sigma> \<approx> \<tau>"
  obtains n where "\<sigma>[m..] \<approx> \<tau>[n..]" and "\<forall>j<n. \<exists>k<m. \<sigma>[k..] \<approx> \<tau>[j..]"
proof -
  from assms have "\<tau> \<approx> \<sigma>"
    by (rule stutter_equiv_sym)
  then obtain n where "\<tau>[n..] \<approx> \<sigma>[m..]" "\<forall>j<n. \<exists>k<m. \<tau>[j..] \<approx> \<sigma>[k..]"
    by (rule stutter_equiv_suffixes_left)
  with that show ?thesis
    by (blast dest: stutter_equiv_sym)
qed

text {*
  In particular, if @{text "\<sigma>"} and @{text "\<tau>"} are stutter equivalent then
  every element that occurs in one sequence also occurs in the other.
*}
lemma stutter_equiv_element_left:
  assumes "\<sigma> \<approx> \<tau>"
  obtains m where "\<sigma> m = \<tau> n" and "\<forall>j<m. \<exists>k<n. \<sigma> j = \<tau> k"
proof -
  from assms obtain m where "\<sigma>[m..] \<approx> \<tau>[n..]" "\<forall>j<m. \<exists>k<n. \<sigma>[j..] \<approx> \<tau>[k..]"
    by (rule stutter_equiv_suffixes_left)
  with that show ?thesis
    by (force dest: stutter_equiv_0)
qed

lemma stutter_equiv_element_right:
  assumes "\<sigma> \<approx> \<tau>"
  obtains n where "\<sigma> m = \<tau> n" and "\<forall>j<n. \<exists>k<m. \<sigma> k = \<tau> j"
proof -
  from assms obtain n where "\<sigma>[m..] \<approx> \<tau>[n..]" "\<forall>j<n. \<exists>k<m. \<sigma>[k..] \<approx> \<tau>[j..]"
    by (rule stutter_equiv_suffixes_right)
  with that show ?thesis
    by (force dest: stutter_equiv_0)
qed

end (* theory StutterEquivalence *)


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

section "Structured Reasoning"

theory StructuredReasoning imports Algebra begin

text \<open>By linking the algebraic, the syntactic, and the semantic views
  of computation, we derive a set of rules for decomposing expectation
  entailment proofs, firstly over the syntactic structure of a program,
  and secondly over the refinement relation.  These rules also form the
  basis for automated reasoning.\<close>

subsection \<open>Syntactic Decomposition\<close>

lemma wp_Abort:
  "(\<lambda>s. 0) \<tturnstile> wp Abort Q"
  unfolding wp_eval by(simp)

lemma wlp_Abort:
  "(\<lambda>s. 1) \<tturnstile> wlp Abort Q"
  unfolding wp_eval by(simp)

lemma wp_Skip:
  "P \<tturnstile> wp Skip P"
  unfolding wp_eval by(blast)

lemma wlp_Skip:
  "P \<tturnstile> wlp Skip P"
  unfolding wp_eval by(blast)

lemma wp_Apply:
  "Q o f \<tturnstile> wp (Apply f) Q"
  unfolding wp_eval by(simp)

lemma wlp_Apply:
  "Q o f \<tturnstile> wlp (Apply f) Q"
  unfolding wp_eval by(simp)

lemma wp_Seq:
  assumes ent_a: "P \<tturnstile> wp a Q"
      and ent_b: "Q \<tturnstile> wp b R"
      and wa:   "well_def a"
      and wb:   "well_def b"
      and s_Q:   "sound Q"
      and s_R:   "sound R"
  shows "P \<tturnstile> wp (a ;; b) R"
proof -
  note ha = well_def_wp_healthy[OF wa]
  note hb = well_def_wp_healthy[OF wb]
  note ent_a
  also from ent_b ha hb s_Q s_R have "wp a Q \<tturnstile> wp a (wp b R)"
    by(blast intro:healthy_monoD2)
  finally show ?thesis by(simp add:wp_eval)
qed

lemma wp_PC:
  "(\<lambda>s. P s * wp a Q s + (1 - P s) * wp b Q s) \<tturnstile> wp (a \<^bsub>P\<^esub>\<oplus> b) Q"
  by(simp add:wp_eval)

lemma wlp_PC:
  "(\<lambda>s. P s * wlp a Q s + (1 - P s) * wlp b Q s) \<tturnstile> wlp (a \<^bsub>P\<^esub>\<oplus> b) Q"
  by(simp add:wp_eval)

text \<open>A simpler rule for when the probability does not depend on the state.\<close>
lemma PC_fixed:
  assumes wpa: "P \<tturnstile> a ab R"
      and wpb: "Q \<tturnstile> b ab R"
      and np: "0 \<le> p" and bp: "p \<le> 1"
  shows "(\<lambda>s. p * P s + (1 - p) * Q s) \<tturnstile> (a \<^bsub>(\<lambda>s. p)\<^esub>\<oplus> b) ab R"
  unfolding PC_def
proof(rule le_funI)
  fix s
  from wpa and np have "p * P s \<le> p * a ab R s"
    by(auto intro:mult_left_mono)
  moreover {
    from bp have "0 \<le> 1 - p" by(simp)
    with wpb have "(1 - p) * Q s \<le> (1 - p) * b ab R s"
      by(auto intro:mult_left_mono)
  }
  ultimately show "p * P s + (1 - p) * Q s \<le>
                   p * a ab R s + (1 - p) * b ab R s"
    by(rule add_mono)
qed

lemma wp_PC_fixed:
  "\<lbrakk> P \<tturnstile> wp a R; Q \<tturnstile> wp b R; 0 \<le> p; p \<le> 1 \<rbrakk> \<Longrightarrow>
  (\<lambda>s. p * P s + (1 - p) * Q s) \<tturnstile> wp (a \<^bsub>(\<lambda>s. p)\<^esub>\<oplus> b) R"
  by(simp add:wp_def PC_fixed)

lemma wlp_PC_fixed:
  "\<lbrakk> P \<tturnstile> wlp a R; Q \<tturnstile> wlp b R; 0 \<le> p; p \<le> 1 \<rbrakk> \<Longrightarrow>
  (\<lambda>s. p * P s + (1 - p) * Q s) \<tturnstile> wlp (a \<^bsub>(\<lambda>s. p)\<^esub>\<oplus> b) R"
  by(simp add:wlp_def PC_fixed)

lemma wp_DC:
  "(\<lambda>s. min (wp a Q s) (wp b Q s)) \<tturnstile> wp (a \<Sqinter> b) Q"
  unfolding wp_eval by(simp)

lemma wlp_DC:
  "(\<lambda>s. min (wlp a Q s) (wlp b Q s)) \<tturnstile> wlp (a \<Sqinter> b) Q"
  unfolding wp_eval by(simp)

text \<open>Combining annotations for both branches:\<close>
lemma DC_split:
  fixes a::"'s prog" and b
  assumes wpa: "P \<tturnstile> a ab R"
      and wpb: "Q \<tturnstile> b ab R"
  shows "(\<lambda>s. min (P s) (Q s)) \<tturnstile> (a \<Sqinter> b) ab R"
  unfolding DC_def
proof(rule le_funI)
  fix s
  from wpa wpb
  have "P s \<le> a ab R s" and "Q s \<le> b ab R s" by(auto)
  thus "min (P s) (Q s) \<le> min (a ab R s) (b ab R s)" by(auto)
qed

lemma wp_DC_split:
  "\<lbrakk> P \<tturnstile> wp prog R; Q \<tturnstile> wp prog' R \<rbrakk> \<Longrightarrow>
  (\<lambda>s. min (P s) (Q s)) \<tturnstile> wp (prog \<Sqinter> prog') R"
  by(simp add:wp_def DC_split)

lemma wlp_DC_split:
  "\<lbrakk> P \<tturnstile> wlp prog R; Q \<tturnstile> wlp prog' R \<rbrakk> \<Longrightarrow>
  (\<lambda>s. min (P s) (Q s)) \<tturnstile> wlp (prog \<Sqinter> prog') R"
  by(simp add:wlp_def DC_split)

lemma wp_DC_split_same:
  "\<lbrakk> P \<tturnstile> wp prog Q; P \<tturnstile> wp prog' Q \<rbrakk> \<Longrightarrow> P \<tturnstile> wp (prog \<Sqinter> prog') Q"
  unfolding wp_eval by(blast intro:min.boundedI)

lemma wlp_DC_split_same:
  "\<lbrakk> P \<tturnstile> wlp prog Q; P \<tturnstile> wlp prog' Q \<rbrakk> \<Longrightarrow> P \<tturnstile> wlp (prog \<Sqinter> prog') Q"
  unfolding wp_eval by(blast intro:min.boundedI)

lemma SetPC_split:
  fixes f::"'x \<Rightarrow> 'y prog"
    and p::"'y \<Rightarrow> 'x \<Rightarrow> real"
  assumes rec: "\<And>x s. x \<in> supp (p s) \<Longrightarrow> P x \<tturnstile> f x ab Q"
      and nnp: "\<And>s. nneg (p s)"
  shows "(\<lambda>s. \<Sum>x \<in> supp (p s). p s x * P x s) \<tturnstile> SetPC f p ab Q"
  unfolding SetPC_def
proof(rule le_funI)
  fix s
  from rec have "\<And>x. x \<in> supp (p s) \<Longrightarrow> P x s \<le> f x ab Q s" by(blast)
  moreover from nnp have "\<And>x. 0 \<le> p s x" by(blast)
  ultimately have "\<And>x. x \<in> supp (p s) \<Longrightarrow> p s x * P x s \<le> p s x * f x ab Q s"
    by(blast intro:mult_left_mono)
  thus "(\<Sum>x \<in> supp (p s). p s x * P x s) \<le> (\<Sum>x \<in> supp (p s). p s x * f x ab Q s)"
    by(rule sum_mono)
qed

lemma wp_SetPC_split:
  "\<lbrakk> \<And>x s. x \<in> supp (p s) \<Longrightarrow> P x \<tturnstile> wp (f x) Q; \<And>s. nneg (p s) \<rbrakk> \<Longrightarrow>
   (\<lambda>s. \<Sum>x \<in> supp (p s). p s x * P x s) \<tturnstile> wp (SetPC f p) Q"
  by(simp add:wp_def SetPC_split)

lemma wlp_SetPC_split:
  "\<lbrakk> \<And>x s. x \<in> supp (p s) \<Longrightarrow> P x \<tturnstile> wlp (f x) Q; \<And>s. nneg (p s) \<rbrakk> \<Longrightarrow>
   (\<lambda>s. \<Sum>x \<in> supp (p s). p s x * P x s) \<tturnstile> wlp (SetPC f p) Q"
  by(simp add:wlp_def SetPC_split)

lemma wp_SetDC_split:
  "\<lbrakk> \<And>s x. x \<in> S s \<Longrightarrow> P \<tturnstile> wp (f x) Q; \<And>s. S s \<noteq> {} \<rbrakk> \<Longrightarrow>
   P \<tturnstile> wp (SetDC f S) Q"
  by(rule le_funI, unfold wp_eval, blast intro!:cInf_greatest)

lemma wlp_SetDC_split:
  "\<lbrakk> \<And>s x. x \<in> S s \<Longrightarrow> P \<tturnstile> wlp (f x) Q; \<And>s. S s \<noteq> {} \<rbrakk> \<Longrightarrow>
   P \<tturnstile> wlp (SetDC f S) Q"
  by(rule le_funI, unfold wp_eval, blast intro!:cInf_greatest)

lemma wp_SetDC:
  assumes wp: "\<And>s x. x \<in> S s \<Longrightarrow> P x \<tturnstile> wp (f x) Q"
      and ne: "\<And>s. S s \<noteq> {}"
      and sP: "\<And>x. sound (P x)"
  shows "(\<lambda>s. Inf ((\<lambda>x. P x s) ` S s)) \<tturnstile> wp (SetDC f S) Q"
  using assms by(intro le_funI, simp add:wp_eval, blast intro!:cInf_mono)

lemma wlp_SetDC:
  assumes wp: "\<And>s x. x \<in> S s \<Longrightarrow> P x \<tturnstile> wlp (f x) Q"
      and ne: "\<And>s. S s \<noteq> {}"
      and sP: "\<And>x. sound (P x)"
  shows "(\<lambda>s. Inf ((\<lambda>x. P x s) ` S s)) \<tturnstile> wlp (SetDC f S) Q"
  using assms by(intro le_funI, simp add:wp_eval, blast intro!:cInf_mono)

lemma wp_Embed:
  "P \<tturnstile> t Q \<Longrightarrow> P \<tturnstile> wp (Embed t) Q"
  by(simp add:wp_def Embed_def)

lemma wlp_Embed:
  "P \<tturnstile> t Q \<Longrightarrow> P \<tturnstile> wlp (Embed t) Q"
  by(simp add:wlp_def Embed_def)

lemma wp_Bind:
  "\<lbrakk> \<And>s. P s \<le> wp (a (f s)) Q s \<rbrakk> \<Longrightarrow> P \<tturnstile> wp (Bind f a) Q"
  by(auto simp:wp_def Bind_def)

lemma wlp_Bind:
  "\<lbrakk> \<And>s. P s \<le> wlp (a (f s)) Q s \<rbrakk> \<Longrightarrow> P \<tturnstile> wlp (Bind f a) Q"
  by(auto simp:wlp_def Bind_def)

lemma wp_repeat:
  "\<lbrakk> P \<tturnstile> wp a Q; Q \<tturnstile> wp (repeat n a) R;
     well_def a; sound Q; sound R \<rbrakk> \<Longrightarrow> P \<tturnstile> wp (repeat (Suc n) a) R"
  by(auto intro!:wp_Seq wd_intros)

lemma wlp_repeat:
  "\<lbrakk> P \<tturnstile> wlp a Q; Q \<tturnstile> wlp (repeat n a) R;
     well_def a; unitary Q; unitary R \<rbrakk> \<Longrightarrow> P \<tturnstile> wlp (repeat (Suc n) a) R"
  by(auto intro!:wlp_Seq wd_intros)

text \<open>Note that the loop rules presented in section \autoref{s:loop_rules} are of the same form,
and would belong here, had they not already been stated.\<close>

text \<open>The following rules are specialisations of those for general
  transformers, and are easier for the unifier to match.\<close>
lemmas wp_strengthen_post=
  entails_strengthen_post[where t="wp a" for a]

lemma wlp_strengthen_post:
  "P \<tturnstile> wlp a Q \<Longrightarrow> nearly_healthy (wlp a) \<Longrightarrow> unitary R \<Longrightarrow> Q \<tturnstile> R \<Longrightarrow> unitary Q \<Longrightarrow>
   P \<tturnstile> wlp a R"
  by(blast intro:entails_trans)

lemmas wp_weaken_pre=
  entails_weaken_pre[where t="wp a" for a]
lemmas wlp_weaken_pre=
  entails_weaken_pre[where t="wlp a" for a]

lemmas wp_scale=
  entails_scale[where t="wp a" for a, OF _ well_def_wp_healthy]

subsection \<open>Algebraic Decomposition\<close>

text \<open>Refinement is a powerful tool for decomposition, belied by the simplicity of the rule.
This is an \emph{axiomatic} formulation of refinement (all annotations of the @{term a}
are annotations of @{term b}), rather than an operational version (all traces of @{term b} are
traces of @{term a}.\<close>

lemma wp_refines:
  "\<lbrakk> a \<sqsubseteq> b; P \<tturnstile> wp a Q; sound Q \<rbrakk> \<Longrightarrow> P \<tturnstile> wp b Q"
  by(auto intro:entails_trans)

lemmas wp_drefines = drefinesD

subsection \<open>Hoare triples\<close>

text \<open>The Hoare triple, or validity predicate, is logically equivalent to the weakest-precondition
entailment form. The benefit is that it allows us to define transitivity rules for computational
(also/finally) reasoning.\<close>

definition
  wp_valid :: "('a \<Rightarrow> real) \<Rightarrow> 'a prog \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>p")
where
  "wp_valid P prog Q \<equiv> P \<tturnstile> wp prog Q"

lemma wp_validI:
  "P \<tturnstile> wp prog Q \<Longrightarrow> \<lbrace>P\<rbrace> prog \<lbrace>Q\<rbrace>p"
  unfolding wp_valid_def by(assumption)

lemma wp_validD:
  "\<lbrace>P\<rbrace> prog \<lbrace>Q\<rbrace>p \<Longrightarrow> P \<tturnstile> wp prog Q"
  unfolding wp_valid_def by(assumption)

lemma valid_Seq:
  "\<lbrakk> \<lbrace>P\<rbrace> a \<lbrace>Q\<rbrace>p; \<lbrace>Q\<rbrace> b \<lbrace>R\<rbrace>p; well_def a; well_def b; sound Q; sound R \<rbrakk> \<Longrightarrow>
  \<lbrace>P\<rbrace> a ;; b \<lbrace>R\<rbrace>p"
  unfolding wp_valid_def by(rule wp_Seq)

text \<open>We make it available to the computational reasoner:\<close>
declare valid_Seq[trans]

end


(* from programming and proving manual *)
theory progprove1
imports Main
begin
  (* page 6 *)
fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add 0 n = n"
| "add (Suc m) n = Suc(add m n)"

lemma "add m 0 = m"
  apply(induction m)
  apply(auto)
done

end