theory STVO imports DDL

begin

consts w::i (*world in which we create a situation*)

typedecl p (*type for person such as owner*)

consts owner::p
consts driver::p

typedecl m (*type for measures as in things to do in a situation*)

consts preventAccidentCongestion::m

(*---------- Predicates to describe a given situation within the traffic system -------*)
  (* These are basically on/off switches for creating a situation*)

(*Getting in or out of vehicle*)
consts gettingInOrOut_ofVehicle::\<sigma>

(*Who has taken measures?*)
measureTakenBy::"m \<Rightarrow> p \<Rightarrow> \<sigma>"

(*Did we leave the vehicle?*)
consts vehicleIsLeft::\<sigma>

(*Do we participate in traffic?*)
consts participationTraffic::\<sigma>

(*Should we be careful and considerate?*)
consts carefulAndConsiderate::\<sigma>

(*Should we harm others?*)
consts harmfulAction::\<sigma>

(*Should we annoy others?*)
consts annoyingAction::\<sigma>

(*Can we avoid an annoying action?*)
isAvoidable_annoyingAction::"\<sigma> \<Rightarrow> \<sigma>"
(*------------------------------------------------------------------------------------*)

(*------------------------------------- Grundregeln ----------------------------------*)
axiomatization where
  (*Participation in traffic requires caution and consideration*)
  ax1_1: "\<lfloor> \<^bold>O\<^bold>\<langle> carefulAndConsiderate \<^bold>| participationTraffic \<^bold>\<rangle> \<rfloor>" and

  (*Participation in traffic should not lead to harm of others or annoyance more then necessary*)
  ax1_2_1: "\<lfloor> \<^bold>O\<^bold>\<langle> (\<^bold>\<not>harmfulAction) \<^bold>| participationTraffic \<^bold>\<rangle> \<rfloor>" and
  ax1_2_2: "\<lfloor> \<^bold>O\<^bold>\<langle> (isAvoidable_annoyingAction(annoyingAction) \<^bold>\<rightarrow> (\<^bold>\<not>annoyingAction)) \<^bold>| participationTraffic \<^bold>\<rangle> \<rfloor>" (*If I do not split the axiom the provers fail*)
(*------------------------------------------------------------------------------------*)

theorem streetSafty: "(\<lfloor>participationTraffic\<rfloor> \<longrightarrow> \<lfloor> \<^bold>O\<^bold>\<langle>  carefulAndConsiderate  \<^bold>\<rangle>  \<rfloor>)" sledgehammer
  by (metis ax1_1 ax_5a ax_5b ax_5e)

theorem hope: "(\<lfloor>harmfulAction\<rfloor> \<longrightarrow> \<lfloor> \<^bold>O\<^bold>\<langle>  carefulAndConsiderate  \<^bold>\<rangle>  \<rfloor>)" sledgehammer
  using ax1_2_1 ax_5a by fastforce

lemma noAnnoyingActionPossible: "\<lfloor>participationTraffic \<^bold>\<and> isAvoidable_annoyingAction(annoyingAction)\<rfloor> \<longrightarrow> \<lfloor>\<^bold>\<not>annoyingAction\<rfloor>"  nitpick[card=2] (*card 1 does not exist*) oops

lemma a: "\<lfloor>participationTraffic\<rfloor> \<longrightarrow> \<lfloor> \<^bold>O\<^bold>\<langle>\<^bold>\<not>harmfulAction \<^bold>\<rangle> \<rfloor>" sledgehammer
  by (metis (no_types, lifting) ax1_2_1 ax_5a ax_5b ax_5e)

lemma Ob_toNotBeAnnoying: "\<lfloor>participationTraffic \<^bold>\<and> isAvoidable_annoyingAction(annoyingAction)\<rfloor> \<longrightarrow> \<lfloor>\<^bold>O\<^bold>\<langle>\<^bold>\<not>annoyingAction\<^bold>\<rangle>\<rfloor>" sledgehammer
  by (metis (no_types, lifting) ax1_2_2 ax_5a ax_5b ax_5e)

lemma intuition: "\<lfloor>participationTraffic\<rfloor>\<^sub>c\<^sub>w \<longrightarrow> \<lfloor>\<^bold>\<diamond> participationTraffic \<rfloor>" sledgehammer
(*How to say: locally valid in world w and locally valid in world v?*)
  by auto

(*------------------------------- Ein- und Aussteigen --------------------------------*)
axiomatization where
  ax14_1: "\<lfloor> \<^bold>O\<^bold>\<langle> (\<^bold>\<not>harmfulAction) \<^bold>| gettingInOrOut_ofVehicle \<^bold>\<rangle> \<rfloor>" and
  ax14_2: "\<lfloor> \<^bold>O\<^bold>\<langle> measureTakenBy preventAccidentCongestion owner \<^bold>| vehicleIsLeft \<^bold>\<rangle> \<rfloor>"

(*------------------------------------------------------------------------------------*)

lemma True nitpick[satisfy] oops

end


(*************************************************************************************************)
(* Project: The Isabelle/UTP Proof System                                                        *)
(* File: utp_sp.thy                                                                              *)
(* Authors: Yakoub Nemouchi (Virginia Tech, USA) and Simon Foster (University of York, UK)       *)
(* Emails: nemouchi@vt.edu and simon.foster@york.ac.uk                                           *)
(*************************************************************************************************)

section \<open> Strongest Postcondition Calculus\<close>

theory utp_sp
imports utp_wp
begin

named_theorems sp

method sp_tac = (simp add: sp)

consts
  usp :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infix "sp" 60)

definition sp_upred :: "'\<alpha> cond \<Rightarrow> ('\<alpha>, '\<beta>) urel \<Rightarrow> '\<beta> cond" where
"sp_upred p Q = \<lfloor>(\<lceil>p\<rceil>\<^sub>> ;; Q) :: ('\<alpha>, '\<beta>) urel\<rfloor>\<^sub>>"

no_utp_lift usp

adhoc_overloading
  usp sp_upred

declare sp_upred_def [upred_defs]

lemma sp_false [sp]: "p sp false = false"
  by (rel_simp)

lemma sp_true [sp]: "q \<noteq> false \<Longrightarrow> q sp true = true"
  by (rel_auto)

lemma sp_assign_r [sp]:
  "vwb_lens x \<Longrightarrow> (p sp x := e) = (\<^bold>\<exists> v \<bullet> p\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> \<and> &x =\<^sub>u e\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>)"
  by (rel_auto, metis vwb_lens_wb wb_lens.get_put, metis vwb_lens.put_eq)

lemma sp_assigns_r [sp]:
  "(p sp \<langle>\<sigma>\<rangle>\<^sub>a) = (\<^bold>\<exists> v \<bullet> [p\<lbrakk>\<guillemotleft>v\<guillemotright>/&\<^bold>v\<rbrakk>]\<^sub>u \<and> &\<^bold>v =\<^sub>u \<sigma>\<lbrakk>\<guillemotleft>v\<guillemotright>/&\<^bold>v\<rbrakk>)"
  by (rel_auto)

lemma sp_convr [sp]: "b sp P\<^sup>- = P wp b"
  by (rel_auto)

lemma wp_convr [wp]: "P\<^sup>- wp b = b sp P"
  by (rel_auto)

lemma sp_seqr [sp]: "b sp (P ;; Q) = (b sp P) sp Q"
  by (rel_auto)

lemma sp_is_post_condition:
  "\<lbrace>p\<rbrace>C\<lbrace>p sp C\<rbrace>\<^sub>u"
  by rel_blast

lemma sp_it_is_the_strongest_post:
  "`p sp C \<Rightarrow> Q` \<Longrightarrow> \<lbrace>p\<rbrace>C\<lbrace>Q\<rbrace>\<^sub>u"
  by rel_blast

theorem sp_hoare_link:
  "\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u \<longleftrightarrow> `p sp Q \<Rightarrow> r`"
  by rel_auto

lemma sp_while_r [sp]:
   assumes \<open>`pre \<Rightarrow> I`\<close> and \<open>\<lbrace>I \<and> b\<rbrace>C\<lbrace>I'\<rbrace>\<^sub>u\<close> and \<open>`I' \<Rightarrow> I`\<close>
   shows "(pre sp invar I while\<^sub>\<bottom> b do C od) = (\<not>b \<and> I)"
   unfolding sp_upred_def
   oops

theorem sp_eq_intro: "\<lbrakk>\<And>r. r sp P = r sp Q\<rbrakk> \<Longrightarrow> P = Q"
  by (rel_auto robust, fastforce+)

lemma wlp_sp_sym:
  "`prog wlp (true sp prog)`"
  by rel_auto

lemma it_is_pre_condition:"\<lbrace>C wlp Q\<rbrace>C\<lbrace>Q\<rbrace>\<^sub>u"
  by rel_blast

end


section \<open>Execution rules for threads\<close>

theory KPL_execution_thread imports
  KPL_state
begin

text \<open>Evaluate a local expression down to a word\<close>
fun eval_word :: "local_expr \<Rightarrow> thread_state \<Rightarrow> word"
where
  "eval_word (Loc (Var v)) \<tau> = l \<tau> (Inl v)"
(* eval_word (Loc (Name n)) \<tau> = undefined *)
| "eval_word Lid \<tau> = l \<tau> LID"
| "eval_word Gid \<tau> = l \<tau> GID"
| "eval_word eTrue \<tau> = 1"
| "eval_word (e1 \<and>* e2) \<tau> =
  (eval_word e1 \<tau> * eval_word e2 \<tau>)"
| "eval_word (\<not>* e) \<tau> = (if eval_word e \<tau> = 0 then 1 else 0)"

text \<open>Evaluate a local expression down to a boolean\<close>
fun eval_bool :: "local_expr \<Rightarrow> thread_state \<Rightarrow> bool"
where
  "eval_bool e \<tau> = (eval_word e \<tau> \<noteq> 0)"

text \<open>Abstraction level: none, equality abstraction, or adversarial abstraction\<close>
datatype abs_level = No_Abst | Eq_Abst | Adv_Abst

text \<open>The rules of Figure 4, plus two additional rules
  for adversarial abstraction (Fig 7b)\<close>
inductive step_t
  :: "abs_level \<Rightarrow> (thread_state \<times> pred_basic_stmt) \<Rightarrow> thread_state \<Rightarrow> bool"
where
  T_Disabled:
  "\<not> (eval_bool p \<tau>) \<Longrightarrow> step_t a (\<tau>, (b, p)) \<tau>"
| T_Assign:
  "\<lbrakk> eval_bool p \<tau> ; l' = (l \<tau>) (Inl v := eval_word e \<tau>) \<rbrakk>
  \<Longrightarrow> step_t a (\<tau>, (Assign (Var v) e, p)) (\<tau> (| l := l' |))"
| T_Read:
  "\<lbrakk> eval_bool p \<tau> ; l' = (l \<tau>) (Inl v := sh \<tau> (eval_word e \<tau>)) ;
  R' = R \<tau> \<union> { eval_word e \<tau> } ; a \<in> {No_Abst, Eq_Abst} \<rbrakk>
  \<Longrightarrow> step_t a (\<tau>, (Read (Var v) e, p)) (\<tau> (| l := l', R := R' |))"
| T_Write:
  "\<lbrakk> eval_bool p \<tau> ;
  sh' = (sh \<tau>) (eval_word e1 \<tau> := eval_word e2 \<tau>) ;
  W' = W \<tau> \<union> { eval_word e1 \<tau> } ; a \<in> {No_Abst, Eq_Abst} \<rbrakk>
  \<Longrightarrow> step_t a (\<tau>, (Write e1 e2, p)) (\<tau> (| sh := sh', W := W' |))"
| T_Read_Adv:
  "\<lbrakk> eval_bool p \<tau> ; l' = (l \<tau>) (Inl v := asterisk) ;
  R' = R \<tau> \<union> { eval_word e \<tau> } \<rbrakk>
  \<Longrightarrow> step_t Adv_Abst (\<tau>, (Read (Var v) e, p)) (\<tau> (| l := l', R := R' |))"
| T_Write_Adv:
  "\<lbrakk> eval_bool p \<tau> ; W' = W \<tau> \<union> { eval_word e1 \<tau> } \<rbrakk>
  \<Longrightarrow> step_t Adv_Abst (\<tau>, (Write e1 e2, p)) (\<tau> (| \<^cancel>\<open>sh := sh',\<close> W := W' |))"

text \<open>Rephrasing \<open>T_Assign\<close> to make it more usable\<close>
lemma T_Assign_helper:
  "\<lbrakk> eval_bool p \<tau> ; l' = (l \<tau>) (Inl v := eval_word e \<tau>) ; \<tau>' = \<tau> (| l := l' |) \<rbrakk>
  \<Longrightarrow> step_t a (\<tau>, (Assign (Var v) e, p)) \<tau>'"
by (auto simp add: step_t.T_Assign)

text \<open>Rephrasing \<open>T_Read\<close> to make it more usable\<close>
lemma T_Read_helper:
  "\<lbrakk> eval_bool p \<tau> ; l' = (l \<tau>) (Inl v := sh \<tau> (eval_word e \<tau>)) ;
  R' = R \<tau> \<union> { eval_word e \<tau> } ; a \<in> {No_Abst, Eq_Abst} ;
  \<tau>' = \<tau> (| l := l', R := R' |) \<rbrakk>
  \<Longrightarrow> step_t a (\<tau>, (Read (Var v) e, p)) \<tau>'"
by (auto simp add: step_t.T_Read)

text \<open>Rephrasing \<open>T_Write\<close> to make it more usable\<close>
lemma T_Write_helper:
  "\<lbrakk> eval_bool p \<tau> ;
  sh' = (sh \<tau>) (eval_word e1 \<tau> := eval_word e2 \<tau>) ;
  W' = W \<tau> \<union> { eval_word e1 \<tau> } ; a \<in> {No_Abst, Eq_Abst} ;
  \<tau>' = \<tau> (| sh := sh', W := W' |) \<rbrakk>
  \<Longrightarrow> step_t a (\<tau>, (Write e1 e2, p)) \<tau>'"
by (auto simp add: step_t.T_Write)

end


theory Insert
imports Common
begin

section types

(* the stack records a list of pages, and the index within the page that was followed;
the page is always a nf
 *)
datatype ('r) stk = Stk "('r page_ref * nat) list"

definition dest_stk :: "'r stk => ('r page_ref * nat) list" where
  "dest_stk stk == (case stk of Stk xs => xs)"

definition stk_cons :: "'r stk => ('r page_ref * nat) => 'r stk" where
  "stk_cons stk rn == (case stk of
    Stk xs => Stk(rn # xs))"

definition stk_size :: "'r stk => nat" where
  "stk_size stk == (case stk of (Stk xs) => size(xs))"

section "tree substitution"

(* we need to construct the tree, given a stack and a subtree (or two subtrees) *)

function tree_subst :: "('bs,'k,'r,'v) ctxt_p2f_t => ('bs,'r) store =>
  ('k,'v) tree => (* given a subtree *)
  'r stk => (* and a stack identifying the subtree *)
  ('k,'v) tree option" (* return the new tree resulting from substituting the given subtree *)
where
  "tree_subst c0 s0 t0 stk0 = (
    case stk0 of
    Stk [] => (Some t0)
    | Stk ((r0,n0)#stk1) => (
      let h0 = arb in (* FIXME what to do about height?! *)
      let t1 = page_ref_to_tree c0 s0 r0 h0 in
      let t2 = (
        case t1 of
        None => (Error |> rresult_to_option)
        | Some x =>(
          case x of
          Tr_lf _ => (Error |> rresult_to_option) (* impossible if stk wf *)
          | Tr_nd(n,ks,ts) => (
            let t0' = Tr_nd(n,ks,ts(n0 := t0)) in
            tree_subst c0 s0 t0' (Stk(stk1))
          ))
        )
      in
      t2)
)"
by pat_completeness auto
termination
  apply(force intro:FIXME)
  done

(* in one step, the effect of substitution at position n is... *)

definition tree_subst_1 :: "('bs,'k,'r,'v) ctxt_p2f_t => ('bs,'r) store =>
  ('k,'v) tree => (* given a subtree *)
  ('r page_ref * nat) => (* and a stack frame identifying the subtree *)
  ('k,'v) tree option" (* return the new tree resulting from substituting the given subtree *)
where
  "tree_subst_1 c0 s0 t0 r0n0 == (
      let (r0,n0) = r0n0 in
      let h0 = arb in (* FIXME what to do about height?! *)
      let t1 = page_ref_to_tree c0 s0 r0 h0 in
      let t2 = (
        case t1 of
        None => (Error |> rresult_to_option)
        | Some x =>(
          case x of
          Tr_lf _ => (Error |> rresult_to_option) (* impossible if stk wf *)
          | Tr_nd(n,ks,ts) => (
            let t0' = Tr_nd(n,ks,ts(n0 := t0)) in
            Some(t0')
          ))
        )
      in
      t2)
"

(* for tree contexts, it is convenient to work with partial trees, where a node may map to none;
instead, we use the degenerate node Tr_nd[]
 *)

(* tree_subst_1 has the following property;
FIXME need to distinguish the types of failure and success; roughly there is a failure
"at this level", and a failure at a lower level (which we don't care too much about the nature of)

we really need to move to a formalization with a "hole"; does thiemann et al have a notion of
leaves and the effect of hole substitution?

need to get some version of his stuff

*)
lemma exists_kvs_l_kvs_r: "? kvs_l kvs_r.
(((tree_subst_1 c0 s0 (Tr_nd(0,ks,ts)) (r0,n0)) |> (Option.map_option tree_to_leaves))
  = Some(kvs_l@[]@kvs_r))
& (length kvs_l = n0)
"
  sorry

lemma "
(((tree_subst_1 c0 s0 (Tr_nd(0,ks,ts)) (r0,n0)) |> tree_to_leaves) = kvs_l@[]@kvs_r)
& (length kvs_l = n0)
"
oops

(* want to know what the effect of substituting a tree is, in terms of the leaves; we need to know
the following holds for our defn of tree subst; the problem is how to get kvs_l and kvs_r *)

lemma "
! stk0. (stk_size(stk0) = n0)
--> (? kvs_l kvs_r. ! t0 kvs_c.
  ((t0 |> tree_to_leaves) = ((kvs_c)))
  --> ((tree_subst c0 s0 t0 stk0) |> (map_option tree_to_leaves) = Some(kvs_l@kvs_c@kvs_r)))
"
apply(induct_tac n0)
 apply(intro allI impI)
 apply(rule_tac x="[]" in exI)
 apply(rule_tac x="[]" in exI)
 apply(intro allI impI)
 apply(subgoal_tac "stk0 = Stk[]") prefer 2 apply (metis case_stk_def length_0_conv stk.exhaust stk.rec stk_size_def)
 apply(simp)
 apply (metis option.simps(9) rev_apply_def)

 (* size stk0 = Suc n *)
 apply(intro allI impI)
 apply(case_tac stk0)
 apply(case_tac list) apply (metis list.size(3) old.nat.distinct(2) stk.case stk_size_def)
 apply(rename_tac rn stk1)
 apply(erule_tac x="Stk(stk1)" in allE)
 apply(erule_tac impE) apply(force simp add: stk_size_def)
 apply(simp)
 apply(elim exE)

lemma tree_subst_tree_to_leaves: "
  (! t0 kvs_c.
    ((t0 |> tree_to_leaves) = ((kvs_c)))
    -->(tree_subst c0 s0 t0 stk0) |> (map_option tree_to_leaves) = Some(kvs_l@kvs_c@kvs_r))
  --> True
"
oops

section "parameters"

section "insert,  ins_state, ins_step"

record ('bs,'k,'r,'v) ins_state_down =
  isd_k :: "'k key"
  isd_v :: "'v value_t"
  isd_r :: "'r page_ref"
  isd_stk :: "'r stk"
  isd_str :: "('bs,'r) store"

record ('r) ins_state_up_1 =
  (* r is the node we have just come from ie the node we just modified *)
  isu1_r :: "'r page_ref"

(* r1 <= k < r2 *)
record ('k,'r,'v) ins_state_up_2 =
  isu2_r1 :: "'r page_ref"
  isu2_k :: "'k key"
  isu2_r2 :: "'r page_ref"

datatype ('k,'r,'v) ins_state_up' =
  S "'r ins_state_up_1"  (* inserting a single pointer *)
  | D "('k,'r,'v) ins_state_up_2"  (* inserting two pointers, separated by a key *)

record ('bs,'k,'r,'v) ins_state_up =
  isu_s :: "('k,'r,'v) ins_state_up'"
  isu_stk :: "'r stk"
  isu_str :: "('bs,'r) store"

datatype ('bs,'k,'r,'v) ins_state =
  Down "('bs,'k,'r,'v) ins_state_down"
  | Up "('bs,'k,'r,'v) ins_state_up"
  | Ret "('r page_ref * ('bs,'r) store)"

definition ins_step :: "('bs,'k,'r,'v) ctxt_k2r_t
  => ('bs,'k,'r,'v) ins_state
  =>  ('bs,'k,'r,'v) ins_state option" where
  "ins_step ctxt1 is0 == (
case is0 of
    Down isd => (
      let r0 = isd|>isd_r in
      let frm = (page_ref_to_frame (ctxt_p2f_t.truncate ctxt1) (isd|>isd_str) r0) in
      case frm of
      None => None
      | Some frm0 => (
        case frm0 of
        Frm_I nf => (
          let k2r = ((ctxt1|>key_to_ref2)|>dest_key_to_ref) in
          let k0 = (isd|>isd_k) in
          let i = k2r nf k0 in (* we need the index *)
          let r' = (nf|>nf_rs) i in
          let stk = (isd|>isd_stk) in
          let stk' = stk_cons stk (r0,i) in
          Some(Down(isd \<lparr> isd_r:= r', isd_stk:=stk'  \<rparr>))
        )
        | Frm_L lf => (
          (* we do the insert, no split case *)
          let kvs = (lf |> lf_kvs) in
          let (k,v) = (isd |> isd_k, isd |> isd_v) in
          let kvs' = (k,v)#kvs in
          let (s0::('bs,'r)store,r') = arb (* new_ref (s0|>isd_str) *) in
          let s0 = arb (* write_frame s0 r (Frm_L \<lparr> lf_kvs:=kvs' \<rparr>) *) in
          let isu1 = \<lparr> isu1_r=r' \<rparr> in
          let isu' = S(isu1) in
          let isu = \<lparr> isu_s = isu', isu_stk = (isd |> isd_stk), isu_str = s0 \<rparr> in
          Some(Up isu)
        )
      )
    )
    | Up isu => (
      let (isu',stk,s0) = (isu|>isu_s,isu|>isu_stk,isu|>isu_str) in
      case isu' of
      S isu1 => (
        let r = isu1|>isu1_r in
        case stk of Stk([]) => Some(Ret(r,s0))
        | Stk((r2,n2)#rns) => (
          (* we need to insert r in the place recorded in the stack *)
          let frm = (page_ref_to_frame (ctxt_p2f_t.truncate ctxt1) s0 r2) in
          case frm of None => (Error |> rresult_to_option) | Some x => (case x of
          Frm_I nf => (
            let (s0::('bs,'r)store,r'::'r page_ref) = arb (* new ref *) in
            let nf'::('r,'k) node_frame = arb nf r n2 in (* substitute *)
            let s0::('bs,'r)store = arb s0 r' nf' in (* write new page *)
            let isu1 = \<lparr> isu1_r=r' \<rparr> in
            let isu' = S(isu1) in
            let isu = \<lparr> isu_s = isu', isu_stk = (Stk(rns)), isu_str = s0 \<rparr> in
            Some(Up isu) )
          | _ => impossible (* ins_step: impossible *)
          )))
      | D isu2 => arb

    )

  )"

end


theory Dom_Snd
  imports "../Dominant" "../../Lifter/Lifter_Instances"
begin

locale dominant2_snd = dominant2

sublocale dominant2_snd \<subseteq> out : dominant2 "snd_l l1" t1 "snd_l l2" t2 X
proof
  fix a1 a2
  fix b :: "('g :: {Pord, Pord_Weakb}) * 'c"
  fix x
  assume Xin : "x \<in> X"

  then obtain b'1 b'2 where B' : "b = (b'1, b'2)"
    by(cases b; auto simp add: snd_l_S_def)

  then show "LUpd (snd_l l2) (t2 x) a2 b <[
       LUpd (snd_l l1) (t1 x) a1 b"
    using dominant_leq[OF Xin]
    by(auto simp add: snd_l_def prod_pleq leq_refl)
qed

lemma (in dominant2_snd) ax :
  shows "dominant2 (snd_l l1) t1 (snd_l l2) t2 X"
  using out.dominant2_axioms
  by auto

end


theory PhiSem_Int_ArbiPrec
  imports PhiSem_Generic_Boolean PhiSem_Common_Int
begin

chapter \<open>Integer of Arbitrary Precision\<close>

section \<open>Semantics\<close>

subsection \<open>Type\<close>

virtual_datatype \<phi>spec_int_ty =
  T_aint    ::  unit

debt_axiomatization T_aint :: \<open>unit type_entry\<close>
  where \<phi>spec_int_ty_ax: \<open>\<phi>spec_int_ty TY_CONS_OF T_aint\<close>

interpretation \<phi>spec_int_ty TY_CONS_OF \<open>TYPE(TY_N)\<close> \<open>TYPE(TY)\<close> T_aint using \<phi>spec_int_ty_ax .

hide_fact \<phi>spec_int_ty_ax

abbreviation aint where \<open>aint \<equiv> T_aint.mk ()\<close>

subsection \<open>Value\<close>

virtual_datatype \<phi>spec_int_val =
  V_aint     :: \<open>int\<close>

debt_axiomatization V_aint :: \<open>int value_entry\<close>
  where \<phi>spec_int_val_ax: \<open>\<phi>spec_int_val VAL_CONS_OF V_aint\<close>

interpretation \<phi>spec_int_val VAL_CONS_OF \<open>TYPE(VAL_N)\<close> \<open>TYPE(VAL)\<close> V_aint using \<phi>spec_int_val_ax .

hide_fact \<phi>spec_int_val_ax \<phi>spec_int_val_axioms

subsection \<open>Semantics\<close>

debt_axiomatization
    WT_aint[simp]: \<open>Well_Type aint = { V_aint.mk i |i. True } \<close>
and can_eqcmp_aint[simp]: "Can_EqCompare res (V_aint.mk i1) (V_aint.mk i2)"
and eqcmp_aint[simp]: "EqCompare (V_aint.mk i1) (V_aint.mk i2) \<longleftrightarrow> i1 = i2"
and  zero_aint[simp]: \<open>Zero aint   = Some (V_aint.mk 0)\<close>

(*lemma Valid_Types[simp]:
  \<open>Valid_Type aint\<close>
  unfolding Inhabited_def
  apply simp
  using less_exp by blast *)

section \<open>\<phi>-Types\<close>

subsection \<open>Integer in the normal sense\<close>

definition \<phi>AInt :: "(VAL, int) \<phi>" ("\<int>")
  where "\<phi>AInt = (\<lambda>z. { V_aint.mk z})"

lemma \<phi>AInt_expn[\<phi>expns]:
  "p \<in> (x \<Ztypecolon> \<int>) \<longleftrightarrow> p = V_aint.mk x"
  unfolding \<phi>Type_def by (simp add: \<phi>AInt_def)

lemma \<phi>AInt_inhabited[elim!,\<phi>inhabitance_rule]:
  "Inhabited (x \<Ztypecolon> \<int>) \<Longrightarrow> C \<Longrightarrow> C"
  unfolding Inhabited_def by (simp add: \<phi>expns)

lemma [\<phi>reason 1000]:
    "\<phi>Equal \<int> (\<lambda>x y. True) (=)"
  unfolding \<phi>Equal_def by (simp add: \<phi>expns eq_nat_nat_iff)

lemma [\<phi>reason 1000]:
    "\<phi>Zero aint \<int> 0"
  unfolding \<phi>Zero_def by (simp add: \<phi>expns)

lemma \<phi>Int_semty[\<phi>reason 1000]:
  \<open>\<phi>SemType (x \<Ztypecolon> \<int>) aint\<close>
  unfolding \<phi>SemType_def subset_iff
  by (simp add: \<phi>expns)

subsection \<open>Natural Nmber\<close>

definition \<phi>ANat ("\<nat>") where [\<phi>defs]: "\<nat> n = (of_nat n \<Ztypecolon> \<int>)"

lemma [\<phi>reason 1000]:
  " Threshold_Cost 4
\<Longrightarrow> \<p>\<r>\<e>\<m>\<i>\<s>\<e> 0 \<le> x \<and> y = nat x
\<Longrightarrow> x \<Ztypecolon> \<int> \<i>\<m>\<p>\<l>\<i>\<e>\<s> y \<Ztypecolon> \<nat>"
  \<medium_left_bracket> construct\<phi> \<open>nat x \<Ztypecolon> \<nat>\<close> \<medium_right_bracket>. .

lemma [\<phi>reason 1000]:
  \<open> \<p>\<r>\<e>\<m>\<i>\<s>\<e> 0 \<le> x
\<Longrightarrow> x \<Ztypecolon> \<int> \<i>\<m>\<p>\<l>\<i>\<e>\<s> nat x \<Ztypecolon> \<nat> @action to \<nat>\<close> \<medium_left_bracket> \<medium_right_bracket>. .

lemma [\<phi>reason 1000]:
  " Threshold_Cost 2
\<Longrightarrow> \<p>\<r>\<e>\<m>\<i>\<s>\<e> Int.int x = y
\<Longrightarrow> x \<Ztypecolon> \<nat> \<i>\<m>\<p>\<l>\<i>\<e>\<s> y \<Ztypecolon> \<int>" \<medium_left_bracket> destruct\<phi> _ \<medium_right_bracket>. .

lemma [\<phi>reason 1000]:
  " x \<Ztypecolon> \<nat> \<i>\<m>\<p>\<l>\<i>\<e>\<s> Int.int x \<Ztypecolon> \<int> @action to \<int> " \<medium_left_bracket> \<medium_right_bracket>. .

lemma \<phi>ANat_elim[elim!,\<phi>inhabitance_rule]:
  "Inhabited (n \<Ztypecolon> \<nat>) \<Longrightarrow> C \<Longrightarrow> C" .

lemma [\<phi>reason 1000]: \<open>\<phi>SemType (n \<Ztypecolon> \<nat>) aint\<close> \<medium_left_bracket> to \<int> \<medium_right_bracket>. .

lemma [\<phi>reason 1000]: "\<phi>Zero aint \<nat> 0" \<medium_left_bracket> \<open>0 \<Ztypecolon> \<int>\<close> \<medium_right_bracket>. .

lemma [\<phi>reason 1000]: \<open>\<phi>Equal \<nat> (\<lambda>_ _. True) (=)\<close> \<medium_left_bracket> to \<int> \<medium_right_bracket>. .

section \<open>Instructions\<close>

subsection \<open>Arithmetic Operations\<close>

definition op_const_aint :: "int \<Rightarrow> VAL proc"
  where "op_const_aint const = Return (\<phi>arg (V_aint.mk const))"

definition op_aadd :: "(VAL \<times> VAL, VAL) proc'"
  where "op_aadd =
      \<phi>M_caseV (\<lambda>vb va.
      \<phi>M_getV aint V_aint.dest vb (\<lambda>val_b.
      \<phi>M_getV aint V_aint.dest va (\<lambda>val_a.
      Return (\<phi>arg (V_aint.mk (val_a + val_b)))
  )))"

definition op_asub :: "(VAL \<times> VAL, VAL) proc'"
  where "op_asub =
      \<phi>M_caseV (\<lambda>va vb.
      \<phi>M_getV aint V_aint.dest va (\<lambda>val_a.
      \<phi>M_getV aint V_aint.dest vb (\<lambda>val_b.
      Return (\<phi>arg (V_aint.mk (val_b - val_a)))
  )))"

definition op_amul :: "(VAL \<times> VAL, VAL) proc'"
  where "op_amul =
      \<phi>M_caseV (\<lambda>va vb.
      \<phi>M_getV aint V_aint.dest va (\<lambda>val_a.
      \<phi>M_getV aint V_aint.dest vb (\<lambda>val_b.
      Return (\<phi>arg (V_aint.mk (val_b * val_a)))
  )))"

definition op_audiv :: "(VAL \<times> VAL, VAL) proc'"
  where "op_audiv =
      \<phi>M_caseV (\<lambda>va vb.
      \<phi>M_getV aint V_aint.dest va (\<lambda>val_a.
      \<phi>M_getV aint V_aint.dest vb (\<lambda>val_b.
      Return (\<phi>arg (V_aint.mk (val_b div val_a)))
  )))"

definition op_alshr :: "(VAL \<times> VAL, VAL) proc'"
  where "op_alshr =
      \<phi>M_caseV (\<lambda>va vb.
      \<phi>M_getV aint V_aint.dest va (\<lambda>val_a.
      \<phi>M_getV aint V_aint.dest vb (\<lambda>val_b.
      \<phi>M_assert (0 \<le> val_a) \<ggreater>
      Return (\<phi>arg (V_aint.mk (val_b div 2 ^ (Int.nat val_a))))
  )))"

definition op_alshl :: "(VAL \<times> VAL, VAL) proc'"
  where "op_alshl =
      \<phi>M_caseV (\<lambda>va vb.
      \<phi>M_getV aint V_aint.dest va (\<lambda>val_a.
      \<phi>M_getV aint V_aint.dest vb (\<lambda>val_b.
      \<phi>M_assert (0 \<le> val_a) \<ggreater>
      Return (\<phi>arg (V_aint.mk (val_b * 2 ^ (Int.nat val_a))))
  )))"

definition op_a_lt :: "(VAL \<times> VAL, VAL) proc'"
  where "op_a_lt =
      \<phi>M_caseV (\<lambda>va vb.
      \<phi>M_getV aint V_aint.dest va (\<lambda>val_a.
      \<phi>M_getV aint V_aint.dest vb (\<lambda>val_b.
      Return (\<phi>arg (V_bool.mk (val_b < val_a)))
  )))"

definition op_a_le :: "(VAL \<times> VAL, VAL) proc'"
  where "op_a_le =
      \<phi>M_caseV (\<lambda>va vb.
      \<phi>M_getV aint V_aint.dest va (\<lambda>val_a.
      \<phi>M_getV aint V_aint.dest vb (\<lambda>val_b.
      Return (\<phi>arg (V_bool.mk (val_b \<le> val_a)))
  )))"

section \<open>Abstraction of Instructions\<close>

subsection \<open>Arithmetic Operations\<close>

subsubsection \<open>Constant Integer\<close>

lemma op_const_aint_\<phi>app[\<phi>synthesis 300]:
  \<open> Check_Literal x
\<Longrightarrow> \<p>\<r>\<o>\<c> op_const_aint x \<lbrace> Void \<longmapsto> \<v>\<a>\<l> x \<Ztypecolon> \<int> \<rbrace>\<close>
  unfolding op_const_aint_def Premise_def
  by (rule, simp add: \<phi>expns)

lemma op_const_anat_\<phi>app[\<phi>synthesis 300]:
  \<open> \<s>\<i>\<m>\<p>\<l>\<i>\<f>\<y> x' : of_nat x \<comment>\<open>TODO: improve this!\<close>
\<Longrightarrow> Check_Literal x'
\<Longrightarrow> \<p>\<r>\<o>\<c> op_const_aint x' \<lbrace> Void \<longmapsto> \<v>\<a>\<l> x \<Ztypecolon> \<nat> \<rbrace>\<close>
  \<medium_left_bracket> op_const_aint[where x=x'] \<medium_right_bracket>. .

lemma [\<phi>reason 1210
    for \<open>Synthesis_Parse (numeral ?n::nat) (?X :: ?'ret \<Rightarrow> assn)\<close>
       \<open>Synthesis_Parse (1::nat) (?X :: ?'ret \<Rightarrow> assn)\<close>
       \<open>Synthesis_Parse (0::nat) (?X :: ?'ret \<Rightarrow> assn)\<close>
]:
  \<open> Synthesis_Parse (n \<Ztypecolon> \<nat>) X
\<Longrightarrow> Synthesis_Parse n X\<close>
  for X :: \<open>'ret \<Rightarrow> assn\<close>
  unfolding Synthesis_Parse_def ..

lemma [\<phi>reason 1210
    for \<open>Synthesis_Parse (numeral ?n::int) (?X :: ?'ret \<Rightarrow> assn)\<close>
       \<open>Synthesis_Parse (1::int) (?X :: ?'ret \<Rightarrow> assn)\<close>
       \<open>Synthesis_Parse (0::int) (?X :: ?'ret \<Rightarrow> assn)\<close>
]:
  \<open> Synthesis_Parse (n \<Ztypecolon> \<int>) X
\<Longrightarrow> Synthesis_Parse n X\<close>
  for X :: \<open>'ret \<Rightarrow> assn\<close>
  unfolding Synthesis_Parse_def ..

(* lemma op_const_size_t:
  \<open>\<p>\<r>\<o>\<c> op_const_size_t n \<lbrace> Void \<longmapsto> \<v>\<a>\<l> n \<Ztypecolon> Size \<rbrace>\<close>
  unfolding op_const_size_t_def Premise_def
  by (\<phi>reason, simp add: \<phi>expns Big_def) *)

(* lemma [\<phi>reason 1200
    for \<open>\<p>\<r>\<o>\<c> ?f \<lbrace> ?X' \<longmapsto> ?X\<heavy_comma> SYNTHESIS \<v>\<a>\<l> (numeral ?n) \<Ztypecolon> Size \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> ?E  @action synthesis ?G\<close>
       \<open>\<p>\<r>\<o>\<c> ?f \<lbrace> ?X' \<longmapsto> ?X\<heavy_comma> SYNTHESIS \<v>\<a>\<l> 0 \<Ztypecolon> Size \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> ?E  @action synthesis ?G\<close>
       \<open>\<p>\<r>\<o>\<c> ?f \<lbrace> ?X' \<longmapsto> ?X\<heavy_comma> SYNTHESIS \<v>\<a>\<l> 1 \<Ztypecolon> Size \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> ?E  @action synthesis ?G\<close>
]:
  \<open>\<p>\<r>\<o>\<c> op_const_size_t n \<lbrace> R \<longmapsto> R\<heavy_comma> SYNTHESIS \<v>\<a>\<l> n \<Ztypecolon> Size \<rbrace> @action synthesis G\<close>
  unfolding Synthesis_def Action_Tag_def
  using op_const_size_t[THEN \<phi>frame, simplified] . *)

subsubsection \<open>Integer Arithmetic\<close>

paragraph \<open>Addition\<close>

declare [[\<phi>trace_reasoning = 1]]

lemma op_add_aint_\<phi>app
  [\<phi>overload add,
   \<phi>synthesis for _ (100)
              and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<int>\<close> \<Rightarrow> \<open>\<lambda>v. x + y \<Ztypecolon> _\<close> (1200)]:
  \<open> \<p>\<r>\<o>\<c> op_aadd (\<phi>V_pair vy vx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[vx] \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[vy] \<int> \<longmapsto> \<v>\<a>\<l> x + y \<Ztypecolon> \<int> \<rbrace> \<close>
  unfolding op_aadd_def Premise_def
  by (cases vx; cases vy; simp, rule, rule, simp add: \<phi>expns, rule,
      simp add: \<phi>expns, rule, simp add: \<phi>expns)

lemma op_add_anat_\<phi>app
  [\<phi>overload add,
   \<phi>synthesis for _ (100)
              and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<nat>\<close> \<Rightarrow> \<open>\<lambda>v. x + y \<Ztypecolon> _\<close> (1200)]:
  \<open> \<p>\<r>\<o>\<c> op_aadd (\<phi>V_pair vy vx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[vx] \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[vy] \<nat> \<longmapsto> \<v>\<a>\<l> x + y \<Ztypecolon> \<nat> \<rbrace> \<close>
  \<medium_left_bracket> op_add_aint \<medium_right_bracket> by fastforce .

paragraph \<open>Subtraction\<close>

lemma op_sub_aint_\<phi>app[\<phi>overload sub,
                       \<phi>synthesis for _ (100)
                                  and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<int>\<close> \<Rightarrow> \<open>\<lambda>v. x - y \<Ztypecolon> _\<close> (1200)]:
  \<open> \<p>\<r>\<o>\<c> op_asub (\<phi>V_pair vy vx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[vx] \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[vy] \<int> \<longmapsto> \<v>\<a>\<l> x - y \<Ztypecolon> \<int> \<rbrace>\<close>
  unfolding op_asub_def Premise_def
  by (cases vx; cases vy; simp, rule, rule, simp add: \<phi>expns,
      rule, simp add: \<phi>expns, rule, simp add: \<phi>expns)

lemma op_sub_anat_\<phi>app[\<phi>overload sub,
                       \<phi>synthesis for _ (100)
                                  and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<nat>\<close> \<Rightarrow> \<open>\<lambda>v. x - y \<Ztypecolon> _\<close> (1200)]:
  \<open> \<p>\<r>\<e>\<m>\<i>\<s>\<e> y \<le> x
\<Longrightarrow> \<p>\<r>\<o>\<c> op_asub (\<phi>V_pair vy vx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[vx] \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[vy] \<nat> \<longmapsto> \<v>\<a>\<l> x - y \<Ztypecolon> \<nat> \<rbrace>\<close>
  \<medium_left_bracket> op_sub_aint \<medium_right_bracket> using nat_minus_as_int the_\<phi> by presburger .

paragraph \<open>Times\<close>

lemma op_mul_aint[\<phi>overload mul,
                  \<phi>synthesis for _ (100)
                             and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<int>\<close> \<Rightarrow> \<open>\<lambda>v. x * y \<Ztypecolon> _\<close> (1200)]:
  \<open> \<p>\<r>\<o>\<c> op_amul (\<phi>V_pair vy vx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[vx] \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[vy] \<int> \<longmapsto> \<v>\<a>\<l> x * y \<Ztypecolon> \<int> \<rbrace>\<close>
  unfolding op_amul_def
  by (cases vx; cases vy; simp, rule, rule, simp add: \<phi>expns,
      rule, simp add: \<phi>expns, rule, simp add: \<phi>expns)

lemma op_mul_anat[\<phi>overload mul,
                  \<phi>synthesis for _ (100)
                             and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<nat>\<close> \<Rightarrow> \<open>\<lambda>v. x * y \<Ztypecolon> _\<close> (1200)]:
  \<open> \<p>\<r>\<o>\<c> op_amul (\<phi>V_pair vy vx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[vx] \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[vy] \<nat> \<longmapsto> \<v>\<a>\<l> x * y \<Ztypecolon> \<nat> \<rbrace>\<close>
  \<medium_left_bracket> op_mul_aint \<medium_right_bracket>
    by (simp add: nat_mult_distrib) .

paragraph \<open>Division\<close>

lemma op_udiv_aint_\<phi>app[\<phi>overload div,
                        \<phi>synthesis for _ (100)
                                   and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<int>\<close> \<Rightarrow> \<open>\<lambda>v. x div y \<Ztypecolon> _\<close> (1200)]:
  \<open>\<p>\<r>\<o>\<c> op_audiv (\<phi>V_pair vy vx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[vx] \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[vy] \<int> \<longmapsto> \<v>\<a>\<l> x div y \<Ztypecolon> \<int> \<rbrace>\<close>
  unfolding op_audiv_def
  by (cases vx; cases vy; simp, rule, rule, simp add: \<phi>expns, rule, simp add: \<phi>expns,
      rule, simp add: \<phi>expns)

lemma op_udiv_anat_\<phi>app[\<phi>overload div,
                        \<phi>synthesis for _ (100)
                                   and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<nat>\<close> \<Rightarrow> \<open>\<lambda>v. x div y \<Ztypecolon> _\<close> (1200)]:
  \<open>\<p>\<r>\<o>\<c> op_audiv (\<phi>V_pair vy vx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[vx] \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[vy] \<nat> \<longmapsto> \<v>\<a>\<l> x div y \<Ztypecolon> \<nat> \<rbrace>\<close>
  \<medium_left_bracket> op_udiv_aint \<medium_right_bracket>
    by (simp add: div_int_pos_iff nat_div_distrib) .

paragraph \<open>Right Shift\<close>

lemma op_lshr_aint_pre_\<phi>app:
  \<open> \<p>\<r>\<e>\<m>\<i>\<s>\<e> 0 \<le> y
\<Longrightarrow> \<p>\<r>\<o>\<c> op_alshr (\<phi>V_pair raw2 raw1) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[raw1] \<int> \<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[raw2] \<int> \<longmapsto> \<v>\<a>\<l> drop_bit (nat y) x \<Ztypecolon> \<int> \<rbrace>\<close>
  unfolding op_alshr_def Premise_def
  apply (cases raw1; cases raw2; simp; rule, rule, simp add: \<phi>expns, rule, simp add: \<phi>expns, rule,
      rule \<phi>M_assert, simp add: \<phi>expns, rule, simp add: \<phi>expns)
  using drop_bit_int_def by presburger

lemma op_lshr_aint_\<phi>app[\<phi>synthesis for _ (100)
                                   and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<int> \<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<nat>\<close> \<Rightarrow> \<open>\<lambda>v. drop_bit y x \<Ztypecolon> _\<close> (1200)]:
  \<open>\<p>\<r>\<o>\<c> op_alshr (\<phi>V_pair raw2 raw1) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[raw1] \<int> \<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[raw2] \<nat> \<longmapsto> \<v>\<a>\<l> drop_bit y x \<Ztypecolon> \<int> \<rbrace>\<close>
  \<medium_left_bracket> op_lshr_aint_pre \<medium_right_bracket>. .

lemma op_lshr_anat_\<phi>app[\<phi>synthesis for _ (100)
                                   and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<nat> \<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<nat>\<close> \<Rightarrow> \<open>\<lambda>ret. drop_bit y x \<Ztypecolon> _\<close> (1200)]:
  \<open>\<p>\<r>\<o>\<c> op_alshr (\<phi>V_pair raw2 raw1) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[raw1] \<nat> \<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[raw2] \<nat> \<longmapsto> \<v>\<a>\<l> drop_bit y x \<Ztypecolon> \<nat> \<rbrace>\<close>
  \<medium_left_bracket> op_lshr_aint \<medium_right_bracket>
    by (simp add: drop_bit_of_nat)  .

paragraph \<open>Left Shift\<close>

lemma op_lshl_aint_pre_\<phi>app:
  \<open> \<p>\<r>\<e>\<m>\<i>\<s>\<e> 0 \<le> y
\<Longrightarrow> \<p>\<r>\<o>\<c> op_alshl (\<phi>V_pair raw2 raw1) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[raw1] \<int> \<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[raw2] \<int> \<longmapsto> \<v>\<a>\<l> push_bit (nat y) x \<Ztypecolon> \<int> \<rbrace>\<close>
  unfolding op_alshl_def Premise_def
  by (cases raw1; cases raw2; simp; rule, rule, simp add: \<phi>expns, rule, simp add: \<phi>expns, rule,
      rule \<phi>M_assert, simp add: \<phi>expns, rule, simp add: \<phi>expns push_bit_int_def)

lemma op_lshl_aint_\<phi>app[\<phi>synthesis for _ (100)
                                   and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<int> \<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<nat>\<close> \<Rightarrow> \<open>\<lambda>v. push_bit y x \<Ztypecolon> _\<close> (1200)]:
  \<open>\<p>\<r>\<o>\<c> op_alshl (\<phi>V_pair raw2 raw1) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[raw1] \<int> \<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[raw2] \<nat> \<longmapsto> \<v>\<a>\<l> push_bit y x \<Ztypecolon> \<int> \<rbrace>\<close>
  \<medium_left_bracket> op_lshl_aint_pre \<medium_right_bracket>. .

lemma op_lshl_anat_\<phi>app[\<phi>synthesis for _ (100)
                                   and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<nat> \<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<nat>\<close> \<Rightarrow> \<open>\<lambda>v. push_bit y x \<Ztypecolon> _\<close> (1200)]:
  \<open>\<p>\<r>\<o>\<c> op_alshl (\<phi>V_pair raw2 raw1) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[raw1] \<nat> \<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[raw2] \<nat> \<longmapsto> \<v>\<a>\<l> push_bit y x \<Ztypecolon> \<nat> \<rbrace>\<close>
  \<medium_left_bracket> op_lshl_aint \<medium_right_bracket> by (simp add: push_bit_of_nat) .

paragraph \<open>Less Than\<close>

lemma op_lt_aint[\<phi>overload less,
                 \<phi>synthesis for _ (100)
                            and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<int>\<close> \<Rightarrow> \<open>\<lambda>v. x < y \<Ztypecolon> _\<close> (1200)]:
  \<open>\<p>\<r>\<o>\<c> op_a_lt (\<phi>V_pair rawy rawx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[rawx] \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[rawy] \<int> \<longmapsto> \<v>\<a>\<l> x < y \<Ztypecolon> \<bool> \<rbrace>\<close>
  unfolding op_a_lt_def
  by (cases rawx; cases rawy; simp, rule, rule, simp add: \<phi>expns, rule,
      simp add: \<phi>expns, rule, simp add: \<phi>expns)

lemma op_lt_anat[\<phi>overload less,
                 \<phi>synthesis for _ (100)
                            and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<nat>\<close> \<Rightarrow> \<open>\<lambda>v. x < y \<Ztypecolon> _\<close> (1200)]:
  \<open>\<p>\<r>\<o>\<c> op_a_lt (\<phi>V_pair rawy rawx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[rawx] \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[rawy] \<nat> \<longmapsto> \<v>\<a>\<l> x < y \<Ztypecolon> \<bool> \<rbrace>\<close>
  \<medium_left_bracket> op_lt_aint \<medium_right_bracket>. .

paragraph \<open>Less Equal\<close>

lemma op_le_aint_\<phi>app[\<phi>overload less_equal,
                      \<phi>synthesis for _ (100)
                                 and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<int>\<close> \<Rightarrow> \<open>\<lambda>v. x \<le> y \<Ztypecolon> _\<close> (1200)]:
  \<open>\<p>\<r>\<o>\<c> op_a_le (\<phi>V_pair rawy rawx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[rawx] \<int>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[rawy] \<int> \<longmapsto> \<v>\<a>\<l> x \<le> y \<Ztypecolon> \<bool> \<rbrace>\<close>
  unfolding op_a_le_def
  by (cases rawx; cases rawy; simp, rule, rule, simp add: \<phi>expns,
      rule, simp add: \<phi>expns, rule, simp add: \<phi>expns)

lemma op_le_anat_\<phi>app[\<phi>overload less_equal,
                      \<phi>synthesis for _ (100)
                                 and \<open>x \<Ztypecolon> \<v>\<a>\<l> \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l> \<nat>\<close> \<Rightarrow> \<open>\<lambda>v. x \<le> y \<Ztypecolon> _\<close> (1200)]:
  \<open>\<p>\<r>\<o>\<c> op_a_le (\<phi>V_pair rawy rawx) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[rawx] \<nat>\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[rawy] \<nat> \<longmapsto> \<v>\<a>\<l> x \<le> y \<Ztypecolon> \<bool> \<rbrace>\<close>
  \<medium_left_bracket> op_le_aint \<medium_right_bracket>. .

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)
theory TraceMonad
imports
  "../Lib"
  "Strengthen"
begin

text \<open>
The ``Interference Trace Monad''. This nondeterministic monad
records the state at every interference point, permitting
nondeterministic interference by the environment at interference
points.

The trace set initially includes all possible environment behaviours.
Trace steps are tagged as environment or self actions, and can then
be constrained to a smaller set where the environment acts according
to a rely constraint (i.e. rely-guarantee reasoning), or to set the
environment actions to be the self actions of another program (parallel
composition).
\<close>

section "The Trace Monad"

text \<open>Trace monad identifier. Me corresponds to the current thread running and Env to the environment.\<close>
datatype tmid = Me | Env

text \<open>Results associated with traces. Traces may correspond to incomplete, failed, or completed executions.\<close>
datatype ('s, 'a) tmres = Failed | Incomplete | Result "('a \<times> 's)"

abbreviation
  map_tmres_rv :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s, 'a) tmres \<Rightarrow> ('s, 'b) tmres"
where
  "map_tmres_rv f \<equiv> map_tmres id f"

section "The Monad"

text \<open> tmonad returns a set of non-deterministic  computations, including
  a trace as a list of "thread identifier" \<times> state, and an optional
  pair result, state when the computation did not fail. \<close>
type_synonym ('s, 'a) tmonad = "'s \<Rightarrow> ((tmid \<times> 's) list \<times> ('s, 'a) tmres) set"

text \<open>Returns monad results, ignoring failures and traces.\<close>
definition
  mres :: "((tmid \<times> 's) list \<times> ('s, 'a) tmres) set \<Rightarrow> ('a \<times> 's) set"
where
  "mres r = Result -` (snd ` r)"

text \<open>
  The definition of fundamental monad functions @{text return} and
  @{text bind}. The monad function @{text "return x"} does not change
  the  state, does not fail, and returns @{text "x"}.
\<close>
definition
  return :: "'a \<Rightarrow> ('s,'a) tmonad"
where
  "return a \<equiv> \<lambda>s. ({([], Result (a, s))})"

text \<open>
  The monad function @{text "bind f g"}, also written @{text "f >>= g"},
  is the execution of @{term f} followed by the execution of @{text g}.
  The function @{text g} takes the result value \emph{and} the result
  state of @{text f} as parameter. The definition says that the result of
  the combined operation is the union of the set of sets that is created
  by @{text g} applied to the result sets of @{text f}. The combined
  operation may have failed, if @{text f} may have failed or @{text g} may
  have failed on any of the results of @{text f}.
\<close>

abbreviation (input)
  fst_upd :: "('a \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c \<times> 'b"
where
  "fst_upd f \<equiv> \<lambda>(a,b). (f a, b)"

abbreviation (input)
  snd_upd :: "('b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'c"
where
  "snd_upd f \<equiv> \<lambda>(a,b). (a, f b)"

definition
  bind :: "('s, 'a) tmonad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) tmonad) \<Rightarrow>
           ('s, 'b) tmonad" (infixl ">>=" 60)
where
  "bind f g \<equiv> \<lambda>s. \<Union>(xs, r) \<in> (f s). case r of Failed \<Rightarrow> {(xs, Failed)}
    | Incomplete \<Rightarrow> {(xs, Incomplete)}
    | Result (rv, s) \<Rightarrow> fst_upd (\<lambda>ys. ys @ xs) ` g rv s"

text \<open>Sometimes it is convenient to write @{text bind} in reverse order.\<close>
abbreviation(input)
  bind_rev :: "('c \<Rightarrow> ('a, 'b) tmonad) \<Rightarrow> ('a, 'c) tmonad \<Rightarrow>
               ('a, 'b) tmonad" (infixl "=<<" 60)
where
  "g =<< f \<equiv> f >>= g"

text \<open>
  The basic accessor functions of the state monad. @{text get} returns
  the current state as result, does not fail, and does not change the state.
  @{text "put s"} returns nothing (@{typ unit}), changes the current state
  to @{text s} and does not fail.
\<close>
definition
  get :: "('s,'s) tmonad"
where
  "get \<equiv> \<lambda>s. {([], Result (s, s))}"

definition
  put :: "'s \<Rightarrow> ('s, unit) tmonad"
where
  "put s \<equiv> \<lambda>st. {([], Result ((), s))}"

definition
  put_trace_elem :: "(tmid \<times> 's) \<Rightarrow> ('s, unit) tmonad"
where
  "put_trace_elem x = (\<lambda>s. {([], Incomplete), ([x], Result ((), s))})"

primrec
  put_trace :: "(tmid \<times> 's) list \<Rightarrow> ('s, unit) tmonad"
where
    "put_trace [] = return ()"
  | "put_trace (x # xs) = (put_trace xs >>= (\<lambda>_. put_trace_elem x))"

subsection "Nondeterminism"

text \<open>
  Basic nondeterministic functions. @{text "select A"} chooses an element
  of the set @{text A}, does not change the state, and does not fail
  (even if the set is empty). @{text "f OR g"} executes @{text f} or
  executes @{text g}. It retuns the union of results of @{text f} and
  @{text g}, and may have failed if either may have failed.
\<close>
definition
  select :: "'a set \<Rightarrow> ('s, 'a) tmonad"
where
  (* Should we have Failed when A = {} ? *)
  "select A \<equiv> \<lambda>s. (Pair [] ` Result ` (A \<times> {s}))"

definition
  alternative :: "('s,'a) tmonad \<Rightarrow> ('s,'a) tmonad \<Rightarrow>
                  ('s,'a) tmonad"
  (infixl "OR" 20)
where
  "f OR g \<equiv> \<lambda>s. (f s \<union> g s)"

text \<open> Alternative notation for @{text OR} \<close>
notation (xsymbols)  alternative (infixl "\<sqinter>" 20)

text \<open> The @{text selet_f} function was left out here until we figure
  out what variant we actually need.
\<close>

subsection "Failure"

text \<open> The monad function that always fails. Returns an empty set of
results and sets the failure flag. \<close>
definition
  fail :: "('s, 'a) tmonad"
where
 "fail \<equiv> \<lambda>s. {([], Failed)}"

text \<open> Assertions: fail if the property @{text P} is not true \<close>
definition
  assert :: "bool \<Rightarrow> ('a, unit) tmonad"
where
 "assert P \<equiv> if P then return () else fail"

text \<open> Fail if the value is @{const None},
  return result @{text v} for @{term "Some v"} \<close>
definition
  assert_opt :: "'a option \<Rightarrow> ('b, 'a) tmonad"
where
 "assert_opt v \<equiv> case v of None \<Rightarrow> fail | Some v \<Rightarrow> return v"

text \<open> An assertion that also can introspect the current state. \<close>

definition
  state_assert :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, unit) tmonad"
where
  "state_assert P \<equiv> get >>= (\<lambda>s. assert (P s))"

subsection "Generic functions on top of the state monad"

text \<open> Apply a function to the current state and return the result
without changing the state. \<close>
definition
  gets :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s, 'a) tmonad"
where
 "gets f \<equiv> get >>= (\<lambda>s. return (f s))"

text \<open> Modify the current state using the function passed in. \<close>
definition
  modify :: "('s \<Rightarrow> 's) \<Rightarrow> ('s, unit) tmonad"
where
  "modify f \<equiv> get >>= (\<lambda>s. put (f s))"

lemma simpler_gets_def: "gets f = (\<lambda>s. {([], Result ((f s), s))})"
 by (simp add: fun_eq_iff gets_def return_def bind_def get_def split_def)

lemma simpler_modify_def:
  "modify f = (\<lambda>s. {([], Result ((),(f s)))})"
  by (simp add: fun_eq_iff modify_def bind_def get_def put_def split_def)

text \<open> Execute the given monad when the condition is true,
  return @{text "()"} otherwise. \<close>
definition
  "when" :: "bool \<Rightarrow> ('s, unit) tmonad \<Rightarrow>
           ('s, unit) tmonad"
where
  "when P m \<equiv> if P then m else return ()"

text \<open> Execute the given monad unless the condition is true,
  return @{text "()"} otherwise. \<close>
definition
  unless :: "bool \<Rightarrow> ('s, unit) tmonad \<Rightarrow>
            ('s, unit) tmonad"
where
  "unless P m \<equiv> when (\<not>P) m"

text \<open>
  Perform a test on the current state, performing the left monad if
  the result is true or the right monad if the result is false.
\<close>
definition
  condition :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'r) tmonad \<Rightarrow> ('s, 'r) tmonad \<Rightarrow> ('s, 'r) tmonad"
where
  "condition P L R \<equiv> \<lambda>s. if (P s) then (L s) else (R s)"

notation (output)
  condition  ("(condition (_)//  (_)//  (_))" [1000,1000,1000] 1000)

text \<open>
Apply an option valued function to the current state, fail
if it returns @{const None}, return @{text v} if it returns
@{term "Some v"}.
\<close>
definition
  gets_the :: "('s \<Rightarrow> 'a option) \<Rightarrow> ('s, 'a) tmonad"
where
  "gets_the f \<equiv> gets f >>= assert_opt"

subsection \<open> The Monad Laws \<close>

text \<open>An alternative definition of bind, sometimes more convenient.\<close>
lemma bind_def2:
  "bind f g \<equiv> (\<lambda>s. ((\<lambda>xs. (xs, Failed)) ` {xs. (xs, Failed) \<in> f s})
    \<union> ((\<lambda>xs. (xs, Incomplete)) ` {xs. (xs, Incomplete) \<in> f s})
    \<union> (\<Union>(xs, rv, s) \<in> {(xs, rv, s'). (xs, Result (rv, s')) \<in> f s}. fst_upd (\<lambda>ys. ys @ xs) ` g rv s))"
  apply (clarsimp simp add: bind_def fun_eq_iff
                            Un_Union_image split_def
                    intro!: eq_reflection)
  apply (auto split: tmres.splits elim!:rev_bexI[where A="f x" for x])
  apply (fastforce intro: image_eqI[rotated])
  done

lemma elem_bindE:
  "(tr, res) \<in> bind f (\<lambda>x. g x) s
    \<Longrightarrow> ((res = Incomplete | res = Failed) \<Longrightarrow> (tr, map_tmres undefined undefined res) \<in> f s \<Longrightarrow> P)
    \<Longrightarrow> (\<And>tr' tr'' x s'. (tr', Result (x, s')) \<in> f s \<Longrightarrow> (tr'', res) \<in> g x s'
        \<Longrightarrow> tr = tr'' @ tr' \<Longrightarrow> P)
    \<Longrightarrow> P"
  by (auto simp: bind_def2)

text \<open> Each monad satisfies at least the following three laws. \<close>

text \<open> @{term return} is absorbed at the left of a @{term bind},
  applying the return value directly: \<close>

declare map_option.identity[simp]

lemma return_bind [simp]: "(return x >>= f) = f x"
  by (auto simp add: return_def bind_def split_def split:if_splits)

text \<open> @{term return} is absorbed on the right of a @{term bind} \<close>
lemma bind_return [simp]: "(m >>= return) = m"
  by (auto simp add: fun_eq_iff bind_def return_def
           split: tmres.splits)

text \<open> @{term bind} is associative \<close>
lemma bind_assoc:
  fixes m :: "('a,'b) tmonad"
  fixes f :: "'b \<Rightarrow> ('a,'c) tmonad"
  fixes g :: "'c \<Rightarrow> ('a,'d) tmonad"
  shows "(m >>= f) >>= g  =  m >>= (\<lambda>x. f x >>= g)"
  apply (unfold bind_def Let_def split_def)
  apply (rule ext)
  apply clarsimp
  apply (rule SUP_cong[OF refl], clarsimp)
  apply (split tmres.split; intro conjI impI; clarsimp)
  apply (simp add: image_Union)
  apply (rule SUP_cong[OF refl], clarsimp)
  apply (split tmres.split; intro conjI impI; clarsimp)
  apply (simp add: image_image)
  done

section \<open> Adding Exceptions \<close>

text \<open>
  The type @{typ "('s,'a) tmonad"} gives us nondeterminism and
  failure. We now extend this monad with exceptional return values
  that abort normal execution, but can be handled explicitly.
  We use the sum type to indicate exceptions.

  In @{typ "('s, 'e + 'a) tmonad"}, @{typ "'s"} is the state,
  @{typ 'e} is an exception, and @{typ 'a} is a normal return value.

  This new type itself forms a monad again. Since type classes in
  Isabelle are not powerful enough to express the class of monads,
  we provide new names for the @{term return} and @{term bind} functions
  in this monad. We call them @{text returnOk} (for normal return values)
  and @{text bindE} (for composition). We also define @{text throwError}
  to return an exceptional value.
\<close>
definition
  returnOk :: "'a \<Rightarrow> ('s, 'e + 'a) tmonad"
where
  "returnOk \<equiv> return o Inr"

definition
  throwError :: "'e \<Rightarrow> ('s, 'e + 'a) tmonad"
where
  "throwError \<equiv> return o Inl"

text \<open>
  Lifting a function over the exception type: if the input is an
  exception, return that exception; otherwise continue execution.
\<close>
definition
  lift :: "('a \<Rightarrow> ('s, 'e + 'b) tmonad) \<Rightarrow>
           'e +'a \<Rightarrow> ('s, 'e + 'b) tmonad"
where
  "lift f v \<equiv> case v of Inl e \<Rightarrow> throwError e
                      | Inr v' \<Rightarrow> f v'"

text \<open>
  The definition of @{term bind} in the exception monad (new
  name @{text bindE}): the same as normal @{term bind}, but
  the right-hand side is skipped if the left-hand side
  produced an exception.
\<close>
definition
  bindE :: "('s, 'e + 'a) tmonad \<Rightarrow>
            ('a \<Rightarrow> ('s, 'e + 'b) tmonad) \<Rightarrow>
            ('s, 'e + 'b) tmonad"  (infixl ">>=E" 60)
where
  "bindE f g \<equiv> bind f (lift g)"

text \<open>
  Lifting a normal nondeterministic monad into the
  exception monad is achieved by always returning its
  result as normal result and never throwing an exception.
\<close>
definition
  liftE :: "('s,'a) tmonad \<Rightarrow> ('s, 'e+'a) tmonad"
where
  "liftE f \<equiv> f >>= (\<lambda>r. return (Inr r))"

text \<open>
  Since the underlying type and @{text return} function changed,
  we need new definitions for when and unless:
\<close>
definition
  whenE :: "bool \<Rightarrow> ('s, 'e + unit) tmonad \<Rightarrow>
            ('s, 'e + unit) tmonad"
where
  "whenE P f \<equiv> if P then f else returnOk ()"

definition
  unlessE :: "bool \<Rightarrow> ('s, 'e + unit) tmonad \<Rightarrow>
            ('s, 'e + unit) tmonad"
where
  "unlessE P f \<equiv> if P then returnOk () else f"

text \<open>
  Throwing an exception when the parameter is @{term None}, otherwise
  returning @{term "v"} for @{term "Some v"}.
\<close>
definition
  throw_opt :: "'e \<Rightarrow> 'a option \<Rightarrow> ('s, 'e + 'a) tmonad"
where
  "throw_opt ex x \<equiv>
    case x of None \<Rightarrow> throwError ex | Some v \<Rightarrow> returnOk v"

text \<open>
  Failure in the exception monad is redefined in the same way
  as @{const whenE} and @{const unlessE}, with @{term returnOk}
  instead of @{term return}.
\<close>
definition
  assertE :: "bool \<Rightarrow> ('a, 'e + unit) tmonad"
where
  "assertE P \<equiv> if P then returnOk () else fail"

subsection "Monad Laws for the Exception Monad"

text \<open> More direct definition of @{const liftE}: \<close>
lemma liftE_def2:
  "liftE f = (\<lambda>s. snd_upd (map_tmres_rv Inr) ` (f s))"
  apply (clarsimp simp: fun_eq_iff liftE_def return_def split_def bind_def image_def)
  apply (rule set_eqI)
  apply (rule iffI)
  apply clarsimp
   apply (erule rev_bexI[where A="f s" for s])
   apply (clarsimp split: tmres.splits)
  apply clarsimp
  apply (rule exI)
  apply (rule conjI)
   apply (erule rev_bexI[where A="f s" for s])
   apply (rule refl)
  apply (clarsimp split: tmres.splits)
  done

text \<open> Left @{const returnOk} absorbtion over @{term bindE}: \<close>
lemma returnOk_bindE [simp]: "(returnOk x >>=E f) = f x"
  apply (unfold bindE_def returnOk_def)
  apply (clarsimp simp: lift_def)
  done

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

text \<open> Right @{const returnOk} absorbtion over @{term bindE}: \<close>
lemma bindE_returnOk [simp]: "(m >>=E returnOk) = m"
  by (simp add: bindE_def returnOk_def)

text \<open> Associativity of @{const bindE}: \<close>
lemma bindE_assoc:
  "(m >>=E f) >>=E g = m >>=E (\<lambda>x. f x >>=E g)"
  apply (simp add: bindE_def bind_assoc)
  apply (rule arg_cong [where f="\<lambda>x. m >>= x"])
  apply (rule ext)
  apply (case_tac x, simp_all add: lift_def throwError_def)
  done

text \<open> @{const returnOk} could also be defined via @{const liftE}: \<close>
lemma returnOk_liftE:
  "returnOk x = liftE (return x)"
  by (simp add: liftE_def returnOk_def)

text \<open> Execution after throwing an exception is skipped: \<close>
lemma throwError_bindE [simp]:
  "(throwError E >>=E f) = throwError E"
  by (simp add: fun_eq_iff bindE_def bind_def throwError_def lift_def return_def split_def)

section "Syntax"

text \<open> This section defines traditional Haskell-like do-syntax
  for the state monad in Isabelle. \<close>

subsection "Syntax for the Nondeterministic State Monad"

text \<open> We use @{text K_bind} to syntactically indicate the
  case where the return argument of the left side of a @{term bind}
  is ignored \<close>
definition
  K_bind_def [iff]: "K_bind \<equiv> \<lambda>x y. x"

nonterminal
  dobinds and dobind and nobind

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

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

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

text \<open> Syntax examples: \<close>
lemma "do x \<leftarrow> return 1;
          return (2::nat);
          return x
       od =
       return 1 >>=
       (\<lambda>x. return (2::nat) >>=
            K_bind (return x))"
  by (rule refl)

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

subsection "Interference command"

text \<open>Interference commands must be inserted in between actions that can be interfered with commands
running in other threads. \<close>

definition
  last_st_tr :: "(tmid * 's) list \<Rightarrow> 's \<Rightarrow> 's"
where
  "last_st_tr tr s0 = (hd (map snd tr @ [s0]))"

definition
  env_steps :: "('s,unit) tmonad"
where
  "env_steps \<equiv>
  do
    s \<leftarrow> get;
    \<comment> \<open>Add unfiltered environment events to the trace\<close>
    xs \<leftarrow> select UNIV;
    tr \<leftarrow> return (map (Pair Env) xs);
    put_trace tr;
    \<comment> \<open>Pick the last event of the trace as the final state\<close>
    put (last_st_tr tr s)
  od"

definition
  commit_step :: "('s, unit) tmonad"
where
  "commit_step \<equiv>
  do
    s \<leftarrow> get;
    put_trace [(Me,s)]
  od"

definition
  interference :: "('s,unit) tmonad"
where
  "interference \<equiv>
  do
    commit_step;
    env_steps
  od"

subsection "Syntax for the Exception Monad"

text \<open>
  Since the exception monad is a different type, we
  need to syntactically distinguish it in the syntax.
  We use @{text doE}/@{text odE} for this, but can re-use
  most of the productions from @{text do}/@{text od}
  above.
\<close>

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

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

text \<open> Syntax examples: \<close>
lemma "doE x \<leftarrow> returnOk 1;
           returnOk (2::nat);
           returnOk x
       odE =
       returnOk 1 >>=E
       (\<lambda>x. returnOk (2::nat) >>=E
            K_bind (returnOk x))"
  by (rule refl)

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

section "Library of additional Monadic Functions and Combinators"

text \<open> Lifting a normal function into the monad type: \<close>
definition
  liftM :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'a) tmonad \<Rightarrow> ('s, 'b) tmonad"
where
  "liftM f m \<equiv> do x \<leftarrow> m; return (f x) od"

text \<open> The same for the exception monad: \<close>
definition
  liftME :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'e+'a) tmonad \<Rightarrow> ('s,'e+'b) tmonad"
where
  "liftME f m \<equiv> doE x \<leftarrow> m; returnOk (f x) odE"

text \<open> Run a sequence of monads from left to right, ignoring return values. \<close>
definition
  sequence_x :: "('s, 'a) tmonad list \<Rightarrow> ('s, unit) tmonad"
where
  "sequence_x xs \<equiv> foldr (\<lambda>x y. x >>= (\<lambda>_. y)) xs (return ())"

text \<open>
  Map a monadic function over a list by applying it to each element
  of the list from left to right, ignoring return values.
\<close>
definition
  mapM_x :: "('a \<Rightarrow> ('s,'b) tmonad) \<Rightarrow> 'a list \<Rightarrow> ('s, unit) tmonad"
where
  "mapM_x f xs \<equiv> sequence_x (map f xs)"

text \<open>
  Map a monadic function with two parameters over two lists,
  going through both lists simultaneously, left to right, ignoring
  return values.
\<close>
definition
  zipWithM_x :: "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) tmonad) \<Rightarrow>
                 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, unit) tmonad"
where
  "zipWithM_x f xs ys \<equiv> sequence_x (zipWith f xs ys)"

text \<open> The same three functions as above, but returning a list of
return values instead of @{text unit} \<close>
definition
  sequence :: "('s, 'a) tmonad list \<Rightarrow> ('s, 'a list) tmonad"
where
  "sequence xs \<equiv> let mcons = (\<lambda>p q. p >>= (\<lambda>x. q >>= (\<lambda>y. return (x#y))))
                 in foldr mcons xs (return [])"

definition
  mapM :: "('a \<Rightarrow> ('s,'b) tmonad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'b list) tmonad"
where
  "mapM f xs \<equiv> sequence (map f xs)"

definition
  zipWithM :: "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) tmonad) \<Rightarrow>
                 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, 'c list) tmonad"
where
  "zipWithM f xs ys \<equiv> sequence (zipWith f xs ys)"

definition
  foldM :: "('b \<Rightarrow> 'a \<Rightarrow> ('s, 'a) tmonad) \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> ('s, 'a) tmonad"
where
  "foldM m xs a \<equiv> foldr (\<lambda>p q. q >>= m p) xs (return a) "

definition
  foldME ::"('b \<Rightarrow> 'a \<Rightarrow> ('s,('e + 'b)) tmonad) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> ('s, ('e + 'b)) tmonad"
where "foldME m a xs \<equiv> foldr (\<lambda>p q. q >>=E swp m p) xs (returnOk a)"

text \<open> The sequence and map functions above for the exception monad,
with and without lists of return value \<close>
definition
  sequenceE_x :: "('s, 'e+'a) tmonad list \<Rightarrow> ('s, 'e+unit) tmonad"
where
  "sequenceE_x xs \<equiv> foldr (\<lambda>x y. doE _ <- x; y odE) xs (returnOk ())"

definition
  mapME_x :: "('a \<Rightarrow> ('s,'e+'b) tmonad) \<Rightarrow> 'a list \<Rightarrow>
              ('s,'e+unit) tmonad"
where
  "mapME_x f xs \<equiv> sequenceE_x (map f xs)"

definition
  sequenceE :: "('s, 'e+'a) tmonad list \<Rightarrow> ('s, 'e+'a list) tmonad"
where
  "sequenceE xs \<equiv> let mcons = (\<lambda>p q. p >>=E (\<lambda>x. q >>=E (\<lambda>y. returnOk (x#y))))
                 in foldr mcons xs (returnOk [])"

definition
  mapME :: "('a \<Rightarrow> ('s,'e+'b) tmonad) \<Rightarrow> 'a list \<Rightarrow>
              ('s,'e+'b list) tmonad"
where
  "mapME f xs \<equiv> sequenceE (map f xs)"

text \<open> Filtering a list using a monadic function as predicate: \<close>
primrec
  filterM :: "('a \<Rightarrow> ('s, bool) tmonad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'a list) tmonad"
where
  "filterM P []       = return []"
| "filterM P (x # xs) = do
     b  <- P x;
     ys <- filterM P xs;
     return (if b then (x # ys) else ys)
   od"

text \<open> @{text select_state} takes a relationship between
  states, and outputs nondeterministically a state
  related to the input state. \<close>

definition
  state_select :: "('s \<times> 's) set \<Rightarrow> ('s, unit) tmonad"
where
  "state_select r \<equiv> (do
    s \<leftarrow> get;
    S \<leftarrow> return {s'. (s, s') \<in> r};
    assert (S \<noteq> {});
    s' \<leftarrow> select S;
    put s'
  od)"
section "Catching and Handling Exceptions"

text \<open>
  Turning an exception monad into a normal state monad
  by catching and handling any potential exceptions:
\<close>
definition
  catch :: "('s, 'e + 'a) tmonad \<Rightarrow>
            ('e \<Rightarrow> ('s, 'a) tmonad) \<Rightarrow>
            ('s, 'a) tmonad" (infix "<catch>" 10)
where
  "f <catch> handler \<equiv>
     do x \<leftarrow> f;
        case x of
          Inr b \<Rightarrow> return b
        | Inl e \<Rightarrow> handler e
     od"

text \<open>
  Handling exceptions, but staying in the exception monad.
  The handler may throw a type of exceptions different from
  the left side.
\<close>
definition
  handleE' :: "('s, 'e1 + 'a) tmonad \<Rightarrow>
               ('e1 \<Rightarrow> ('s, 'e2 + 'a) tmonad) \<Rightarrow>
               ('s, 'e2 + 'a) tmonad" (infix "<handle2>" 10)
where
  "f <handle2> handler \<equiv>
   do
      v \<leftarrow> f;
      case v of
        Inl e \<Rightarrow> handler e
      | Inr v' \<Rightarrow> return (Inr v')
   od"

text \<open>
  A type restriction of the above that is used more commonly in
  practice: the exception handle (potentially) throws exception
  of the same type as the left-hand side.
\<close>
definition
  handleE :: "('s, 'x + 'a) tmonad \<Rightarrow>
              ('x \<Rightarrow> ('s, 'x + 'a) tmonad) \<Rightarrow>
              ('s, 'x + 'a) tmonad" (infix "<handle>" 10)
where
  "handleE \<equiv> handleE'"

text \<open>
  Handling exceptions, and additionally providing a continuation
  if the left-hand side throws no exception:
\<close>
definition
  handle_elseE :: "('s, 'e + 'a) tmonad \<Rightarrow>
                   ('e \<Rightarrow> ('s, 'ee + 'b) tmonad) \<Rightarrow>
                   ('a \<Rightarrow> ('s, 'ee + 'b) tmonad) \<Rightarrow>
                   ('s, 'ee + 'b) tmonad"
  ("_ <handle> _ <else> _" 10)
where
  "f <handle> handler <else> continue \<equiv>
   do v \<leftarrow> f;
   case v of Inl e  \<Rightarrow> handler e
           | Inr v' \<Rightarrow> continue v'
   od"

subsection "Loops"

text \<open>
  Loops are handled using the following inductive predicate;
  non-termination is represented using the failure flag of the
  monad.
\<close>
inductive_set
  whileLoop_results :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) tmonad) \<Rightarrow> (('r \<times> 's) \<times> ((tmid \<times> 's) list \<times> ('s, 'r) tmres)) set"
  for C B
where
    "\<lbrakk> \<not> C r s \<rbrakk> \<Longrightarrow> ((r, s), ([], Result (r, s))) \<in> whileLoop_results C B"
  | "\<lbrakk> C r s; (ts, Failed) \<in> B r s \<rbrakk> \<Longrightarrow> ((r, s), (ts, Failed)) \<in> whileLoop_results C B"
  | "\<lbrakk> C r s; (ts, Incomplete) \<in> B r s \<rbrakk> \<Longrightarrow> ((r, s), (ts, Incomplete)) \<in> whileLoop_results C B"
  | "\<lbrakk> C r s; (ts, Result (r', s')) \<in> B r s; ((r', s'), (ts',z)) \<in> whileLoop_results C B  \<rbrakk>
       \<Longrightarrow> ((r, s), (ts'@ts,z)) \<in> whileLoop_results C B"

inductive_cases whileLoop_results_cases_result_end: "((x,y), ([],Result r)) \<in> whileLoop_results C B"
inductive_cases whileLoop_results_cases_fail: "((x,y), (ts, Failed)) \<in> whileLoop_results C B"
inductive_cases whileLoop_results_cases_incomplete: "((x,y), (ts, Incomplete)) \<in> whileLoop_results C B"

inductive_simps whileLoop_results_simps_valid: "((x,y), ([], Result z)) \<in> whileLoop_results C B"

inductive
  whileLoop_terminates :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) tmonad) \<Rightarrow> 'r \<Rightarrow> 's \<Rightarrow> bool"
  for C B
where
    "\<not> C r s \<Longrightarrow> whileLoop_terminates C B r s"
  | "\<lbrakk> C r s; \<forall>(r', s') \<in> Result -` snd ` (B r s). whileLoop_terminates C B r' s' \<rbrakk>
        \<Longrightarrow> whileLoop_terminates C B r s"

inductive_cases whileLoop_terminates_cases: "whileLoop_terminates C B r s"
inductive_simps whileLoop_terminates_simps: "whileLoop_terminates C B r s"

definition
  whileLoop :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) tmonad) \<Rightarrow> 'r \<Rightarrow> ('s, 'r) tmonad"
where
  "whileLoop C B \<equiv> (\<lambda>r s. {(ts, res). ((r,s), ts,res) \<in> whileLoop_results C B})"

notation (output)
  whileLoop  ("(whileLoop (_)//  (_))" [1000, 1000] 1000)

definition
  whileLoopT :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) tmonad) \<Rightarrow> 'r \<Rightarrow> ('s, 'r) tmonad"
where
  "whileLoopT C B \<equiv> (\<lambda>r s. {(ts, res). ((r,s), ts,res) \<in> whileLoop_results C B
                                         \<and> whileLoop_terminates C B r s})"

notation (output)
  whileLoopT  ("(whileLoopT (_)//  (_))" [1000, 1000] 1000)

definition
  whileLoopE :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'e + 'r) tmonad)
      \<Rightarrow> 'r \<Rightarrow> ('s, ('e + 'r)) tmonad"
where
  "whileLoopE C body \<equiv>
      \<lambda>r. whileLoop (\<lambda>r s. (case r of Inr v \<Rightarrow> C v s | _ \<Rightarrow> False)) (lift body) (Inr r)"

notation (output)
  whileLoopE  ("(whileLoopE (_)//  (_))" [1000, 1000] 1000)

subsection "Await command"

text \<open> @{term "Await c f"} blocks the execution until the @{term "c"} is true,
      and atomically executes @{term "f"}.
\<close>

definition
  Await :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,unit) tmonad"
where
  "Await c \<equiv>
  do
    s \<leftarrow> get;
    \<comment> \<open>Add unfiltered environment events, with the last one
       satisfying the `c' state predicate\<close>
    xs \<leftarrow> select {xs. c (last_st_tr (map (Pair Env) xs) s)};
    tr \<leftarrow> return (map (Pair Env) xs);
    put_trace tr;
    \<comment> \<open>Pick the last event of the trace\<close>
    put (last_st_tr tr s)
  od"

section "Hoare Logic"

subsection "Validity"

text \<open> This section defines a Hoare logic for partial correctness for
  the nondeterministic state monad as well as the exception monad.
  The logic talks only about the behaviour part of the monad and ignores
  the failure flag.

  The logic is defined semantically. Rules work directly on the
  validity predicate.

  In the nondeterministic state monad, validity is a triple of precondition,
  monad, and postcondition. The precondition is a function from state to
  bool (a state predicate), the postcondition is a function from return value
  to state to bool. A triple is valid if for all states that satisfy the
  precondition, all result values and result states that are returned by
  the monad satisfy the postcondition. Note that if the computation returns
  the empty set, the triple is trivially valid. This means @{term "assert P"}
  does not require us to prove that @{term P} holds, but rather allows us
  to assume @{term P}! Proving non-failure is done via separate predicate and
  calculus (see below).
\<close>

definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) tmonad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>")
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (\<forall>(r,s') \<in> mres (f s). Q r s')"

text \<open>
  We often reason about invariant predicates. The following provides shorthand syntax
  that avoids repeating potentially long predicates.
\<close>
abbreviation (input)
  invariant :: "('s,'a) tmonad \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool" ("_ \<lbrace>_\<rbrace>" [59,0] 60)
where
  "invariant f P \<equiv> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"

text \<open>rg_pred type: Rely-Guaranty predicates (state before => state after => bool)\<close>
type_synonym 's rg_pred = "'s \<Rightarrow> 's \<Rightarrow> bool"

text \<open>
  Validity for the exception monad is similar and build on the standard
  validity above. Instead of one postcondition, we have two: one for
  normal and one for exceptional results.
\<close>
definition
  validE :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) tmonad \<Rightarrow>
             ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
("\<lbrace>_\<rbrace>/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>)" )
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace> \<equiv> \<lbrace>P\<rbrace> f \<lbrace> \<lambda>v s. case v of Inr r \<Rightarrow> Q r s | Inl e \<Rightarrow> E e s \<rbrace>"
(*
text \<open> Validity for exception monad with interferences. Not as easy to phrase
 as we need to  \<close>
definition
  validIE :: "('s, 'a + 'b) tmonad \<Rightarrow>
             's rg_pred \<Rightarrow>
             's rg_pred \<Rightarrow> 's rg_pred \<Rightarrow>
             ('b \<Rightarrow> 's rg_pred) \<Rightarrow>
             ('a \<Rightarrow> 's rg_pred) \<Rightarrow> bool"
 ("_ //PRE _//RELY _//GUAR _//POST _//EXC _" [59,0,0,0,0,0] 60)
where
  "validIE f P R G Q E \<equiv> f SAT [P,R,G,\<lambda>v. case v of Inr r \<Rightarrow> Q r | Inl e \<Rightarrow> E e]"

abbreviation (input)
  validIEsat :: "('s, 'a + 'b) tmonad \<Rightarrow>
             's rg_pred \<Rightarrow>
             's rg_pred \<Rightarrow> 's rg_pred \<Rightarrow>
             ('b \<Rightarrow> 's rg_pred) \<Rightarrow>
             ('a \<Rightarrow> 's rg_pred) \<Rightarrow> bool"
  ("_ //SAT [_, _, _, _, _]" [59,0,0,0,0,0] 60)
  where
  "validIEsat f P R G Q E \<equiv> validIE f P R G Q E"
 *)
text \<open>
  The following two instantiations are convenient to separate reasoning
  for exceptional and normal case.
\<close>
definition
  validE_R :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'e + 'a) tmonad \<Rightarrow>
               ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
   ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>, -")
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,- \<equiv> validE P f Q (\<lambda>x y. True)"

definition
  validE_E :: "('s \<Rightarrow> bool) \<Rightarrow>  ('s, 'e + 'a) tmonad \<Rightarrow>
               ('e \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
   ("\<lbrace>_\<rbrace>/ _ /-, \<lbrace>_\<rbrace>")
where
  "\<lbrace>P\<rbrace> f -,\<lbrace>Q\<rbrace> \<equiv> validE P f (\<lambda>x y. True) Q"

text \<open> Abbreviations for trivial preconditions: \<close>
abbreviation(input)
  top :: "'a \<Rightarrow> bool" ("\<top>")
where
  "\<top> \<equiv> \<lambda>_. True"

abbreviation(input)
  bottom :: "'a \<Rightarrow> bool" ("\<bottom>")
where
  "\<bottom> \<equiv> \<lambda>_. False"

text \<open> Abbreviations for trivial postconditions (taking two arguments): \<close>
abbreviation(input)
  toptop :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<top>\<top>")
where
  "\<top>\<top> \<equiv> \<lambda>_ _. True"

abbreviation(input)
  toptoptop :: "'a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" ("\<top>\<top>\<top>")
where
  "\<top>\<top>\<top> \<equiv> \<lambda>_ _ _. True"

abbreviation(input)
  botbot :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<bottom>\<bottom>")
where
  "\<bottom>\<bottom> \<equiv> \<lambda>_ _. False"

abbreviation(input)
  botbotbot :: "'a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" ("\<bottom>\<bottom>\<bottom>")
where
  "\<bottom>\<bottom>\<bottom> \<equiv> \<lambda>_ _ _. False"

text \<open>
  Lifting @{text "\<and>"} and @{text "\<or>"} over two arguments.
  Lifting @{text "\<and>"} and @{text "\<or>"} over one argument is already
  defined (written @{text "and"} and @{text "or"}).
\<close>
definition
  bipred_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)"
  (infixl "And" 96)
where
  "bipred_conj P Q \<equiv> \<lambda>x y. P x y \<and> Q x y"

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

subsection "Determinism"

text \<open> A monad of type @{text tmonad} is deterministic iff it
returns an empty trace, exactly one state and result and does not fail \<close>
definition
  det :: "('a,'s) tmonad \<Rightarrow> bool"
where
  "det f \<equiv> \<forall>s. \<exists>r. f s = {([], Result r)}"

text \<open> A deterministic @{text tmonad} can be turned
  into a normal state monad: \<close>
definition
  the_run_state :: "('s,'a) tmonad \<Rightarrow> 's \<Rightarrow> 'a \<times> 's"
where
  "the_run_state M \<equiv> \<lambda>s. THE s'. mres (M s) = {s'}"

subsection "Non-Failure"

text \<open>
  We can formulate non-failure separately from validity.
\<close>
definition
  no_fail :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) tmonad \<Rightarrow> bool"
where
  "no_fail P m \<equiv> \<forall>s. P s \<longrightarrow> Failed \<notin> snd ` (m s)"

text \<open>
  It is often desired to prove non-failure and a Hoare triple
  simultaneously, as the reasoning is often similar. The following
  definitions allow such reasoning to take place.
\<close>

definition
  validNF ::"('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) tmonad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
      ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!")
where
  "validNF P f Q \<equiv> valid P f Q \<and> no_fail P f"

definition
  validE_NF :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) tmonad \<Rightarrow>
             ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>!)")
where
  "validE_NF P f Q E \<equiv> validE P f Q E \<and> no_fail P f"

lemma validE_NF_alt_def:
  "\<lbrace> P \<rbrace> B \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>! = \<lbrace> P \<rbrace> B \<lbrace> \<lambda>v s. case v of Inl e \<Rightarrow> E e s | Inr r \<Rightarrow> Q r s \<rbrace>!"
  by (clarsimp simp: validE_NF_def validE_def validNF_def)

(* text \<open>
  Usually, well-formed monads constructed from the primitives
  above will have the following property: if they return an
  empty set of results, they will have the failure flag set.
\<close>
definition
  empty_fail :: "('s,'a) tmonad \<Rightarrow> bool"
where
  "empty_fail m \<equiv> \<forall>s. fst (m s) = {} \<longrightarrow> snd (m s)"

text \<open>
  Useful in forcing otherwise unknown executions to have
  the @{const empty_fail} property.
\<close>
definition
  mk_ef :: "'a set \<times> bool \<Rightarrow> 'a set \<times> bool"
where
  "mk_ef S \<equiv> (fst S, fst S = {} \<or> snd S)"
 *)
section "Basic exception reasoning"

text \<open>
  The following predicates @{text no_throw} and @{text no_return} allow
  reasoning that functions in the exception monad either do
  no throw an exception or never return normally.
\<close>

definition "no_throw P A \<equiv> \<lbrace> P \<rbrace> A \<lbrace> \<lambda>_ _. True \<rbrace>,\<lbrace> \<lambda>_ _. False \<rbrace>"

definition "no_return P A \<equiv> \<lbrace> P \<rbrace> A \<lbrace>\<lambda>_ _. False\<rbrace>,\<lbrace>\<lambda>_ _. True \<rbrace>"

section "Trace monad Parallel"

definition
  parallel :: "('s,'a) tmonad \<Rightarrow> ('s,'a) tmonad \<Rightarrow> ('s,'a) tmonad"
where
  "parallel f g = (\<lambda>s. {(xs, rv). \<exists>f_steps. length f_steps = length xs
    \<and> (map (\<lambda>(f_step, (id, s)). (if f_step then id else Env, s)) (zip f_steps xs), rv) \<in> f s
    \<and> (map (\<lambda>(f_step, (id, s)). (if f_step then Env else id, s)) (zip f_steps xs), rv) \<in> g s})"

abbreviation(input)
  "parallel_mrg \<equiv> ((\<lambda>((idn, s), (idn', _)). (if idn = Env then idn' else idn, s)))"

lemma parallel_def2:
  "parallel f g = (\<lambda>s. {(xs, rv). \<exists>ys zs. (ys, rv) \<in> f s \<and> (zs, rv) \<in> g s
    \<and> list_all2 (\<lambda>y z. (fst y = Env \<or> fst z = Env) \<and> snd y = snd z) ys zs
    \<and> xs = map parallel_mrg (zip ys zs)})"
  apply (simp add: parallel_def fun_eq_iff set_eq_iff)
  apply safe
   apply (rule exI, rule conjI, assumption)+
   apply (simp add: list_all2_conv_all_nth list_eq_iff_nth_eq split_def prod_eq_iff)
   apply clarsimp
  apply (rule_tac x="map (((\<noteq>) Env) o fst) ys" in exI)
  apply (simp add: zip_map1 o_def split_def)
  apply (strengthen subst[where P="\<lambda>xs. (xs, v) \<in> S" for v S, mk_strg I _ E])
  apply (clarsimp simp: list_all2_conv_all_nth list_eq_iff_nth_eq
                        split_def prod_eq_iff
             split del: if_split cong: if_cong)
  apply auto
  done

lemma parallel_def3:
  "parallel f g = (\<lambda>s. (\<lambda>(ys, zs, rv). (map parallel_mrg (zip ys zs), rv))
    ` {(ys, zs, rv). (ys, rv) \<in> f s \<and> (zs, rv) \<in> g s
    \<and> list_all2 (\<lambda>y z. (fst y = Env \<or> fst z = Env) \<and> snd y = snd z) ys zs})"
  by (simp add: parallel_def2, rule ext, auto simp: image_def)

primrec
  trace_steps :: "(tmid \<times> 's) list \<Rightarrow> 's \<Rightarrow> (tmid \<times> 's \<times> 's) set"
where
  "trace_steps (elem # trace) s0 = {(fst elem, s0, snd elem)} \<union> trace_steps trace (snd elem)"
| "trace_steps [] s0 = {}"

lemma trace_steps_nth:
  "trace_steps xs s0 = (\<lambda>i. (fst (xs ! i), (if i = 0 then s0 else snd (xs ! (i - 1))), snd (xs ! i))) ` {..< length xs}"
proof (induct xs arbitrary: s0)
  case Nil
  show ?case by simp
next
  case (Cons a xs)
  show ?case
    apply (simp add: lessThan_Suc_eq_insert_0 Cons image_image nth_Cons')
    apply (intro arg_cong2[where f=insert] refl image_cong)
    apply simp
    done
qed

definition
  rely_cond :: "'s rg_pred \<Rightarrow> 's \<Rightarrow> (tmid \<times> 's) list \<Rightarrow> bool"
where
  "rely_cond R s0s tr = (\<forall>(ident, s0, s) \<in> trace_steps (rev tr) s0s. ident = Env \<longrightarrow> R s0 s)"

definition
  guar_cond :: "'s rg_pred \<Rightarrow> 's \<Rightarrow> (tmid \<times> 's) list \<Rightarrow> bool"
where
  "guar_cond G s0s tr = (\<forall>(ident, s0, s) \<in> trace_steps (rev tr) s0s. ident = Me \<longrightarrow> G s0 s)"

lemma rg_empty_conds[simp]:
  "rely_cond R s0s []"
  "guar_cond G s0s []"
  by (simp_all add: rely_cond_def guar_cond_def)

definition
  rely :: "('s, 'a) tmonad \<Rightarrow> 's rg_pred \<Rightarrow> 's \<Rightarrow> ('s, 'a) tmonad"
where
  "rely f R s0s \<equiv> (\<lambda>s. f s \<inter> ({tr. rely_cond R s0s tr} \<times> UNIV))"

definition
  prefix_closed :: "('s, 'a) tmonad \<Rightarrow> bool"
where
  "prefix_closed f = (\<forall>s. \<forall>x xs. (x # xs) \<in> fst ` f s \<longrightarrow> (xs, Incomplete) \<in> f s)"

definition
  validI :: "('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's rg_pred \<Rightarrow> ('s,'a) tmonad
    \<Rightarrow> 's rg_pred \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>)/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>)")
where
  "\<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>G\<rbrace>,\<lbrace>Q\<rbrace> \<equiv> prefix_closed f \<and> (\<forall>s0 s. P s0 s
    \<longrightarrow> (\<forall>tr res. (tr, res) \<in> (rely f R s0 s) \<longrightarrow> guar_cond G s0 tr
        \<and> (\<forall>rv s'. res = Result (rv, s') \<longrightarrow> Q rv (last_st_tr tr s0) s')))"

lemma in_rely:
  "\<lbrakk> (tr, res) \<in> f s; rely_cond R s0s tr \<rbrakk> \<Longrightarrow> (tr, res) \<in> rely f R s0s s"
  by (simp add: rely_def)

lemmas validI_D = validI_def[THEN meta_eq_to_obj_eq, THEN iffD1,
    THEN conjunct2, rule_format, OF _ _ in_rely]
lemmas validI_GD = validI_D[THEN conjunct1]
lemmas validI_rvD = validI_D[THEN conjunct2, rule_format, rotated -1, OF refl]
lemmas validI_prefix_closed = validI_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN conjunct1]
lemmas validI_prefix_closed_T = validI_prefix_closed[where P="\<lambda>_ _. False" and R="\<lambda>_ _. False"
    and G="\<lambda>_ _. True" and Q="\<lambda>_ _ _. True"]

lemmas prefix_closedD1 = prefix_closed_def[THEN iffD1, rule_format]

lemma in_fst_snd_image_eq:
  "x \<in> fst ` S = (\<exists>y. (x, y) \<in> S)"
  "y \<in> snd ` S = (\<exists>x. (x, y) \<in> S)"
  by (auto elim: image_eqI[rotated])

lemma in_fst_snd_image:
  "(x, y) \<in> S \<Longrightarrow> x \<in> fst ` S"
  "(x, y) \<in> S \<Longrightarrow> y \<in> snd ` S"
  by (auto simp: in_fst_snd_image_eq)

lemmas prefix_closedD = prefix_closedD1[OF _ in_fst_snd_image(1)]

end


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

section \<open>Domain package\<close>

theory Domain
imports Representable Domain_Aux
keywords
  "lazy" "unsafe" and
  "domaindef" "domain" :: thy_defn and
  "domain_isomorphism" :: thy_decl
begin

default_sort "domain"

subsection \<open>Representations of types\<close>

lemma emb_prj: "emb\<cdot>((prj\<cdot>x)::'a) = cast\<cdot>DEFL('a)\<cdot>x"
by (simp add: cast_DEFL)

lemma emb_prj_emb:
  fixes x :: "'a"
  assumes "DEFL('a) \<sqsubseteq> DEFL('b)"
  shows "emb\<cdot>(prj\<cdot>(emb\<cdot>x) :: 'b) = emb\<cdot>x"
unfolding emb_prj
apply (rule cast.belowD)
apply (rule monofun_cfun_arg [OF assms])
apply (simp add: cast_DEFL)
done

lemma prj_emb_prj:
  assumes "DEFL('a) \<sqsubseteq> DEFL('b)"
  shows "prj\<cdot>(emb\<cdot>(prj\<cdot>x :: 'b)) = (prj\<cdot>x :: 'a)"
 apply (rule emb_eq_iff [THEN iffD1])
 apply (simp only: emb_prj)
 apply (rule deflation_below_comp1)
   apply (rule deflation_cast)
  apply (rule deflation_cast)
 apply (rule monofun_cfun_arg [OF assms])
done

text \<open>Isomorphism lemmas used internally by the domain package:\<close>

lemma domain_abs_iso:
  fixes abs and rep
  assumes DEFL: "DEFL('b) = DEFL('a)"
  assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
  assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
  shows "rep\<cdot>(abs\<cdot>x) = x"
unfolding abs_def rep_def
by (simp add: emb_prj_emb DEFL)

lemma domain_rep_iso:
  fixes abs and rep
  assumes DEFL: "DEFL('b) = DEFL('a)"
  assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
  assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
  shows "abs\<cdot>(rep\<cdot>x) = x"
unfolding abs_def rep_def
by (simp add: emb_prj_emb DEFL)

subsection \<open>Deflations as sets\<close>

definition defl_set :: "'a::bifinite defl \<Rightarrow> 'a set"
where "defl_set A = {x. cast\<cdot>A\<cdot>x = x}"

lemma adm_defl_set: "adm (\<lambda>x. x \<in> defl_set A)"
unfolding defl_set_def by simp

lemma defl_set_bottom: "\<bottom> \<in> defl_set A"
unfolding defl_set_def by simp

lemma defl_set_cast [simp]: "cast\<cdot>A\<cdot>x \<in> defl_set A"
unfolding defl_set_def by simp

lemma defl_set_subset_iff: "defl_set A \<subseteq> defl_set B \<longleftrightarrow> A \<sqsubseteq> B"
apply (simp add: defl_set_def subset_eq cast_below_cast [symmetric])
apply (auto simp add: cast.belowI cast.belowD)
done

subsection \<open>Proving a subtype is representable\<close>

text \<open>Temporarily relax type constraints.\<close>

setup \<open>
  fold Sign.add_const_constraint
  [ (\<^const_name>\<open>defl\<close>, SOME \<^typ>\<open>'a::pcpo itself \<Rightarrow> udom defl\<close>)
  , (\<^const_name>\<open>emb\<close>, SOME \<^typ>\<open>'a::pcpo \<rightarrow> udom\<close>)
  , (\<^const_name>\<open>prj\<close>, SOME \<^typ>\<open>udom \<rightarrow> 'a::pcpo\<close>)
  , (\<^const_name>\<open>liftdefl\<close>, SOME \<^typ>\<open>'a::pcpo itself \<Rightarrow> udom u defl\<close>)
  , (\<^const_name>\<open>liftemb\<close>, SOME \<^typ>\<open>'a::pcpo u \<rightarrow> udom u\<close>)
  , (\<^const_name>\<open>liftprj\<close>, SOME \<^typ>\<open>udom u \<rightarrow> 'a::pcpo u\<close>) ]
\<close>

lemma typedef_domain_class:
  fixes Rep :: "'a::pcpo \<Rightarrow> udom"
  fixes Abs :: "udom \<Rightarrow> 'a::pcpo"
  fixes t :: "udom defl"
  assumes type: "type_definition Rep Abs (defl_set t)"
  assumes below: "(\<sqsubseteq>) \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  assumes emb: "emb \<equiv> (\<Lambda> x. Rep x)"
  assumes prj: "prj \<equiv> (\<Lambda> x. Abs (cast\<cdot>t\<cdot>x))"
  assumes defl: "defl \<equiv> (\<lambda> a::'a itself. t)"
  assumes liftemb: "(liftemb :: 'a u \<rightarrow> udom u) \<equiv> u_map\<cdot>emb"
  assumes liftprj: "(liftprj :: udom u \<rightarrow> 'a u) \<equiv> u_map\<cdot>prj"
  assumes liftdefl: "(liftdefl :: 'a itself \<Rightarrow> _) \<equiv> (\<lambda>t. liftdefl_of\<cdot>DEFL('a))"
  shows "OFCLASS('a, domain_class)"
proof
  have emb_beta: "\<And>x. emb\<cdot>x = Rep x"
    unfolding emb
    apply (rule beta_cfun)
    apply (rule typedef_cont_Rep [OF type below adm_defl_set cont_id])
    done
  have prj_beta: "\<And>y. prj\<cdot>y = Abs (cast\<cdot>t\<cdot>y)"
    unfolding prj
    apply (rule beta_cfun)
    apply (rule typedef_cont_Abs [OF type below adm_defl_set])
    apply simp_all
    done
  have prj_emb: "\<And>x::'a. prj\<cdot>(emb\<cdot>x) = x"
    using type_definition.Rep [OF type]
    unfolding prj_beta emb_beta defl_set_def
    by (simp add: type_definition.Rep_inverse [OF type])
  have emb_prj: "\<And>y. emb\<cdot>(prj\<cdot>y :: 'a) = cast\<cdot>t\<cdot>y"
    unfolding prj_beta emb_beta
    by (simp add: type_definition.Abs_inverse [OF type])
  show "ep_pair (emb :: 'a \<rightarrow> udom) prj"
    apply standard
    apply (simp add: prj_emb)
    apply (simp add: emb_prj cast.below)
    done
  show "cast\<cdot>DEFL('a) = emb oo (prj :: udom \<rightarrow> 'a)"
    by (rule cfun_eqI, simp add: defl emb_prj)
qed (simp_all only: liftemb liftprj liftdefl)

lemma typedef_DEFL:
  assumes "defl \<equiv> (\<lambda>a::'a::pcpo itself. t)"
  shows "DEFL('a::pcpo) = t"
unfolding assms ..

text \<open>Restore original typing constraints.\<close>

setup \<open>
  fold Sign.add_const_constraint
   [(\<^const_name>\<open>defl\<close>, SOME \<^typ>\<open>'a::domain itself \<Rightarrow> udom defl\<close>),
    (\<^const_name>\<open>emb\<close>, SOME \<^typ>\<open>'a::domain \<rightarrow> udom\<close>),
    (\<^const_name>\<open>prj\<close>, SOME \<^typ>\<open>udom \<rightarrow> 'a::domain\<close>),
    (\<^const_name>\<open>liftdefl\<close>, SOME \<^typ>\<open>'a::predomain itself \<Rightarrow> udom u defl\<close>),
    (\<^const_name>\<open>liftemb\<close>, SOME \<^typ>\<open>'a::predomain u \<rightarrow> udom u\<close>),
    (\<^const_name>\<open>liftprj\<close>, SOME \<^typ>\<open>udom u \<rightarrow> 'a::predomain u\<close>)]
\<close>

ML_file \<open>Tools/domaindef.ML\<close>

subsection \<open>Isomorphic deflations\<close>

definition isodefl :: "('a \<rightarrow> 'a) \<Rightarrow> udom defl \<Rightarrow> bool"
  where "isodefl d t \<longleftrightarrow> cast\<cdot>t = emb oo d oo prj"

definition isodefl' :: "('a::predomain \<rightarrow> 'a) \<Rightarrow> udom u defl \<Rightarrow> bool"
  where "isodefl' d t \<longleftrightarrow> cast\<cdot>t = liftemb oo u_map\<cdot>d oo liftprj"

lemma isodeflI: "(\<And>x. cast\<cdot>t\<cdot>x = emb\<cdot>(d\<cdot>(prj\<cdot>x))) \<Longrightarrow> isodefl d t"
unfolding isodefl_def by (simp add: cfun_eqI)

lemma cast_isodefl: "isodefl d t \<Longrightarrow> cast\<cdot>t = (\<Lambda> x. emb\<cdot>(d\<cdot>(prj\<cdot>x)))"
unfolding isodefl_def by (simp add: cfun_eqI)

lemma isodefl_strict: "isodefl d t \<Longrightarrow> d\<cdot>\<bottom> = \<bottom>"
unfolding isodefl_def
by (drule cfun_fun_cong [where x="\<bottom>"], simp)

lemma isodefl_imp_deflation:
  fixes d :: "'a \<rightarrow> 'a"
  assumes "isodefl d t" shows "deflation d"
proof
  note assms [unfolded isodefl_def, simp]
  fix x :: 'a
  show "d\<cdot>(d\<cdot>x) = d\<cdot>x"
    using cast.idem [of t "emb\<cdot>x"] by simp
  show "d\<cdot>x \<sqsubseteq> x"
    using cast.below [of t "emb\<cdot>x"] by simp
qed

lemma isodefl_ID_DEFL: "isodefl (ID :: 'a \<rightarrow> 'a) DEFL('a)"
unfolding isodefl_def by (simp add: cast_DEFL)

lemma isodefl_LIFTDEFL:
  "isodefl' (ID :: 'a \<rightarrow> 'a) LIFTDEFL('a::predomain)"
unfolding isodefl'_def by (simp add: cast_liftdefl u_map_ID)

lemma isodefl_DEFL_imp_ID: "isodefl (d :: 'a \<rightarrow> 'a) DEFL('a) \<Longrightarrow> d = ID"
unfolding isodefl_def
apply (simp add: cast_DEFL)
apply (simp add: cfun_eq_iff)
apply (rule allI)
apply (drule_tac x="emb\<cdot>x" in spec)
apply simp
done

lemma isodefl_bottom: "isodefl \<bottom> \<bottom>"
unfolding isodefl_def by (simp add: cfun_eq_iff)

lemma adm_isodefl:
  "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. isodefl (f x) (g x))"
unfolding isodefl_def by simp

lemma isodefl_lub:
  assumes "chain d" and "chain t"
  assumes "\<And>i. isodefl (d i) (t i)"
  shows "isodefl (\<Squnion>i. d i) (\<Squnion>i. t i)"
using assms unfolding isodefl_def
by (simp add: contlub_cfun_arg contlub_cfun_fun)

lemma isodefl_fix:
  assumes "\<And>d t. isodefl d t \<Longrightarrow> isodefl (f\<cdot>d) (g\<cdot>t)"
  shows "isodefl (fix\<cdot>f) (fix\<cdot>g)"
unfolding fix_def2
apply (rule isodefl_lub, simp, simp)
apply (induct_tac i)
apply (simp add: isodefl_bottom)
apply (simp add: assms)
done

lemma isodefl_abs_rep:
  fixes abs and rep and d
  assumes DEFL: "DEFL('b) = DEFL('a)"
  assumes abs_def: "(abs :: 'a \<rightarrow> 'b) \<equiv> prj oo emb"
  assumes rep_def: "(rep :: 'b \<rightarrow> 'a) \<equiv> prj oo emb"
  shows "isodefl d t \<Longrightarrow> isodefl (abs oo d oo rep) t"
unfolding isodefl_def
by (simp add: cfun_eq_iff assms prj_emb_prj emb_prj_emb)

lemma isodefl'_liftdefl_of: "isodefl d t \<Longrightarrow> isodefl' d (liftdefl_of\<cdot>t)"
unfolding isodefl_def isodefl'_def
by (simp add: cast_liftdefl_of u_map_oo liftemb_eq liftprj_eq)

lemma isodefl_sfun:
  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
    isodefl (sfun_map\<cdot>d1\<cdot>d2) (sfun_defl\<cdot>t1\<cdot>t2)"
apply (rule isodeflI)
apply (simp add: cast_sfun_defl cast_isodefl)
apply (simp add: emb_sfun_def prj_sfun_def)
apply (simp add: sfun_map_map isodefl_strict)
done

lemma isodefl_ssum:
  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
    isodefl (ssum_map\<cdot>d1\<cdot>d2) (ssum_defl\<cdot>t1\<cdot>t2)"
apply (rule isodeflI)
apply (simp add: cast_ssum_defl cast_isodefl)
apply (simp add: emb_ssum_def prj_ssum_def)
apply (simp add: ssum_map_map isodefl_strict)
done

lemma isodefl_sprod:
  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
    isodefl (sprod_map\<cdot>d1\<cdot>d2) (sprod_defl\<cdot>t1\<cdot>t2)"
apply (rule isodeflI)
apply (simp add: cast_sprod_defl cast_isodefl)
apply (simp add: emb_sprod_def prj_sprod_def)
apply (simp add: sprod_map_map isodefl_strict)
done

lemma isodefl_prod:
  "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
    isodefl (prod_map\<cdot>d1\<cdot>d2) (prod_defl\<cdot>t1\<cdot>t2)"
apply (rule isodeflI)
apply (simp add: cast_prod_defl cast_isodefl)
apply (simp add: emb_prod_def prj_prod_def)
apply (simp add: prod_map_map cfcomp1)
done

lemma isodefl_u:
  "isodefl d t \<Longrightarrow> isodefl (u_map\<cdot>d) (u_defl\<cdot>t)"
apply (rule isodeflI)
apply (simp add: cast_u_defl cast_isodefl)
apply (simp add: emb_u_def prj_u_def liftemb_eq liftprj_eq u_map_map)
done

lemma isodefl_u_liftdefl:
  "isodefl' d t \<Longrightarrow> isodefl (u_map\<cdot>d) (u_liftdefl\<cdot>t)"
apply (rule isodeflI)
apply (simp add: cast_u_liftdefl isodefl'_def)
apply (simp add: emb_u_def prj_u_def liftemb_eq liftprj_eq)
done

lemma encode_prod_u_map:
  "encode_prod_u\<cdot>(u_map\<cdot>(prod_map\<cdot>f\<cdot>g)\<cdot>(decode_prod_u\<cdot>x))
    = sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>g)\<cdot>x"
unfolding encode_prod_u_def decode_prod_u_def
apply (case_tac x, simp, rename_tac a b)
apply (case_tac a, simp, case_tac b, simp, simp)
done

lemma isodefl_prod_u:
  assumes "isodefl' d1 t1" and "isodefl' d2 t2"
  shows "isodefl' (prod_map\<cdot>d1\<cdot>d2) (prod_liftdefl\<cdot>t1\<cdot>t2)"
using assms unfolding isodefl'_def
unfolding liftemb_prod_def liftprj_prod_def
by (simp add: cast_prod_liftdefl cfcomp1 encode_prod_u_map sprod_map_map)

lemma encode_cfun_map:
  "encode_cfun\<cdot>(cfun_map\<cdot>f\<cdot>g\<cdot>(decode_cfun\<cdot>x))
    = sfun_map\<cdot>(u_map\<cdot>f)\<cdot>g\<cdot>x"
unfolding encode_cfun_def decode_cfun_def
apply (simp add: sfun_eq_iff cfun_map_def sfun_map_def)
apply (rule cfun_eqI, rename_tac y, case_tac y, simp_all)
done

lemma isodefl_cfun:
  assumes "isodefl (u_map\<cdot>d1) t1" and "isodefl d2 t2"
  shows "isodefl (cfun_map\<cdot>d1\<cdot>d2) (sfun_defl\<cdot>t1\<cdot>t2)"
using isodefl_sfun [OF assms] unfolding isodefl_def
by (simp add: emb_cfun_def prj_cfun_def cfcomp1 encode_cfun_map)

subsection \<open>Setting up the domain package\<close>

named_theorems domain_defl_simps "theorems like DEFL('a t) = t_defl$DEFL('a)"
  and domain_isodefl "theorems like isodefl d t ==> isodefl (foo_map$d) (foo_defl$t)"

ML_file \<open>Tools/Domain/domain_isomorphism.ML\<close>
ML_file \<open>Tools/Domain/domain_axioms.ML\<close>
ML_file \<open>Tools/Domain/domain.ML\<close>

lemmas [domain_defl_simps] =
  DEFL_cfun DEFL_sfun DEFL_ssum DEFL_sprod DEFL_prod DEFL_u
  liftdefl_eq LIFTDEFL_prod u_liftdefl_liftdefl_of

lemmas [domain_map_ID] =
  cfun_map_ID sfun_map_ID ssum_map_ID sprod_map_ID prod_map_ID u_map_ID

lemmas [domain_isodefl] =
  isodefl_u isodefl_sfun isodefl_ssum isodefl_sprod
  isodefl_cfun isodefl_prod isodefl_prod_u isodefl'_liftdefl_of
  isodefl_u_liftdefl

lemmas [domain_deflation] =
  deflation_cfun_map deflation_sfun_map deflation_ssum_map
  deflation_sprod_map deflation_prod_map deflation_u_map

setup \<open>
  fold Domain_Take_Proofs.add_rec_type
    [(\<^type_name>\<open>cfun\<close>, [true, true]),
     (\<^type_name>\<open>sfun\<close>, [true, true]),
     (\<^type_name>\<open>ssum\<close>, [true, true]),
     (\<^type_name>\<open>sprod\<close>, [true, true]),
     (\<^type_name>\<open>prod\<close>, [true, true]),
     (\<^type_name>\<open>u\<close>, [true])]
\<close>

end