section \<open> COMPASS Modelling Language \<close>

theory utp_cml
imports "UTP1-Reactive-Designs.utp_rea_designs" "UTP1.utp_full"
begin

subsection \<open> Preliminaries \<close>

datatype '\<theta> tevent = Tock "'\<theta> set" | Event '\<theta>

type_synonym ('\<sigma>,'\<theta>) st_cml      = "('\<sigma>, '\<theta> tevent list, unit) rsp"
type_synonym ('\<sigma>,'\<theta>) cmlact      = "('\<sigma>,'\<theta>) st_cml hrel"
type_synonym ('a,'\<sigma>,'\<theta>) expr_cml = "('a, ('\<sigma>,'\<theta>) st_cml \<times> ('\<sigma>,'\<theta>) st_cml) uexpr"

fun events :: "'\<theta> tevent list \<Rightarrow> '\<theta> tevent list" where
"events [] = []" |
"events (Tock A # t) = events t" |
"events (Event x # t) = (Event x # events t)"

lemma events_append [simp]: "events (xs @ ys) = events(xs) @ events(ys)"
  apply (induct xs, simp_all)
  apply (rename_tac x xs)
  apply (case_tac x)
  apply (simp_all)
done

fun tocks :: "'\<theta> tevent list \<Rightarrow> '\<theta> tevent list" where
"tocks [] = []" |
"tocks (Tock A # xs) = Tock A # tocks xs" |
"tocks (Event x # xs) = tocks xs"

fun refusals :: "'\<theta> tevent list \<Rightarrow> '\<theta> set" where
"refusals [] = {}" |
"refusals (Tock A # t) = A \<union> refusals t" |
"refusals (Event x # t) = refusals t"

fun idleprefix :: "'\<theta> tevent list \<Rightarrow> '\<theta> tevent list" where
"idleprefix [] = []" |
"idleprefix (Tock A # t) = (Tock A # idleprefix t)" |
"idleprefix (Event x # t) = []"

definition "idlesuffix = idleprefix \<circ> rev"

syntax
  "_events"     :: "logic \<Rightarrow> logic" ("events\<^sub>u'(_')")
  "_tocks"      :: "logic \<Rightarrow> logic" ("tocks\<^sub>u'(_')")
  "_refusals"   :: "logic \<Rightarrow> logic" ("refusals\<^sub>u'(_')")
  "_idleprefix" :: "logic \<Rightarrow> logic" ("idleprefix\<^sub>u'(_')")
  "_idlesuffix" :: "logic \<Rightarrow> logic" ("idlesuffix\<^sub>u'(_')")
  "_ev"         :: "logic \<Rightarrow> logic" ("ev\<^sub>u'(_')")
  "_tock"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("tock\<^sub>u'(_,_')")

translations
  "events\<^sub>u(t)" == "CONST uop CONST events t"
  "tocks\<^sub>u(t)" == "CONST uop CONST tocks t"
  "refusals\<^sub>u(t)" == "CONST uop CONST refusals t"
  "idleprefix\<^sub>u(t)" == "CONST uop CONST idleprefix t"
  "idlesuffix\<^sub>u(t)" == "CONST uop CONST idlesuffix t"
  "ev\<^sub>u(e)" == "CONST uop CONST Event e"
  "tock\<^sub>u(t,A)" == "CONST bop CONST Tock t A"

subsection \<open> Signature \<close>

abbreviation time_length :: "(nat,'\<sigma>,'\<theta>) expr_cml" ("\<^bold>l")
  where "\<^bold>l \<equiv> U(length(tocks(&tt)))"

abbreviation CML :: "(('\<sigma>, '\<phi>) st_cml \<times> ('\<sigma>, '\<phi>) st_cml) health"
  where "CML \<equiv> SRD"

abbreviation Skip :: "('\<sigma>,'\<theta>) cmlact" where
"Skip \<equiv> II\<^sub>R"

abbreviation Assigns :: "'\<sigma> usubst \<Rightarrow> ('\<sigma>,'\<theta>) cmlact" ("\<langle>_\<rangle>\<^sub>C") where
"Assigns \<sigma> \<equiv> \<langle>\<sigma>\<rangle>\<^sub>R"

definition Stop :: "('\<sigma>,'\<theta>) cmlact" where
[upred_defs]: "Stop = \<^bold>R\<^sub>s(true \<turnstile> U(events(&tt) = []) \<diamondop> false)"

definition DoCML :: "('\<theta>, '\<sigma>) uexpr \<Rightarrow> ('\<sigma>,'\<theta>) cmlact" where
  [upred_defs]:
  "DoCML a = \<^bold>R\<^sub>s(true \<turnstile> U(events(&tt) = [] \<and> \<lceil>a\<rceil>\<^sub>S\<^sub>< \<notin> refusals(&tt))
                      \<diamondop> U(&tt = idleprefix(&tt) @ [Event(\<lceil>a\<rceil>\<^sub>S\<^sub><)]
                         \<and> $st\<acute> = $st \<and> \<lceil>a\<rceil>\<^sub>S\<^sub>< \<notin> refusals(&tt)))"

definition Wait :: "(nat, '\<sigma>) uexpr \<Rightarrow> ('\<sigma>,'\<theta>) cmlact" where
  [upred_defs, rdes_def]:
  "Wait n = \<^bold>R\<^sub>s(true \<turnstile> U(events(&tt) = [] \<and> length(&tt) < \<lceil>n\<rceil>\<^sub>S\<^sub><)
                    \<diamondop> U(events(&tt) = [] \<and> length(&tt) = \<lceil>n\<rceil>\<^sub>S\<^sub><
                       \<and> $st\<acute> = $st))"

lemma Skip_def: "Skip = \<^bold>R\<^sub>s(true \<turnstile> false \<diamondop> ($tr\<acute> =\<^sub>u $tr \<and> $st\<acute> =\<^sub>u $st))"
  by (simp add: srdes_skip_def, rel_auto)

subsection \<open> Healthiness conditions \<close>

abbreviation RT1 :: "('\<sigma>,'\<theta>) cmlact \<Rightarrow> ('\<sigma>,'\<theta>) cmlact" where "RT1 \<equiv> R1"
abbreviation RT2 :: "('\<sigma>,'\<theta>) cmlact \<Rightarrow> ('\<sigma>,'\<theta>) cmlact" where "RT2 \<equiv> R2c"
abbreviation RT3 :: "('\<sigma>,'\<theta>) cmlact \<Rightarrow> ('\<sigma>,'\<theta>) cmlact" where "RT3 \<equiv> R3h"
abbreviation RT4 :: "('\<sigma>,'\<theta>) cmlact \<Rightarrow> ('\<sigma>,'\<theta>) cmlact" where "RT4 \<equiv> RD1"
abbreviation RT5 :: "('\<sigma>,'\<theta>) cmlact \<Rightarrow> ('\<sigma>,'\<theta>) cmlact" where "RT5 \<equiv> RD2"
abbreviation RT6 :: "('\<sigma>,'\<theta>) cmlact \<Rightarrow> ('\<sigma>,'\<theta>) cmlact" where "RT6(P) \<equiv> Skip ;; P"
abbreviation RT7 :: "('\<sigma>,'\<theta>) cmlact \<Rightarrow> ('\<sigma>,'\<theta>) cmlact" where "RT7 \<equiv> RD3"

abbreviation RT :: "('\<sigma>,'\<theta>) cmlact \<Rightarrow> ('\<sigma>,'\<theta>) cmlact"
where "RT \<equiv> RT1 \<circ> RT2 \<circ> RT3 \<circ> RT4 \<circ> RT7"

text \<open> For the time being we omit RT8. We also omit RT5 and RT6 as, as they are both tautologies
  of the reduced theory, as we shall show. \<close>

text \<open> The following definition is taken from (Canham and Woodcock, 2014) \<close>

lemma Skip_CML_def: "Skip = (RT3 \<circ> RT4) (\<not> $wait\<acute> \<and> $tr\<acute> =\<^sub>u $tr \<and> $st\<acute> =\<^sub>u $st \<and> $ok\<acute>)"
  by (rel_auto)

subsection \<open> Laws \<close>

lemma Wait_0: "Wait 0 = Skip"
proof -
  have "Wait 0 = \<^bold>R\<^sub>s(true \<turnstile> U(events(&tt) = [] \<and> 0 > length(&tt)) \<diamondop> U(events(&tt) = [] \<and> length(&tt) = 0 \<and> $st\<acute> = $st))"
    (is "?lhs = \<^bold>R\<^sub>s(?P \<turnstile> ?Q \<diamondop> ?R)")
    by (simp add: Wait_def alpha)
  also have "... = \<^bold>R\<^sub>s(true \<turnstile> false \<diamondop> ($tr\<acute> =\<^sub>u $tr \<and> $st\<acute> =\<^sub>u $st))"
  proof -
    have 1:"?Q = false"
      by (pred_auto)
    have 2:"R1(?R) = ($tr\<acute> =\<^sub>u $tr \<and> $st\<acute> =\<^sub>u $st)"
      by (rel_auto)
    show ?thesis
      by (metis (no_types, lifting) "1" "2" RHS_design_post_R1)
  qed
  also have "... = Skip"
    by (simp add: Skip_def)
  finally show ?thesis .
qed

lemma skip_lift_state [alpha]: "\<lceil>II\<rceil>\<^sub>S = ($st\<acute> =\<^sub>u $st)"
  by (rel_auto)

lemma Stop_left_zero:
  assumes "P is CML"
  shows "Stop ;; P = Stop"
proof -
  have "Stop ;; P = \<^bold>R\<^sub>s(true \<turnstile> U(events(&tt) = []) \<diamondop> false) ;; \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P))"
    by (simp add: SRD_reactive_tri_design Stop_def assms)
  also have "... = \<^bold>R\<^sub>s (true \<turnstile> U(\<exists> $st\<acute> \<bullet> events(&tt) = []) \<diamondop> false)"
    by (subst RHS_tri_design_composition, simp_all add: unrest R2s_true R1_false R2s_false)
  also have "... = \<^bold>R\<^sub>s (true \<turnstile> U(events(&tt) = []) \<diamondop> false)"
    by (simp add: ex_unrest unrest)
  finally show ?thesis
    by (simp add: Stop_def)
qed

(*
lemma Wait_m_plus_n: "(Wait m ;; Wait n) = (Wait (m + n))"
proof -
  have 1: "(R2 (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) ;; R2 (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> \<lceil>n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt))) =
         R2 (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> \<lceil>m\<rceil>\<^sub>S\<^sub>< \<le>\<^sub>u #\<^sub>u(&tt) \<and> #\<^sub>u(&tt) <\<^sub>u \<lceil>m + n\<rceil>\<^sub>S\<^sub><)" (is "?lhs = ?rhs")
  proof -
    have "?lhs = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (((events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) ;;\<^sub>h
                                   (events\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> \<lceil>n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>))) \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>))"
      by (simp add: R2_seqr_form usubst unrest, rel_auto)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> ((events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> (#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) ;;\<^sub>h
                                       (\<lceil>n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) \<and> events\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle>))) \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (simp add: seqr_pre_out unrest conj_assoc, simp add: conj_comm)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> ((#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) ;;\<^sub>h
                                  (\<lceil>n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>))) \<and> events\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (simp add: seqr_post_out unrest conj_assoc)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> ((#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) ;;\<^sub>h (\<lceil>n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>))) \<and>
                                      events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> events\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (meson shEx_cong utp_pred_laws.inf.left_commute)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (\<lceil>(\<lceil>#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u m\<rceil>\<^sub>< \<and> II) ;;\<^sub>h (\<lceil>n\<rceil>\<^sub>< >\<^sub>u #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>))\<rceil>\<^sub>S) \<and>
                                      events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> events\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (simp add: alpha)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (\<lceil>(II \<and> \<lceil>#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u m\<rceil>\<^sub>>) ;;\<^sub>h (\<lceil>n\<rceil>\<^sub>< >\<^sub>u #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>))\<rceil>\<^sub>S) \<and>
                                      events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> events\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (simp add: pre_skip_post)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (\<lceil>\<lceil>#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u m\<rceil>\<^sub>< \<and> \<lceil>n\<rceil>\<^sub>< >\<^sub>u #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>)\<rceil>\<^sub>S) \<and>
                                      events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> events\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (simp add: seqr_pre_transfer unrest)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> \<lceil>n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>)) \<and>
                                      events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> events\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (simp add: alpha)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> \<^bold>\<exists> tt\<^sub>0 \<bullet> #\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> \<lceil>n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(drop\<^sub>u(#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>), \<guillemotleft>tt\<^sub>0\<guillemotright>)) \<and>
                                      events\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>0\<guillemotright> \<and> \<guillemotleft>tt\<^sub>0\<guillemotright> =\<^sub>u \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright> \<and>
                                      \<guillemotleft>tt\<^sub>1\<guillemotright> =\<^sub>u take\<^sub>u(#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>), \<guillemotleft>tt\<^sub>0\<guillemotright>) \<and> \<guillemotleft>tt\<^sub>2\<guillemotright> =\<^sub>u drop\<^sub>u(#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>), \<guillemotleft>tt\<^sub>0\<guillemotright>))"
      by ((rule shEx_cong)+, rel_auto)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> \<^bold>\<exists> tt\<^sub>0 \<bullet> \<lceil>n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(drop\<^sub>u(\<lceil>m\<rceil>\<^sub>S\<^sub><, \<guillemotleft>tt\<^sub>0\<guillemotright>)) \<and>
                                      events\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>0\<guillemotright> \<and>
                                      \<guillemotleft>tt\<^sub>1\<guillemotright> =\<^sub>u take\<^sub>u(\<lceil>m\<rceil>\<^sub>S\<^sub><, \<guillemotleft>tt\<^sub>0\<guillemotright>) \<and> \<guillemotleft>tt\<^sub>2\<guillemotright> =\<^sub>u drop\<^sub>u(\<lceil>m\<rceil>\<^sub>S\<^sub><, \<guillemotleft>tt\<^sub>0\<guillemotright>) \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) \<ge>\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub><)"
      by ((rule shEx_cong)+, rel_auto, simp_all add: min_absorb2)
    also have "... = (\<^bold>\<exists> tt\<^sub>0 \<bullet> \<lceil>m + n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) \<and> events\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>0\<guillemotright> \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) \<ge>\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub><)"
      by (rel_auto)
    also have "... = R2 (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> \<lceil>m\<rceil>\<^sub>S\<^sub>< \<le>\<^sub>u #\<^sub>u(&tt) \<and> #\<^sub>u(&tt) <\<^sub>u \<lceil>m + n\<rceil>\<^sub>S\<^sub><)"
      by (simp add: R2_form usubst unrest, rel_auto)
    finally show ?thesis .
  qed
  have 2:"(R2 (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) ;; R2 (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st)) =
                 R2 (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) =\<^sub>u \<lceil>m + n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st)" (is "?lhs = ?rhs")
  proof -
    have "?lhs = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> ((events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) ;;\<^sub>h
                                   (events\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st))
                         \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (simp add: R2_seqr_form usubst unrest, rel_auto)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> ((#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) ;;\<^sub>h (#\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st)) \<and>
                            events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (rel_auto)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (\<lceil>(\<lceil>#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u m\<rceil>\<^sub>< \<and> II) ;;\<^sub>h (#\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<lceil>n\<rceil>\<^sub>< \<and> II)\<rceil>\<^sub>S) \<and>
                            events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (simp add: alpha)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (\<lceil>\<lceil>#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u m\<rceil>\<^sub>< \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<lceil>n\<rceil>\<^sub>< \<and> II\<rceil>\<^sub>S) \<and>
                            events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (simp add: pre_skip_post, simp add: seqr_pre_transfer unrest)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> (#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) \<and>
                            events\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (simp add: alpha)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> \<^bold>\<exists> tt\<^sub>0 \<bullet> (#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) \<and>
                            events\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>0\<guillemotright> \<and> \<guillemotleft>tt\<^sub>0\<guillemotright> =\<^sub>u \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)"
      by (rel_auto)
    also have "... = (\<^bold>\<exists> tt\<^sub>1 \<bullet> \<^bold>\<exists> tt\<^sub>2 \<bullet> \<^bold>\<exists> tt\<^sub>0 \<bullet> (#\<^sub>u(\<guillemotleft>tt\<^sub>1\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>2\<guillemotright>) =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) \<and>
                            events\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>0\<guillemotright> \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) \<ge>\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and>
                            \<guillemotleft>tt\<^sub>1\<guillemotright> =\<^sub>u take\<^sub>u(\<lceil>m\<rceil>\<^sub>S\<^sub><, \<guillemotleft>tt\<^sub>0\<guillemotright>) \<and> \<guillemotleft>tt\<^sub>2\<guillemotright> =\<^sub>u drop\<^sub>u(\<lceil>m\<rceil>\<^sub>S\<^sub><, \<guillemotleft>tt\<^sub>0\<guillemotright>))"
      by ((rule shEx_cong)+, rel_auto)
    also have "... = (\<^bold>\<exists> tt\<^sub>0 \<bullet> (#\<^sub>u(drop\<^sub>u(\<lceil>m\<rceil>\<^sub>S\<^sub><, \<guillemotleft>tt\<^sub>0\<guillemotright>)) =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) \<and>
                            events\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>0\<guillemotright> \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) \<ge>\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub><)"
      by (rel_auto)
    also have "... = (\<^bold>\<exists> tt\<^sub>0 \<bullet> (#\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) - \<lceil>m\<rceil>\<^sub>S\<^sub>< =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) \<and>
                            events\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>0\<guillemotright> \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) \<ge>\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub><)"
      by (rel_auto)
    also have "... = (\<^bold>\<exists> tt\<^sub>0 \<bullet> (#\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) =\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< + \<lceil>n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st) \<and>
                            events\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) =\<^sub>u \<langle>\<rangle> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>0\<guillemotright> \<and> #\<^sub>u(\<guillemotleft>tt\<^sub>0\<guillemotright>) \<ge>\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub><)"
      by (rel_auto)
    also have "... = ?rhs"
      by (simp add: R2_form usubst unrest, rel_auto)
    finally show ?thesis .
  qed
  show ?thesis
  proof -
    have "(Wait m ;; Wait n) =
          \<^bold>R\<^sub>s (true \<turnstile> ((\<exists> $st\<acute> \<bullet> events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> \<lceil>m\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt)) \<or> R2 (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) \<ge>\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> \<lceil>m + n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt)))
                   \<diamondop> R2 (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) =\<^sub>u \<lceil>m + n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st))"
      by (simp add: Wait_def RHS_tri_design_composition unrest R2s_true R1_false R2_def[THEN sym] 1[simplified] 2[simplified])
    also have "... =
          \<^bold>R\<^sub>s (true \<turnstile> R2(((\<exists> $st\<acute> \<bullet> events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> \<lceil>m\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt)) \<or> R2 (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) \<ge>\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> \<lceil>m + n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt)))
                   \<diamondop> R2(events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) =\<^sub>u \<lceil>m + n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st)))"
      using RHS_design_export_R2 by blast
    also have "... =
          \<^bold>R\<^sub>s (true \<turnstile> R2((events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> \<lceil>m\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt) \<or> R2 (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) \<ge>\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> \<lceil>m + n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt)))
                   \<diamondop> R2(events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) =\<^sub>u \<lceil>m + n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st)))"
      by (simp add: ex_unrest unrest)
    also have "... =
          \<^bold>R\<^sub>s (true \<turnstile> R2((events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> \<lceil>m\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt) \<or> (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) \<ge>\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> \<lceil>m + n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt)))
                   \<diamondop> (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) =\<^sub>u \<lceil>m + n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st)))"
      by (simp add: R2_wait'_cond R2_idem R2_disj)
    also have "... =
          \<^bold>R\<^sub>s (true \<turnstile> (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> \<lceil>m\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt) \<or> (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) \<ge>\<^sub>u \<lceil>m\<rceil>\<^sub>S\<^sub>< \<and> \<lceil>m + n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt)))
                   \<diamondop> (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) =\<^sub>u \<lceil>m + n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st))" (is "?lhs = \<^bold>R\<^sub>s(?P \<turnstile> ?Q \<diamondop> ?R)")
      by (metis (mono_tags, hide_lams) R2_def RHS_design_export_R1 RHS_design_export_R2s)
    also have "... = \<^bold>R\<^sub>s (true \<turnstile> (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> \<lceil>m + n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt)) \<diamondop> (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> #\<^sub>u(&tt) =\<^sub>u \<lceil>m + n\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> =\<^sub>u $st))"
    proof -
      have 1:"?Q = (events\<^sub>u(&tt) =\<^sub>u \<langle>\<rangle> \<and> \<lceil>m + n\<rceil>\<^sub>S\<^sub>< >\<^sub>u #\<^sub>u(&tt))"
        by (pred_auto)
      show ?thesis
        by (simp add: 1)
    qed
    also have "... = Wait (m + n)"
      by (simp add: Wait_def)
    finally show ?thesis .
  qed
qed
*)

end


(*  Title:      Imperative_HOL_Time/Ref_Time.thy
    Author:     Maximilian P. L. Haslbeck & Bohua Zhan, TU Muenchen
*)

section \<open>Monadic references\<close>

text \<open>This theory is an adaptation of \<open>HOL/Imperative_HOL/Ref.thy\<close>,
 adding time bookkeeping.\<close>

theory Ref_Time
imports Array_Time
begin

text \<open>
  Imperative reference operations; modeled after their ML counterparts.
  See \<^url>\<open>https://caml.inria.fr/pub/docs/manual-caml-light/node14.15.html\<close>
  and \<^url>\<open>https://www.smlnj.org/doc/Conversion/top-level-comparison.html\<close>.
\<close>

subsection \<open>Primitives\<close>

definition present :: "heap \<Rightarrow> 'a::heap ref \<Rightarrow> bool" where
  "present h r \<longleftrightarrow> addr_of_ref r < lim h"

definition get :: "heap \<Rightarrow> 'a::heap ref \<Rightarrow> 'a" where
  "get h = from_nat \<circ> refs h TYPEREP('a) \<circ> addr_of_ref"

definition set :: "'a::heap ref \<Rightarrow> 'a \<Rightarrow> heap \<Rightarrow> heap" where
  "set r x = refs_update
    (\<lambda>h. h(TYPEREP('a) := ((h (TYPEREP('a))) (addr_of_ref r := to_nat x))))"

definition alloc :: "'a \<Rightarrow> heap \<Rightarrow> 'a::heap ref \<times> heap" where
  "alloc x h = (let
     l = lim h;
     r = Ref l
   in (r, set r x (h\<lparr>lim := l + 1\<rparr>)))"

definition noteq :: "'a::heap ref \<Rightarrow> 'b::heap ref \<Rightarrow> bool" (infix "=!=" 70) where
  "r =!= s \<longleftrightarrow> TYPEREP('a) \<noteq> TYPEREP('b) \<or> addr_of_ref r \<noteq> addr_of_ref s"

subsection \<open>Monad operations\<close>

definition ref :: "'a::heap \<Rightarrow> 'a ref Heap" where
  [code del]: "ref v = Heap_Time_Monad.heap (%h. let (r,h') = alloc v h in (r,h',1))"

definition lookup :: "'a::heap ref \<Rightarrow> 'a Heap" ("!_" 61) where
  [code del]: "lookup r = Heap_Time_Monad.tap (\<lambda>h. get h r)"

definition update :: "'a ref \<Rightarrow> 'a::heap \<Rightarrow> unit Heap" ("_ := _" 62) where
  [code del]: "update r v = Heap_Time_Monad.heap (\<lambda>h. ((), set r v h, 1))"

definition change :: "('a::heap \<Rightarrow> 'a) \<Rightarrow> 'a ref \<Rightarrow> 'a Heap" where
  "change f r = do {
     x \<leftarrow> ! r;
     let y = f x;
     r := y;
     return y
   }"

subsection \<open>Properties\<close>

text \<open>Primitives\<close>

lemma noteq_sym: "r =!= s \<Longrightarrow> s =!= r"
  and unequal [simp]: "r \<noteq> r' \<longleftrightarrow> r =!= r'" \<comment> \<open>same types!\<close>
  by (auto simp add: noteq_def)

lemma noteq_irrefl: "r =!= r \<Longrightarrow> False"
  by (auto simp add: noteq_def)

lemma present_alloc_neq: "present h r \<Longrightarrow> r =!= fst (alloc v h)"
  by (simp add: present_def alloc_def noteq_def Let_def)

lemma next_fresh [simp]:
  assumes "(r, h') = alloc x h"
  shows "\<not> present h r"
  using assms by (cases h) (auto simp add: alloc_def present_def Let_def)

lemma next_present [simp]:
  assumes "(r, h') = alloc x h"
  shows "present h' r"
  using assms by (cases h) (auto simp add: alloc_def set_def present_def Let_def)

lemma get_set_eq [simp]:
  "get (set r x h) r = x"
  by (simp add: get_def set_def)

lemma get_set_neq [simp]:
  "r =!= s \<Longrightarrow> get (set s x h) r = get h r"
  by (simp add: noteq_def get_def set_def)

lemma set_same [simp]:
  "set r x (set r y h) = set r x h"
  by (simp add: set_def)

lemma not_present_alloc [simp]:
  "\<not> present h (fst (alloc v h))"
  by (simp add: present_def alloc_def Let_def)

lemma set_set_swap:
  "r =!= r' \<Longrightarrow> set r x (set r' x' h) = set r' x' (set r x h)"
  by (simp add: noteq_def set_def fun_eq_iff)

lemma alloc_set:
  "fst (alloc x (set r x' h)) = fst (alloc x h)"
  by (simp add: alloc_def set_def Let_def)

lemma get_alloc [simp]:
  "get (snd (alloc x h)) (fst (alloc x' h)) = x"
  by (simp add: alloc_def Let_def)

lemma set_alloc [simp]:
  "set (fst (alloc v h)) v' (snd (alloc v h)) = snd (alloc v' h)"
  by (simp add: alloc_def Let_def)

lemma get_alloc_neq: "r =!= fst (alloc v h) \<Longrightarrow>
  get (snd (alloc v h)) r  = get h r"
  by (simp add: get_def set_def alloc_def Let_def noteq_def)

lemma lim_set [simp]:
  "lim (set r v h) = lim h"
  by (simp add: set_def)

lemma present_alloc [simp]:
  "present h r \<Longrightarrow> present (snd (alloc v h)) r"
  by (simp add: present_def alloc_def Let_def)

lemma present_set [simp]:
  "present (set r v h) = present h"
  by (simp add: present_def fun_eq_iff)

lemma noteq_I:
  "present h r \<Longrightarrow> \<not> present h r' \<Longrightarrow> r =!= r'"
  by (auto simp add: noteq_def present_def)

text \<open>Monad operations\<close>

lemma execute_ref [execute_simps]:
  "execute (ref v) h = Some (let (r,h') = alloc v h in (r,h',1))"
  by (simp add: ref_def execute_simps)

lemma success_refI [success_intros]:
  "success (ref v) h"
  by (auto intro: success_intros simp add: ref_def)

lemma effect_refI [effect_intros]:
  assumes "(r, h') = alloc v h" "n=1"
  shows "effect (ref v) h h' r n"
  apply (rule effectI) apply (insert assms, simp add:  execute_simps)
  by (metis case_prod_conv)

lemma effect_refE [effect_elims]:
  assumes "effect (ref v) h h' r n"
  obtains "get h' r = v" and "present h' r" and "\<not> present h r" and "n=1"
  using assms apply (rule effectE) apply (simp add: execute_simps)
  by (metis (no_types, lifting) Ref_Time.alloc_def Ref_Time.get_set_eq fst_conv next_fresh next_present prod.case_eq_if snd_conv)

lemma execute_lookup [execute_simps]:
  "Heap_Time_Monad.execute (lookup r) h = Some (get h r, h, 1)"
  by (simp add: lookup_def execute_simps)

lemma success_lookupI [success_intros]:
  "success (lookup r) h"
  by (auto intro: success_intros  simp add: lookup_def)

lemma effect_lookupI [effect_intros]:
  assumes "h' = h" "x = get h r" "n=1"
  shows "effect (!r) h h' x n"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_lookupE [effect_elims]:
  assumes "effect (!r) h h' x n"
  obtains "h' = h" "x = get h r" "n=1"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_update [execute_simps]:
  "Heap_Time_Monad.execute (update r v) h = Some ((), set r v h, 1)"
  by (simp add: update_def execute_simps)

lemma success_updateI [success_intros]:
  "success (update r v) h"
  by (auto intro: success_intros  simp add: update_def)

lemma effect_updateI [effect_intros]:
  assumes "h' = set r v h" "n=1"
  shows "effect (r := v) h h' x n"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_updateE [effect_elims]:
  assumes "effect (r' := v) h h' r n"
  obtains "h' = set r' v h" "n=1"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_change [execute_simps]:
  "Heap_Time_Monad.execute (change f r) h = Some (f (get h r), set r (f (get h r)) h, 3)"
  by (simp add: change_def bind_def Let_def execute_simps)

lemma success_changeI [success_intros]:
  "success (change f r) h"
  by (auto intro!: success_intros effect_intros simp add: change_def)

lemma effect_changeI [effect_intros]:
  assumes "h' = set r (f (get h r)) h" "x = f (get h r)" "n=3"
  shows "effect (change f r) h h' x n"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_changeE [effect_elims]:
  assumes "effect (change f r') h h' r n"
  obtains "h' = set r' (f (get h r')) h" "r = f (get h r')" "n=3"
  using assms by (rule effectE) (simp add: execute_simps)

lemma lookup_chain:
  "(!r \<then> f) = wait 1 \<then> f"
  by (rule Heap_eqI) (auto simp add: lookup_def execute_simps intro: execute_bind)

(* this one is wrong!
lemma update_change [code]:
  "r := e = change (\<lambda>_. e) r \<then> return ()"
  by (rule Heap_eqI) (simp add: change_def lookup_chain)
*)

text \<open>Non-interaction between imperative arrays and imperative references\<close>

lemma array_get_set [simp]:
  "Array_Time.get (set r v h) = Array_Time.get h"
  by (simp add: Array_Time.get_def set_def fun_eq_iff)

lemma get_update [simp]:
  "get (Array_Time.update a i v h) r = get h r"
  by (simp add: get_def Array_Time.update_def Array_Time.set_def)

lemma alloc_update:
  "fst (alloc v (Array_Time.update a i v' h)) = fst (alloc v h)"
  by (simp add: Array_Time.update_def Array_Time.get_def Array_Time.set_def alloc_def Let_def)

lemma update_set_swap:
  "Array_Time.update a i v (set r v' h) = set r v' (Array_Time.update a i v h)"
  by (simp add: Array_Time.update_def Array_Time.get_def Array_Time.set_def set_def)

lemma length_alloc [simp]:
  "Array_Time.length (snd (alloc v h)) a = Array_Time.length h a"
  by (simp add: Array_Time.length_def Array_Time.get_def alloc_def set_def Let_def)

lemma array_get_alloc [simp]:
  "Array_Time.get (snd (alloc v h)) = Array_Time.get h"
  by (simp add: Array_Time.get_def alloc_def set_def Let_def fun_eq_iff)

lemma present_update [simp]:
  "present (Array_Time.update a i v h) = present h"
  by (simp add: Array_Time.update_def Array_Time.set_def fun_eq_iff present_def)

lemma array_present_set [simp]:
  "Array_Time.present (set r v h) = Array_Time.present h"
  by (simp add: Array_Time.present_def set_def fun_eq_iff)

lemma array_present_alloc [simp]:
  "Array_Time.present h a \<Longrightarrow> Array_Time.present (snd (alloc v h)) a"
  by (simp add: Array_Time.present_def alloc_def Let_def)

lemma set_array_set_swap:
  "Array_Time.set a xs (set r x' h) = set r x' (Array_Time.set a xs h)"
  by (simp add: Array_Time.set_def set_def)

hide_const (open) present get set alloc noteq lookup update change

subsection \<open>Code generator setup\<close>

text \<open>Intermediate operation avoids invariance problem in \<open>Scala\<close> (similar to value restriction)\<close>

definition ref' where
  [code del]: "ref' = ref"

text \<open>SML / Eval\<close>

code_printing type_constructor ref \<rightharpoonup> (SML) "_/ ref"
code_printing type_constructor ref \<rightharpoonup> (Eval) "_/ Unsynchronized.ref"
code_printing constant Ref \<rightharpoonup> (SML) "raise/ (Fail/ \"bare Ref\")"
code_printing constant ref' \<rightharpoonup> (SML) "(fn/ ()/ =>/ ref/ _)"
code_printing constant ref' \<rightharpoonup> (Eval) "(fn/ ()/ =>/ Unsynchronized.ref/ _)"
code_printing constant Ref_Time.lookup \<rightharpoonup> (SML) "(fn/ ()/ =>/ !/ _)"
code_printing constant Ref_Time.update \<rightharpoonup> (SML) "(fn/ ()/ =>/ _/ :=/ _)"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (SML) infixl 6 "="

code_reserved Eval Unsynchronized

text \<open>OCaml\<close>

code_printing type_constructor ref \<rightharpoonup> (OCaml) "_/ ref"
code_printing constant Ref \<rightharpoonup> (OCaml) "failwith/ \"bare Ref\""
code_printing constant ref' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ ref/ _)"
code_printing constant Ref_Time.lookup \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ !/ _)"
code_printing constant Ref_Time.update \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ _/ :=/ _)"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (OCaml) infixl 4 "="

code_reserved OCaml ref

text \<open>Haskell\<close>

code_printing type_constructor ref \<rightharpoonup> (Haskell) "Heap.STRef/ Heap.RealWorld/ _"
code_printing constant Ref \<rightharpoonup> (Haskell) "error/ \"bare Ref\""
code_printing constant ref' \<rightharpoonup> (Haskell) "Heap.newSTRef"
code_printing constant Ref_Time.lookup \<rightharpoonup> (Haskell) "Heap.readSTRef"
code_printing constant Ref_Time.update \<rightharpoonup> (Haskell) "Heap.writeSTRef"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (Haskell) infix 4 "=="
code_printing class_instance ref :: HOL.equal \<rightharpoonup> (Haskell) -

text \<open>Scala\<close>

code_printing type_constructor ref \<rightharpoonup> (Scala) "!Ref[_]"
code_printing constant Ref \<rightharpoonup> (Scala) "!sys.error(\"bare Ref\")"
code_printing constant ref' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref((_))"
code_printing constant Ref_Time.lookup \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref.lookup((_))"
code_printing constant Ref_Time.update \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref.update((_), (_))"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (Scala) infixl 5 "=="

end


theory Refinement_MMU_No_ASIDs

imports  Update_Root_Ref

begin

definition
  tlb_rel :: "(unit tlb_entry set)  state_scheme  \<Rightarrow> (vaddr set) state_scheme \<Rightarrow> bool"
where
  "tlb_rel r t \<equiv> \<exists>(s:: unit det_tlb_state_scheme) (s':: unit sat_tlb_state_scheme).
                    tlb_rel_det r (typ_det_tlb s) \<and> tlb_rel_sat (typ_det_tlb s) (typ_sat_tlb s') \<and>
                           tlb_rel_abs (typ_sat_tlb s') t"

lemmas  abc =  mmu_translate_det_sat_refine [simplified split_def Let_def, rotated 2]
lemmas  abc' =  mmu_translate_non_det_det_refine [simplified split_def Let_def, rotated 2]

lemma address_refinement:
  "\<lbrakk> mmu_translate va r = (pa, r');  mmu_translate va t = (pa', t') ;
           va \<notin> set_tlb t ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                               pa = pa' \<and>   tlb_rel  (typ_non_det_tlb r') (typ_set_tlb t') "
  apply (clarsimp simp: tlb_rel_def)
  apply (frule_tac s = s' and pa = "fst(mmu_translate va s')" and s' = "snd(mmu_translate va s')" in
      mmu_translate_sat_incon_refine [rotated]; clarsimp?)
  apply (frule_tac va = va and pa =  "fst(mmu_translate va s)" and s' = "snd(mmu_translate va s)"in  abc; clarsimp?)
  using tlb_rel_abs_consistent apply force
  apply (frule_tac va = va and pa =  "fst(mmu_translate va r)" and s' = "snd(mmu_translate va r)"in  abc'; clarsimp?)
   apply (smt det_tlb_more mmu_incon_eq_asid_root_mem mmu_translate_sat_const_tlb sat_tlb_more tlb_rel_absD tlb_rel_sat_consistent typ_det_prim_parameter typ_sat_prim_parameter typ_set_prim_parameter)
  by force

lemma read_refinement:
  "\<lbrakk> mmu_read_size (va, sz) r = (val, r');  mmu_read_size (va, sz) t = (val', t');
           va \<notin> set_tlb t ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                               val = val' \<and>  tlb_rel  (typ_non_det_tlb r') (typ_set_tlb t') "
  apply (clarsimp simp: tlb_rel_def)
  apply (frule_tac s = s' and val = "fst(mmu_read_size (va, sz) s')" and s' = "snd(mmu_read_size (va, sz) s')" in
      mmu_read_sat_incon_refine [rotated]; clarsimp?)
  apply (frule_tac va = va and sz= sz and val =  "fst(mmu_read_size (va, sz)s)" and s' = "snd(mmu_read_size (va, sz) s)" and
      val' =  "fst(mmu_read_size (va, sz)s')"  and t' = "snd(mmu_read_size (va, sz) s')" in  mmu_read_non_det_sat_refine [rotated 2]; clarsimp?)
  using tlb_rel_abs_consistent apply force

  apply (frule_tac va = va and sz= sz and val =  "fst(mmu_read_size (va, sz)r)" and s' = "snd(mmu_read_size (va, sz) r)" and
      val' =  "fst(mmu_read_size (va, sz)s)"  and t' = "snd(mmu_read_size (va, sz) s)" in  mmu_read_non_det_det_refine [rotated 2]; clarsimp?)
  using tlb_rel_abs_consistent tlb_rel_sat_consistent apply fastforce
   apply (metis (no_types) prod.collapse)
  by force

lemma write_refinement:
  "\<lbrakk> mmu_write_size (val,va, sz) r = ((), r');  mmu_write_size (val,va, sz)  t = ((), t');
           va \<notin> set_tlb t ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                              tlb_rel  (typ_non_det_tlb r') (typ_set_tlb t') "
  apply (clarsimp simp: tlb_rel_def)
  apply (frule_tac s = s' and s' = "snd(mmu_write_size (val,va, sz) s')" in
      mmu_write_sat_incon_refine [rotated]; clarsimp?)
   apply (metis eq_snd_iff old.unit.exhaust)
  apply (frule_tac va = va and sz= sz  and s' = "snd(mmu_write_size (val,va, sz)  s)" and t' = "snd(mmu_write_size (val,va, sz)  s')" and val = val in
      mmu_write_det_sat_refine [rotated]; clarsimp?)
  using tlb_rel_abs_consistent apply force
    apply (metis eq_snd_iff old.unit.exhaust)
   apply (metis eq_snd_iff old.unit.exhaust)
  apply (frule_tac va = va and sz= sz and val =  val and s' = "snd(mmu_write_size (val,va, sz) r)" and
      t' = "snd(mmu_write_size (val,va, sz) s)" in  mmu_write_non_det_det_refine [rotated]; clarsimp?)
  using tlb_rel_abs_consistent tlb_rel_sat_consistent apply fastforce
   apply (metis eq_snd_iff old.unit.exhaust)
  by force

datatype op_typ = translate     vaddr
                | memread       "vaddr \<times> nat"
                | memwrite      "bool list \<times> vaddr \<times> nat"

datatype res_typ = PA paddr
                 | BL "bool list"
                 | UT unit

fun
  mem_op :: "op_typ \<Rightarrow> 'a::mmu state_scheme \<Rightarrow> _"
  where
  "mem_op (translate va) s             = (PA (fst (mmu_translate va s)),            snd (mmu_translate va s))"
| "mem_op (memread (va, sz)) s         = (BL (fst (mmu_read_size (va, sz) s)),      snd (mmu_read_size (va, sz) s))"
| "mem_op (memwrite (bl, va, sz)) s    = (UT (fst (mmu_write_size (bl, va, sz) s)), snd (mmu_write_size (bl, va, sz) s))"

fun
  consistent_f :: "op_typ \<Rightarrow> 'a::mmu set_tlb_state_scheme \<Rightarrow> bool"
where
  "consistent_f (translate va) s             =  (va \<notin> set_tlb s)"
| "consistent_f (memread (va, sz)) s         =  (va \<notin> set_tlb s)"
| "consistent_f (memwrite (bl, va, sz)) s    =  (va \<notin> set_tlb s)"

lemma mem_refine:
    "\<lbrakk> mem_op f r = (res, r') ; mem_op f t = (res', t');
          consistent_f f t ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                 res = res' \<and> tlb_rel (typ_non_det_tlb r') (typ_set_tlb t')"
  apply (cases f; clarsimp)
    apply (rename_tac va)
    apply (rule_tac  va = va and  r = r and t = t in address_refinement; force?)
   apply (rename_tac va sz)
   apply (rule_tac read_refinement; force?)
  apply (rename_tac bl va sz)
  apply (rule_tac val = bl and va = va and sz = sz and r = r and t = t in write_refinement; force?)
   apply (metis eq_snd_iff old.unit.exhaust)
  by (metis eq_snd_iff old.unit.exhaust)

datatype op_typ' = root_update  paddr
                 | flush_op        flush_type

lemma root_refinement:
  "\<lbrakk> update_TTBR0 rt r = ((), r');  update_TTBR0 rt t = ((), t') ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                               tlb_rel  (typ_non_det_tlb r') (typ_set_tlb t') "
  apply (clarsimp simp: tlb_rel_def)
  apply (frule_tac s = s'  and s' = "snd (update_TTBR0 rt s')"  in update_root_sat_incon_refine [rotated]; clarsimp?)
   apply (metis eq_snd_iff old.unit.exhaust)
  apply (frule_tac  r = rt and s' ="snd ( update_TTBR0 rt s) " and t' = "snd (update_TTBR0 rt s')" in update_root_det_sat_refine [rotated 2]; clarsimp?)
    apply (metis eq_snd_iff old.unit.exhaust)
   apply (metis eq_snd_iff old.unit.exhaust)
  apply (frule_tac  r = rt and s' ="snd ( update_TTBR0 rt r) " and t' = "snd (update_TTBR0 rt s)" in update_root_non_det_det_refine [rotated 2]; clarsimp?)
   apply (metis eq_snd_iff old.unit.exhaust)
  by force

lemma flush_refinement:
  "\<lbrakk> flush f r = ((), r');  flush f t = ((), t') ; tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                               tlb_rel  (typ_non_det_tlb r') (typ_set_tlb t') "
  apply (clarsimp simp: tlb_rel_def)
  apply (frule_tac s = s'  and s' = "snd (flush f s')"  in flush_sat_incon_refine [rotated]; clarsimp?)
   apply (metis eq_snd_iff old.unit.exhaust)
  apply (frule_tac f= f and s' ="snd ( flush f s) " and t' = "snd (flush f s')" in flush_det_sat_refine [rotated 2]; clarsimp?)
    apply (metis eq_snd_iff old.unit.exhaust)
   apply (metis eq_snd_iff old.unit.exhaust)
  apply (frule_tac  f = f and s' ="snd ( flush f r) " and t' = "snd (flush f s)" in flush_non_det_det_refine [rotated 2]; clarsimp?)
   apply (metis eq_snd_iff old.unit.exhaust)
  by force

fun
  main_op :: "op_typ' \<Rightarrow> 'a::mmu state_scheme \<Rightarrow> _"
  where
  "main_op (root_update rt) s     = ((),  snd (update_TTBR0 rt s))"
| "main_op (flush_op f) s         = ((), snd (flush f s))"

lemma main_refine:
    "\<lbrakk> main_op f r = ((), r') ; main_op f t = ((), t');
         tlb_rel (typ_non_det_tlb r) (typ_set_tlb t) \<rbrakk> \<Longrightarrow>
                  tlb_rel (typ_non_det_tlb r') (typ_set_tlb t')"
  apply (cases f; clarsimp)
   apply (rename_tac rt)
   apply (rule_tac  rt = rt and  r = r and t = t in root_refinement; force?)
    apply (metis eq_snd_iff old.unit.exhaust)
   apply (metis eq_snd_iff old.unit.exhaust)
  apply (rule_tac f = x2 in flush_refinement; force?)
   apply (metis eq_snd_iff old.unit.exhaust)
  by (metis eq_snd_iff old.unit.exhaust)

end