           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2008         |
            |                   June 2008  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_semantics
imports CSP.Trace_op CSP.CSP_syntax Domain_T_cms

begin

(*****************************************************************

         1. semantic clause
         2.
         3.
         4.

 *****************************************************************)

(*********************************************************
                    semantic clause
 *********************************************************)

primrec
  traces  :: "('p,'a) proc => ('p => 'a domT) => ('a domT)"
where
  "traces(STOP)   = (%M. {<>}t)"
 |"traces(SKIP)   = (%M. {<>, <Tick>}t)"
 |"traces(DIV)    = (%M. {<>}t)"
 |"traces(a -> P) = (%M. {t. t = <> | (EX s. t = <Ev a> ^^^ s & s :t traces(P) M) }t)"

 |"traces(? :X -> Pf) = (%M. {t. t = <> |
                             (EX a s. t = <Ev a> ^^^ s & s :t traces(Pf a) M & a : X) }t)"

 |"traces(P [+] Q) = (%M. traces(P) M UnT traces(Q) M)"
 |"traces(P |~| Q) = (%M. traces(P) M UnT traces(Q) M)"
 |"traces(!! :C .. Pf) = (%M. {t. t = <> |
                               (EX c : sumset C. t :t traces(Pf c) M) }t)"

 |"traces(IF b THEN P ELSE Q) = (%M. (if b then traces(P) M else traces(Q) M))"

 |"traces(P |[X]| Q) = (%M. {u. EX s t. u : s |[X]|tr t &
                                  s :t traces(P) M & t :t traces(Q) M }t)"
 |"traces(P -- X)    = (%M. {t. EX s. t = s --tr X & s :t traces(P) M }t)"

 |"traces(P [[r]])   = (%M. {t. EX s. s [[r]]* t & s :t traces(P) M }t)"

 |"traces(P ;; Q)    = (%M. {u. (EX s. u = rmTick s & s :t traces(P) M ) |
                             (EX s t. u = s ^^^ t & s ^^^ <Tick> :t traces(P) M &
                                      t :t traces(Q) M & noTick s) }t)"
 |"traces(P |. n)    = (%M. traces(P) M .|. n)"
 |"traces($p)        = (%M. M p)"

declare traces.simps [simp del]

(*** for dealing with both !nat and !set ***)

lemma traces_inv_inj[simp]:
   "inj f ==> (EX c. (EX n. c = f n & n : N) & t :t traces (Pf (inv f c)) x)
            = (EX z:N. t :t traces (Pf z) x)"
by (auto)

lemma Rep_int_choice_traces_nat:
  "traces(!nat :N .. Pf) = (%M. {t. t = <> | (EX n:N. t :t traces(Pf n) M) }t)"
apply (simp add: Rep_int_choice_ss_def)
apply (simp add: traces.simps)
done

lemma Rep_int_choice_traces_set:
  "traces(!set :Xs .. Pf) = (%M. {t. t = <> | (EX X:Xs. t :t traces(Pf X) M) }t)"
apply (simp add: Rep_int_choice_ss_def)
apply (simp add: traces.simps)
done

(* contents \<longrightarrow> the_elem *)

lemma Rep_int_choice_traces_com_lm:
   "(EX z. (EX a. z = {a} & a : X) & t :t traces (Pf (the_elem z)) M)
    = (EX a:X. t :t traces (Pf a) M)"
apply (auto)
apply (rule_tac x="{a}" in exI)
apply (auto)
done

lemma Rep_int_choice_traces_com:
  "traces(! :X .. Pf) = (%M. {t. t = <> | (EX a:X. t :t traces(Pf a) M) }t)"
apply (simp add: Rep_int_choice_com_def)
apply (simp add: Rep_int_choice_traces_set)
apply (simp add: Rep_int_choice_traces_com_lm)
done

lemma Rep_int_choice_traces_f:
  "inj f ==> traces(!<f> :X .. Pf) = (%M. {t. t = <> | (EX a:X. t :t traces(Pf a) M) }t)"
apply (simp add: Rep_int_choice_f_def)
apply (simp add: Rep_int_choice_traces_com)
done

lemmas Rep_int_choice_traces =
       Rep_int_choice_traces_nat
       Rep_int_choice_traces_set
       Rep_int_choice_traces_com
       Rep_int_choice_traces_f

lemmas traces_iff = traces.simps Rep_int_choice_traces

(*==================================================================*
                            traces model
 *==================================================================*)

lemma traces_Int_choice_Ext_choice: "traces(P |~| Q) = traces(P [+] Q)"
(* apply (simp add: expand_fun_eq) *)
apply (simp add: fun_eq_iff)
by (simp add: traces_iff)

(*************************************************************
                   set of length of traces+
  lengthset is related to Depth restriction operator (P |. n)
 *************************************************************)

definition
  lengthset   :: "('p,'a) proc =>  ('p => 'a domT) => nat set"
  where
  lengthset_def:
    "lengthset P == (%M. {n. EX t. t :t traces P M &
                      (n = lengtht t | n = Suc (lengtht t) & noTick t)})"

(*********************************************************
                     semantics
 *********************************************************)

(*** M-parametarized semantics ***)

definition
  semTf  :: "('p,'a) proc => ('p => 'a domT) => 'a domT" ("[[_]]Tf")
  where
  semTf_def : "[[P]]Tf == (%M. traces(P) M)"

definition
  semTfun  :: "('p => ('p,'a) proc) =>  ('p => 'a domT) => ('p => 'a domT)"
                                                         ("[[_]]Tfun")
  where
  semTfun_def : "[[Pf]]Tfun == (%M. %p. [[Pf p]]Tf M)"

(*
notation (xsymbols) semTf   ("\<lbrakk>_\<rbrakk>Tf")
notation (xsymbols) semTfun ("\<lbrakk>_\<rbrakk>Tfun")
*)

(*** relation ***)

lemma semTf_semTfun:
  "(%p. [[Pf p]]Tf M) = [[Pf]]Tfun M"
by (simp add: semTfun_def semTf_def)

lemma traces_semTfun:
  "(%p. traces (Pf p) M) = [[Pf]]Tfun M"
by (simp add: semTfun_def semTf_def)

(*------------------------------------------------------------------*
        M such that [[p]]T M = [[PNfun(p)]]T M
   such M is the fixed point of the function [[PNfun(p)]]Tfun
 *------------------------------------------------------------------*)

definition
  semTfix  :: "('p => ('p,'a) proc) => ('p => 'a domT)"      ("[[_]]Tfix")
  where
  semTfix_def :
   "[[Pf]]Tfix == (if (FPmode = CMSmode) then (UFP ([[Pf]]Tfun))
                                         else (LFP ([[Pf]]Tfun)))"
(*
notation (xsymbols) semTfix ("\<lbrakk>_\<rbrakk>Tfix")
*)

definition
  MT :: "('p => 'a domT)"
  where
  MT_def : "MT == [[PNfun]]Tfix"

(*** semantics ***)

definition
  semT  :: "('p,'a) proc => 'a domT"      ("[[_]]T")
  where
  semT_def : "[[P]]T == [[P]]Tf MT"

(*
notation (xsymbols) semT ("\<lbrakk>_\<rbrakk>T")
*)

(*********************************************************
              relations over processes
 *********************************************************)

definition
  refT :: "('p,'a) proc => ('p => 'a domT) =>
           ('q => 'a domT) => ('q,'a) proc => bool"
                               ("(0_ /<=T[_,_] /_)" [51,0,0,50] 50)
  where
  refT_def : "P1 <=T[M1,M2] P2 == [[P2]]Tf M2 <= [[P1]]Tf M1"

definition
  eqT :: "('p,'a) proc => ('p => 'a domT) =>
           ('q => 'a domT) => ('q,'a) proc => bool"
                               ("(0_ /=T[_,_] /_)" [51,0,0,50] 50)
  where
  eqT_def  : "P1  =T[M1,M2] P2 == [[P1]]Tf M1  = [[P2]]Tf M2"

(*------------------------------------*
 |              X-Symbols             |
 *------------------------------------*)
(*
notation (xsymbols) refT ("(0_ /\<sqsubseteq>T[_,_] /_)" [51,0,0,50] 50)
*)
(*********************************************************
        relations over processes (fixed point)
 *********************************************************)

abbreviation
 refTfix :: "('p,'a) proc => ('q,'a) proc => bool" ("(0_ /<=T /_)" [51,50] 50)
 where "P1 <=T P2 == P1 <=T[MT,MT] P2"

abbreviation
 eqTfix :: "('p,'a) proc => ('q,'a) proc => bool"  ("(0_ /=T /_)" [51,50] 50)
 where "P1  =T P2 == P1  =T[MT,MT] P2"

(* =T and <=T *)

lemma refT_semT: "P1 <=T P2 == [[P2]]T <= [[P1]]T"
apply (simp add: refT_def)
apply (simp add: semT_def)
done

lemma eqT_semT: "P1 =T P2 == [[P1]]T = [[P2]]T"
apply (simp add: eqT_def)
apply (simp add: semT_def)
done

(*------------------------------------*
 |              X-Symbols             |
 *------------------------------------*)

(*
notation (xsymbols) refTfix ("(0_ /\<sqsubseteq>T /_)" [51,50] 50)
*)

(*------------------*
 |      csp law     |
 *------------------*)

(*** semantics ***)

lemma cspT_eqT_semantics:
  "(P =T[M1,M2] Q) = (traces P M1 = traces Q M2)"
by (simp add: eqT_def semT_def semTf_def)

lemma cspT_refT_semantics:
  "(P <=T[M1,M2] Q) = (traces Q M2 <= traces P M1)"
by (simp add: refT_def semT_def semTf_def)

lemmas cspT_semantics = cspT_eqT_semantics  cspT_refT_semantics

(*** eq and ref ***)

lemma cspT_eq_ref_iff:
  "(P1 =T[M1,M2] P2) = (P1 <=T[M1,M2] P2 & P2 <=T[M2,M1] P1)"
by (auto simp add: refT_def eqT_def intro:order_antisym)

lemma cspT_eq_ref:
  "P1 =T[M1,M2] P2 ==> P1 <=T[M1,M2] P2"
by (simp add: cspT_eq_ref_iff)

lemma cspT_ref_eq:
  "[| P1 <=T[M1,M2] P2 ; P2 <=T[M2,M1] P1 |] ==> P1 =T[M1,M2] P2"
by (simp add: cspT_eq_ref_iff)

(*** reflexivity ***)

lemma cspT_reflex_eq_P[simp]: "P =T[M,M] P"
by (simp add: eqT_def)

lemma cspT_reflex_eq_STOP[simp]: "STOP =T[M1,M2] STOP"
apply (simp add: cspT_semantics)
apply (simp add: traces_iff)
done

lemma cspT_reflex_eq_SKIP[simp]: "SKIP =T[M1,M2] SKIP"
apply (simp add: cspT_semantics)
apply (simp add: traces_iff)
done

lemma cspT_reflex_eq_DIV[simp]: "DIV =T[M1,M2] DIV"
apply (simp add: cspT_semantics)
apply (simp add: traces_iff)
done

lemmas cspT_reflex_eq = cspT_reflex_eq_P
                        cspT_reflex_eq_STOP
                        cspT_reflex_eq_SKIP
                        cspT_reflex_eq_DIV

lemma cspT_reflex_ref_P[simp]: "P <=T[M,M] P"
by (simp add: refT_def)

lemma cspT_reflex_ref_STOP[simp]: "STOP <=T[M1,M2] STOP"
apply (simp add: cspT_semantics)
apply (simp add: traces_iff)
done

lemma cspT_reflex_ref_SKIP[simp]: "SKIP <=T[M1,M2] SKIP"
apply (simp add: cspT_semantics)
apply (simp add: traces_iff)
done

lemma cspT_reflex_ref_DIV[simp]: "DIV <=T[M1,M2] DIV"
apply (simp add: cspT_semantics)
apply (simp add: traces_iff)
done

lemmas cspT_reflex_ref = cspT_reflex_ref_P
                         cspT_reflex_ref_STOP
                         cspT_reflex_ref_SKIP
                         cspT_reflex_ref_DIV

lemmas cspT_reflex = cspT_reflex_eq cspT_reflex_ref

(*** symmetry ***)

lemma cspT_sym: "P1 =T[M1,M2] P2 ==> P2 =T[M2,M1] P1"
by (simp add: eqT_def)

lemma cspT_symE:
  "[| P1 =T[M1,M2] P2 ; P2 =T[M2,M1] P1 ==> Z |] ==> Z"
by (simp add: eqT_def)

(*** transitivity ***)

lemma cspT_trans_left_eq:
  "[| P1 =T[M1,M2] P2 ; P2 =T[M2,M3] P3 |] ==> P1 =T[M1,M3] P3"
by (simp add: eqT_def)

lemma cspT_trans_left_ref:
  "[| P1 <=T[M1,M2] P2 ; P2 <=T[M2,M3] P3 |] ==> P1 <=T[M1,M3] P3"
by (simp add: refT_def)

lemmas cspT_trans_left = cspT_trans_left_eq cspT_trans_left_ref
lemmas cspT_trans = cspT_trans_left

lemma cspT_trans_right_eq:
  "[| P2 =T[M2,M3] P3 ; P1 =T[M1,M2] P2 |] ==> P1 =T[M1,M3] P3"
by (simp add: eqT_def)

lemma cspT_trans_right_ref:
  "[| P2 <=T[M2,M3] P3 ;  P1 <=T[M1,M2] P2 |] ==> P1 <=T[M1,M3] P3"
by (simp add: refT_def)

lemmas cspT_trans_right = cspT_trans_right_eq cspT_trans_right_ref

(*** rewrite (eq) ***)

lemma cspT_rw_left_eq_MT:
  "[| P1 =T P2 ; P2 =T P3 |] ==> P1 =T P3"
by (simp add: eqT_def)

lemma cspT_rw_left_eq:
  "[| P1 =T[M1,M1] P2 ; P2 =T[M1,M3] P3 |] ==> P1 =T[M1,M3] P3"
by (simp add: eqT_def)

lemma cspT_rw_left_ref_MT:
  "[| P1 =T P2 ; P2 <=T P3 |] ==> P1 <=T P3"
by (simp add: refT_def eqT_def)

lemma cspT_rw_left_ref:
  "[| P1 =T[M1,M1] P2 ; P2 <=T[M1,M3] P3 |] ==> P1 <=T[M1,M3] P3"
by (simp add: refT_def eqT_def)

lemmas cspT_rw_left =
   cspT_rw_left_eq_MT cspT_rw_left_ref_MT
   cspT_rw_left_eq cspT_rw_left_ref

lemma cspT_rw_right_eq:
  "[| P3 =T[M3,M3] P2 ; P1 =T[M1,M3] P2 |] ==> P1 =T[M1,M3] P3"
by (simp add: eqT_def)

lemma cspT_rw_right_eq_MT:
  "[| P3 =T P2 ; P1 =T P2 |] ==> P1 =T P3"
by (simp add: eqT_def)

lemma cspT_rw_right_ref:
  "[| P3 =T[M3,M3] P2 ; P1 <=T[M1,M3] P2 |] ==> P1 <=T[M1,M3] P3"
by (simp add: refT_def eqT_def)

lemma cspT_rw_right_ref_MT:
  "[| P3 =T P2 ; P1 <=T P2 |] ==> P1 <=T P3"
by (simp add: refT_def eqT_def)

lemmas cspT_rw_right =
   cspT_rw_right_eq_MT cspT_rw_right_ref_MT
   cspT_rw_right_eq cspT_rw_right_ref

(*** rewrite (ref) ***)

lemma cspT_tr_left_eq:
   "[| P1 =T[M1,M1] P2 ; P2 =T[M1,M3] P3 |] ==> P1 =T[M1,M3] P3"
by (simp add: eqT_def)

lemma cspT_tr_left_ref:
   "[| P1 <=T[M1,M1] P2 ; P2 <=T[M1,M3] P3 |] ==> P1 <=T[M1,M3] P3"
by (simp add: refT_def eqT_def)

lemmas cspT_tr_left = cspT_tr_left_eq cspT_tr_left_ref

lemma cspT_tr_right_eq:
   "[| P2 =T[M3,M3] P3 ; P1 =T[M1,M3] P2 |] ==> P1 =T[M1,M3] P3"
by (simp add: eqT_def)

lemma cspT_tr_right_ref:
  "[| P2 <=T[M3,M3] P3 ; P1 <=T[M1,M3] P2 |] ==> P1 <=T[M1,M3] P3"
by (simp add: refT_def eqT_def)

lemmas cspT_tr_right = cspT_tr_right_eq cspT_tr_right_ref

(*----------------------------------------*
 |   rewriting processes in assumptions   |
 *----------------------------------------*)

(*** rewrite (eq) ***)

lemma cspT_rw_left_eqE_MF:
  "[| P1 =T P3 ; P1 =T P2 ; [| P2 =T P3 |] ==> R |] ==> R"
apply (subgoal_tac "P2 =T P3")
apply (simp)
apply (rule cspT_rw_left)
apply (rule cspT_sym)
apply (simp)
apply (simp)
done

lemma cspT_rw_left_eqE:
  "[| P1 =T[M1,M3] P3 ; P1 =T[M1,M1] P2 ;
      [| P2 =T[M1,M3] P3 |] ==> R |] ==> R"
apply (subgoal_tac "P2 =T[M1,M3] P3")
apply (simp)
apply (rule cspT_rw_left)
apply (rule cspT_sym)
apply (simp)
apply (simp)
done

lemma cspT_rw_left_refE_MF:
  "[| P1 <=T P3 ; P1 =T P2 ; [| P2 <=T P3 |] ==> R |] ==> R"
apply (subgoal_tac "P2 <=T P3")
apply (simp)
apply (rule cspT_rw_left)
apply (rule cspT_sym)
apply (simp)
apply (simp)
done

lemma cspT_rw_left_refE:
  "[| P1 <=T[M1,M3] P3 ; P1 =T[M1,M1] P2 ;
      [| P2 <=T[M1,M3] P3 |] ==> R |] ==> R"
apply (subgoal_tac "P2 <=T[M1,M3] P3")
apply (simp)
apply (rule cspT_rw_left)
apply (rule cspT_sym)
apply (simp)
apply (simp)
done

lemmas cspT_rw_leftE =
   cspT_rw_left_eqE_MF cspT_rw_left_refE_MF
   cspT_rw_left_eqE    cspT_rw_left_refE

(* right *)

lemma cspT_rw_right_eqE_MF:
  "[| P1 =T P3 ; P3 =T P2 ; [| P1 =T P2 |] ==> R |] ==> R"
apply (subgoal_tac "P1 =T P2")
apply (simp)
apply (rule cspT_rw_right)
apply (rule cspT_sym)
apply (simp)
apply (simp)
done

lemma cspT_rw_right_eqE:
  "[| P1 =T[M1,M3] P3 ; P3 =T[M3,M3] P2 ;
      [| P1 =T[M1,M3] P2 |] ==> R |] ==> R"
apply (subgoal_tac "P1 =T[M1,M3] P2")
apply (simp)
apply (rule cspT_rw_right)
apply (rule cspT_sym)
apply (simp)
apply (simp)
done

lemma cspT_rw_right_refE_MF:
  "[| P1 <=T P3 ; P3 =T P2 ; [| P1 <=T P2 |] ==> R |] ==> R"
apply (subgoal_tac "P1 <=T P2")
apply (simp)
apply (rule cspT_rw_right)
apply (rule cspT_sym)
apply (simp)
apply (simp)
done

lemma cspT_rw_right_refE:
  "[| P1 <=T[M1,M3] P3 ; P3 =T[M3,M3] P2 ;
      [| P1 <=T[M1,M3] P2 |] ==> R |] ==> R"
apply (subgoal_tac "P1 <=T[M1,M3] P2")
apply (simp)
apply (rule cspT_rw_right)
apply (rule cspT_sym)
apply (simp)
apply (simp)
done

lemmas cspT_rw_rightE =
   cspT_rw_right_eqE_MF cspT_rw_right_refE_MF
   cspT_rw_right_eqE    cspT_rw_right_refE

(*-----------------------------------------*
 |                   noPN                  |
 *-----------------------------------------*)

 (* lemma "\<lbrakk> ? :s -> f = P \<rbrakk> \<Longrightarrow> range f = UNIV" *)

lemma traces_noPN_Constant_lm_EC:
  "[| ALL P:range Pf. (EX T. traces P = (%M. T)) |]
       ==> (EX T2. traces (? :X -> Pf) = (%M. T2))"
apply (auto simp add: traces_iff)
apply (simp add: choice_ALL_EX)
apply (erule exE)
apply (auto)
done

lemma traces_noPN_Constant_lm_RIC:
  "[| ALL P:range Pf. (EX T. traces P = (%M. T)) |]
   ==> (EX T2. traces (!! :X .. Pf) = (%M. T2))"
apply (auto simp add: traces_iff)
apply (simp add: choice_ALL_EX)
apply (erule exE)
apply (auto)
done

lemma traces_noPN_Constant_lm:
  "noPN P --> (EX T. traces P = (%M. T))"

apply (induct_tac P)
apply (simp add: traces_iff, force)
apply (simp add: traces_iff, force)
apply (simp add: traces_iff, force)
apply (simp add: traces_iff, force)

(* Ext_pre_choice *)
apply (simp add: traces_noPN_Constant_lm_EC)

(* Isabelle 2013
(* apply (subgoal_tac "ALL x. EX T. traces (fun2 x) = (%M. T)") isabelle 2011 *)
 apply (subgoal_tac "ALL x. EX T. traces (fun x) = (%M. T)")
 apply (simp add: choice_ALL_EX)
 apply (erule exE)
 apply (simp add: traces_iff)
 apply (force)
 apply (simp)

*)
apply (simp add: traces_iff, force)
apply (simp add: traces_iff, force)

(* Rep_int_choice *)
apply (simp add: traces_noPN_Constant_lm_RIC)

(* Isabelle 2013
apply (intro impI)
 apply (simp)
 apply (subgoal_tac "ALL x. EX T. traces (fun x) = (%M. T)")
  apply (simp add: choice_ALL_EX)
 apply (erule exE)
apply (simp add: traces_iff)
apply (force)
apply (simp)
*)

(* IF *)
 apply (simp add: traces_iff)
 apply (case_tac "x1")
 apply (simp)
 apply (simp)

apply (simp add: traces_iff, force)
apply (simp add: traces_iff, force)
apply (simp add: traces_iff, force)
apply (simp add: traces_iff, force)
apply (simp add: traces_iff, force)
apply (simp add: traces_iff)
done

lemma traces_noPN_Constant:
  "noPN P ==> (EX T. traces P = (%M. T))"
apply (simp add: traces_noPN_Constant_lm)
done

(*-----------------------------------------*
 |              substitution               |
 *-----------------------------------------*)

lemma semT_subst:
  "[[P<<f]]T = [[P]]Tf (%q. [[f q]]T)"
apply (induct_tac P)
apply (simp_all add: semT_def semTf_def traces_iff)
done

lemma semT_subst_semTfun:
  "(%q. [[ (Pf q)<<f ]]T) = ([[Pf]]Tfun (%q. [[f q]]T))"
apply (simp add: semTfun_def)
apply (simp add: fun_eq_iff)
apply (rule allI)
apply (simp add: semT_subst)
done

lemma traces_subst:
  "traces(P<<f) M = traces P (%q. traces(f q) M)"
apply (induct_tac P)
apply (simp_all add: semT_def traces_iff)
done

end


theory TickTock_Max_TT1

imports
  "TickTock.TickTock_Core"
  TickTock_Max_FL
begin

text \<open> This theory consists in the definition of a Galois connection between
       tick-tock (that is TT-healthy, and so TT1-healthy) and the superset
       that is not TT1-healhty, where refusals are maximal. \<close>

section \<open> From Maximal Refusals to subset-closed traces of tick-tock. \<close>

subsection \<open> Closure properties of mkTT1 \<close>

lemma TT2w_mkTT1_part:
  assumes "Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>\<sigma>. \<rho> @ [[e]\<^sub>E] \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P) \<or> e = Tock \<and> (\<exists>\<sigma>. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P)} = {}"
          "\<rho> @ [[X]\<^sub>R] \<lesssim>\<^sub>C \<sigma>" "\<sigma> \<in> P" "TT1w P" "TTwf P" "TTM1 P" "TTM2 P" "TT2w P"
    shows "\<exists>\<sigma>. \<rho> @ [[X \<union> Y]\<^sub>R] \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P"
proof -
  have "size (\<rho> @ [[X]\<^sub>R]) \<le> size \<sigma>"
    apply auto
    using assms tt_prefix_subset_length by fastforce
  then obtain \<rho>\<^sub>2 X\<^sub>2 z where X2:"\<sigma> = \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] @ z \<and> X \<subseteq> X\<^sub>2 \<and> \<rho> \<lesssim>\<^sub>C \<rho>\<^sub>2 \<and> size (\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R]) = size (\<rho> @ [[X]\<^sub>R]) \<and> (\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] @ z) \<in> P"
    using assms(2,3,4)
    ttWF_tt_prefix_subset_exists_three_part_iff
    by (metis TTwf_def assms(5) length_append_singleton)
  then have "\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P"
    by (metis TT1w_prefix_concat_in append.assoc assms(4))
  then have "(\<forall>e. (\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P \<and> e \<notin> X\<^sub>2 \<and> e \<noteq> Tock) \<longrightarrow> \<rho>\<^sub>2 @ [[e]\<^sub>E] \<in> P)"
            "(\<forall>e. (\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P \<and> e \<notin> X\<^sub>2 \<and> e = Tock) \<longrightarrow> \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R,[e]\<^sub>E] \<in> P)"
    using assms by (auto simp add:TTM1_def TTM2_def)
  then have "\<forall>e. (\<rho>\<^sub>2 @ [[e]\<^sub>E] \<notin> P \<and> e \<noteq> Tock) \<longrightarrow> e \<in> X\<^sub>2"
    using assms \<open>\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P\<close> by blast
  then obtain Z where Z:"Z \<inter> {e. (e \<noteq> Tock \<and> \<rho>\<^sub>2 @ [[e]\<^sub>E] \<in> P) \<or> (e = Tock \<and> \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R, [e]\<^sub>E] \<in> P) } = {}"
    by blast
  then have "\<rho>\<^sub>2 @ [[X\<^sub>2 \<union> Z]\<^sub>R] \<in> P"
    using assms by (simp add: TT2w_def \<open>\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P\<close>)
  then have "\<forall>e. \<rho> @ [[e]\<^sub>E] \<lesssim>\<^sub>C \<rho>\<^sub>2 @ [[e]\<^sub>E]"
    by (metis Suc_le_mono X2 antisym_conv tt_prefix_subset_eq_length_common_prefix_eq tt_prefix_subset_length tt_prefix_subset_refl length_append_singleton)
  then have "\<forall>e. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<lesssim>\<^sub>C \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R, [e]\<^sub>E]"
    by (metis X2 tt_prefix_subset.simps(2) tt_prefix_subset_eq_length_common_prefix_eq length_append_singleton nat.simps(1))
  then have "{e. (e \<noteq> Tock \<and> \<rho>\<^sub>2 @ [[e]\<^sub>E] \<in> P) \<or> (e = Tock \<and> \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R, [e]\<^sub>E] \<in> P) }
             \<subseteq>
             {e. e \<noteq> Tock \<and> (\<exists>\<sigma>. \<rho> @ [[e]\<^sub>E] \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P) \<or> e = Tock \<and> (\<exists>\<sigma>. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P)}
             "
    apply auto
    using \<open>\<forall>e. \<rho> @ [[e]\<^sub>E] \<lesssim>\<^sub>C \<rho>\<^sub>2 @ [[e]\<^sub>E]\<close> apply blast
    using \<open>\<forall>e. \<rho> @ [[e]\<^sub>E] \<lesssim>\<^sub>C \<rho>\<^sub>2 @ [[e]\<^sub>E]\<close> by blast
  then have "X \<union> Y \<subseteq> X\<^sub>2 \<union> Z"
    using X2 apply safe
    apply blast (* FIXME: The next step deserves a better understanding. *)
    by (smt CollectI \<open>\<forall>e. \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P \<and> e \<notin> X\<^sub>2 \<and> e = Tock \<longrightarrow> \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R, [e]\<^sub>E] \<in> P\<close> \<open>\<forall>e. \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P \<and> e \<notin> X\<^sub>2 \<and> e \<noteq> Tock \<longrightarrow> \<rho>\<^sub>2 @ [[e]\<^sub>E] \<in> P\<close> \<open>\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P\<close> assms(1) disjoint_iff_not_equal subsetCE)
  then have "\<rho> @ [[X \<union> Y]\<^sub>R] \<lesssim>\<^sub>C \<rho>\<^sub>2 @ [[X\<^sub>2 \<union> Z]\<^sub>R]"
    by (metis X2 tt_prefix_subset.simps(2) tt_prefix_subset_eq_length_common_prefix_eq tt_prefix_subset_refl length_append_singleton nat.simps(1))
  then show ?thesis
    using \<open>\<rho>\<^sub>2 @ [[X\<^sub>2 \<union> Z]\<^sub>R] \<in> P\<close> by blast
qed

abbreviation "TT2P \<rho> X P == {e. e \<noteq> Tock \<and> (\<exists>\<sigma>. \<rho> @ [[e]\<^sub>E] \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P) \<or> e = Tock \<and> (\<exists>\<sigma>. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P)}"

lemma TT2_mkTT1_part:
  assumes "Y \<inter> TT2P \<rho> X P = {}"
          "\<rho> @ [[X]\<^sub>R] @ s \<lesssim>\<^sub>C \<sigma>" "\<sigma> \<in> P" "TT1w P" "TTM1 P" "TTM2 P" "TT2 P"
    shows "\<exists>\<sigma>. \<rho> @ [[X \<union> Y]\<^sub>R] @ s \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P"
proof -
  have "size (\<rho> @ [[X]\<^sub>R]) \<le> size \<sigma>"
    apply auto
    using assms tt_prefix_subset_length by fastforce
  then obtain \<rho>\<^sub>2 X\<^sub>2 z where X2:"\<sigma> = \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] @ z \<and> X \<subseteq> X\<^sub>2 \<and> \<rho> \<lesssim>\<^sub>C \<rho>\<^sub>2 \<and> size (\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R]) = size (\<rho> @ [[X]\<^sub>R]) \<and> (\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] @ z) \<in> P"
    using assms(2,3,4)
    ttWF_tt_prefix_subset_exists_three_part_concat
    by (metis length_append_singleton)
    (* by (metis TTwf_def assms(5) length_append_singleton) *)
  then have "\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] @ z \<in> P"
      "\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P"
    by (metis TT1w_prefix_concat_in append.assoc assms(4))+
  then have "(\<forall>e. (\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P \<and> e \<notin> X\<^sub>2 \<and> e \<noteq> Tock) \<longrightarrow> \<rho>\<^sub>2 @ [[e]\<^sub>E] \<in> P)"
            "(\<forall>e. (\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P \<and> e \<notin> X\<^sub>2 \<and> e = Tock) \<longrightarrow> \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R,[e]\<^sub>E] \<in> P)"
    using assms by (auto simp add:TTM1_def TTM2_def)
  then have "\<forall>e. (\<rho>\<^sub>2 @ [[e]\<^sub>E] \<notin> P \<and> e \<noteq> Tock) \<longrightarrow> e \<in> X\<^sub>2"
    using assms \<open>\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P\<close> by blast
  then obtain Z where Z:"Z \<inter> {e. (e \<noteq> Tock \<and> \<rho>\<^sub>2 @ [[e]\<^sub>E] \<in> P) \<or> (e = Tock \<and> \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R, [e]\<^sub>E] \<in> P) } = {}"
    by blast
  then have "\<rho>\<^sub>2 @ [[X\<^sub>2 \<union> Z]\<^sub>R] @ z \<in> P"
    using assms TT2_def
    by (simp add: TT2_def Z X2)
  then have "\<forall>e. \<rho> @ [[e]\<^sub>E] @ z \<lesssim>\<^sub>C \<rho>\<^sub>2 @ [[e]\<^sub>E] @ z"
    by (metis Suc_le_mono X2 antisym_conv tt_prefix_subset_eq_length_common_prefix_eq tt_prefix_subset_length tt_prefix_subset_refl length_append_singleton)
  then have "\<forall>e. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] @ z \<lesssim>\<^sub>C \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R, [e]\<^sub>E] @ z"
    by (metis X2 append_Cons tt_prefix_subset.simps(2) tt_prefix_subset_eq_length_common_prefix_eq length_append_singleton nat.simps(1))
  then have "{e. (e \<noteq> Tock \<and> \<rho>\<^sub>2 @ [[e]\<^sub>E] \<in> P) \<or> (e = Tock \<and> \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R, [e]\<^sub>E] \<in> P) }
             \<subseteq>
             {e. e \<noteq> Tock \<and> (\<exists>\<sigma>. \<rho> @ [[e]\<^sub>E] \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P) \<or> e = Tock \<and> (\<exists>\<sigma>. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P)}
             "
    apply auto
    apply (metis X2 tt_prefix_subset_eq_length_common_prefix_eq tt_prefix_subset_refl length_append_singleton nat.simps(1))
      apply (metis X2 tt_prefix_subset_eq_length_common_prefix_eq tt_prefix_subset_refl length_append_singleton nat.simps(1))
      apply (metis X2 \<open>\<forall>e. \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] @ z \<lesssim>\<^sub>C \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R, [e]\<^sub>E] @ z\<close> tt_prefix_subset_eq_length_common_prefix_eq length_Cons length_append_singleton nat.simps(1))
      by (metis X2 tt_prefix_subset.simps(2) tt_prefix_subset_eq_length_common_prefix_eq tt_prefix_subset_refl length_append_singleton nat.simps(1))
  then have "X \<union> Y \<subseteq> X\<^sub>2 \<union> Z"
    using X2 apply safe
    apply blast (* FIXME: The next step deserves a better understanding. *)
    by (smt CollectI \<open>\<forall>e. \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P \<and> e \<notin> X\<^sub>2 \<and> e = Tock \<longrightarrow> \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R, [e]\<^sub>E] \<in> P\<close> \<open>\<forall>e. \<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P \<and> e \<notin> X\<^sub>2 \<and> e \<noteq> Tock \<longrightarrow> \<rho>\<^sub>2 @ [[e]\<^sub>E] \<in> P\<close> \<open>\<rho>\<^sub>2 @ [[X\<^sub>2]\<^sub>R] \<in> P\<close> assms(1) disjoint_iff_not_equal subsetCE)
  then have "\<rho> @ [[X \<union> Y]\<^sub>R] @ s \<lesssim>\<^sub>C \<rho>\<^sub>2 @ [[X\<^sub>2 \<union> Z]\<^sub>R] @ s"
    by (metis X2 append_Cons tt_prefix_subset.simps(2) tt_prefix_subset_eq_length_common_prefix_eq tt_prefix_subset_refl length_append_singleton nat.simps(1))
  then show ?thesis
  proof -
    have f1: "\<forall>cs c. [c::'a ttobs] @ cs = c # cs"
    by simp
      have "\<rho> @ [[X]\<^sub>R] @ s \<lesssim>\<^sub>C \<sigma>"
        using assms(2) by force
      then have "s \<lesssim>\<^sub>C z"
        by (metis (no_types) X2 append.assoc tt_prefix_subset_eq_length_common_prefix_eq)
      then show ?thesis
        using f1 by (metis (no_types) X2 \<open>X \<union> Y \<subseteq> X\<^sub>2 \<union> Z\<close> \<open>\<rho>\<^sub>2 @ [[X\<^sub>2 \<union> Z]\<^sub>R] @ z \<in> P\<close> tt_prefix_subset.simps(2) tt_prefix_subset_eq_length_common_prefix_eq length_append_singleton nat.simps(1))
    qed
qed

lemma TT2w_mkTT1:
  assumes "TT2w P" "TT1w P" "TTM1 P" "TTM2 P" "TTwf P"
  shows "TT2w(mkTT1(P))"
proof -
  have "TT2w(mkTT1(P)) = TT2w({\<rho>|\<rho> \<sigma>. \<rho> \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P})"
    by (simp add:mkTT1_simp)
  also have "... = True"
    unfolding TT2w_def apply auto
    using assms by (simp add: TT2w_mkTT1_part)
  finally show ?thesis by auto
qed

lemma TT2_mkTT1:
  assumes "TT2 P" "TT1w P" "TTM1 P" "TTM2 P"
  shows "TT2(mkTT1(P))"
proof -
  have "TT2(mkTT1(P)) = TT2({\<rho>|\<rho> \<sigma>. \<rho> \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P})"
    by (simp add:mkTT1_simp)
  also have "... = True"
    using assms TT2_mkTT1_part unfolding TT2_def apply auto
    by (insert TT2_mkTT1_part, blast)
  then show ?thesis using calculation by auto
qed

section \<open> From subset-closed tick-tock to maximal refusals. \<close>

text \<open> Here the adjoint is defined in terms of mkTT1, undoing as much
       as possible the effect of mkTT1. \<close>

definition unTT1 :: "'e ttobs list set \<Rightarrow> 'e ttobs list set" where
"unTT1 P = \<Union>{x. TTM1 x \<and> TTM2 x \<and> TTM3 x \<and> TT1w x \<and> (mkTT1 x) \<subseteq> P}"

text \<open> Although in this definition we do not use all the healthiness conditions
       of TickTock_Max (as standard for an adjoint of a Galois connection), note
       that an equivalent definition can be obtained for healthy P, that is, when
       applied to tick-tock processes as proved in {@lemma unTT1_alt} in TickTock_FL.thy.

       The fact we do not use the conjunction of all healthiness conditions in {@term unTT1}
       makes it simpler to construct unTT1 results, notably simplifying the proofs
       for the Galois connections. \<close>

lemma unTT1_mono:
  assumes "P \<subseteq> Q"
  shows "unTT1(P) \<subseteq> unTT1(Q)"
  using assms unfolding unTT1_def by auto

subsection \<open> Closure properties \<close>

lemma TTM1_unTT1:
  "TTM1(unTT1 P)"
  unfolding unTT1_def TTM1_def by auto

lemma TTwf_unTT1:
  assumes "TTwf P"
  shows "TTwf(unTT1 P)"
  using assms unfolding unTT1_def TTwf_def apply auto
  using TT1_mkTT1 TT1_mkTT1_simp by blast

lemma TT0_unTT1:
  assumes "TT0 P" "TT1 P"
  shows "TT0(unTT1(P))"
proof -
  have "[] \<in> P"
    using assms TT0_TT1_empty by blast
  then have "[] \<in> unTT1(P)"
    unfolding unTT1_def TT0_def apply auto
    apply (rule_tac x="{[]}" in exI, auto)
    unfolding TTM1_def TTM2_def TTM3_def TT1w_def apply auto
     apply (case_tac \<rho>, auto)
    unfolding mkTT1_def apply auto
    by (case_tac x, auto)
  then have "TT0(unTT1(P))"
    unfolding TT0_def by auto
  then show ?thesis .
qed

lemma TT1w_unTT1:
  "TT1w(unTT1(P))"
  unfolding unTT1_def TT1w_def by auto

lemma TTM1_mkTT3w:
  assumes "TTM1 P" "TTM3 P"
  shows "TTM1 (mkTT3w P)"
  using assms unfolding TTM1_def TTM3_def mkTT3w_def apply auto
  by (metis TTickTrace_eq_add_Tick_refusal_trace_fixpoint)

lemma TTM2_mkTT3w:
  assumes "TTM2 P" "TTM3 P"
  shows "TTM2 (mkTT3w P)"
  using assms unfolding TTM2_def TTM3_def mkTT3w_def apply auto
  by (metis TTickTrace_eq_add_Tick_refusal_trace_fixpoint)

lemma TTM3_mkTT3w:
  assumes "TTM3 P"
  shows "TTM3 (mkTT3w P)"
  using assms unfolding TTM3_def mkTT3w_def apply auto
  by (metis TTickTrace_eq_add_Tick_refusal_trace_fixpoint)

lemma TT1w_mkTT3w:
  assumes "TT1w P"
  shows "TT1w (mkTT3w P)"
  using assms unfolding TT1w_def TTM3_def mkTT3w_def apply auto
  by (smt add_Tick_refusal_trace_concat add_Tick_refusal_trace_tt_subset append_eq_append_conv tt_prefix_decompose tt_prefix_tt_subset tt_subset_same_length)

lemma TT3w_unTT1:
  assumes "TT1 P" "TT3w P"
  shows "TT3w(unTT1(P))"
  using assms unfolding TT3w_def unTT1_def  apply auto
  apply (rule_tac x="mkTT3w(x)" in exI, auto)
  using TTM1_mkTT3w apply blast
  using TTM2_mkTT3w apply blast
  using TTM3_mkTT3w apply blast
  using TT1w_mkTT3w apply blast
   apply (smt TT1_fixpoint_mkTT1 TT1_mkTT1_simp UnE mem_Collect_eq mkTT1_mono mkTT3w_def subsetI)
  unfolding mkTT3w_def by auto

lemma TT2_unTT1_part:
  assumes "TT P"
          "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> unTT1 P \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> unTT1 P} = {}"
          "\<rho> @ [X]\<^sub>R # \<sigma> \<in> unTT1 P"
  shows   "\<rho> @ [[X \<union> Y]\<^sub>R] @ \<sigma> \<in> unTT1 P"
proof -
  obtain x where x:"TTM1 x" "TTM2 x" "TTM3 x" "TT1w x" "mkTT1 x \<subseteq> P" "\<rho> @ [X]\<^sub>R # \<sigma> \<in> x"
    using assms unfolding unTT1_def by auto

  have def1:"(Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> unTT1 P \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> unTT1 P} = {})
              =
             (Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>x. TTM1 x \<and> TTM2 x \<and> TTM3 x \<and> TT1w x \<and> mkTT1 x \<subseteq> P \<and> \<rho> @ [[e]\<^sub>E] \<in> x) \<or>
                 e = Tock \<and> (\<exists>x. TTM1 x \<and> TTM2 x \<and> TTM3 x \<and> TT1w x \<and> mkTT1 x \<subseteq> P \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> x)} = {})"
    unfolding unTT1_def by auto

  have "\<rho> @ [[X]\<^sub>R] \<le>\<^sub>C \<rho> @ [X]\<^sub>R # \<sigma>"
    by (simp add: tt_prefix_same_front)
  then have "\<rho> @ [[X]\<^sub>R] \<in> x"
    using TT1w_def x assms by blast
  then have "\<rho> @ [[X]\<^sub>R] \<in> P"
    using assms x mkTT1_def by fastforce

  have "\<forall>e. (e \<noteq> Tock \<and> e \<in> Y) \<longrightarrow> \<not>(\<exists>x. TTM1 x \<and> TTM2 x \<and> TTM3 x \<and> TT1w x \<and> mkTT1 x \<subseteq> P \<and> \<rho> @ [[e]\<^sub>E] \<in> x)"
    using assms def1 by blast
  then have "\<forall>e. (e \<noteq> Tock \<and> e \<in> Y) \<longrightarrow> \<rho> @ [[e]\<^sub>E] \<notin> x"
    using assms x by blast
  then have "\<forall>e. (e \<noteq> Tock \<and> e \<in> Y) \<longrightarrow> (\<rho> @ [[X]\<^sub>R] \<in> P \<longrightarrow> e \<in> X)"
    using assms x TTM1_def \<open>\<rho> @ [[X]\<^sub>R] \<in> x\<close> by blast
  then have "\<forall>e. (e \<noteq> Tock \<and> e \<in> Y) \<longrightarrow> e \<in> X"
    using \<open>\<rho> @ [[X]\<^sub>R] \<in> P\<close> by blast

  have "\<forall>e. (e = Tock \<and> e \<in> Y) \<longrightarrow> \<not>(\<exists>x. TTM1 x \<and> TTM2 x \<and> TTM3 x \<and> TT1w x \<and> mkTT1 x \<subseteq> P \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> x)"
    using assms def1 by blast
  then have "\<forall>e. (e = Tock \<and> e \<in> Y) \<longrightarrow> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<notin> x"
    using assms x by blast
  then have "\<forall>e. (e = Tock \<and> e \<in> Y) \<longrightarrow> (\<rho> @ [[X]\<^sub>R,[e]\<^sub>E] \<in> P \<longrightarrow> e \<in> X)"
    using TTM2_def \<open>\<rho> @ [[X]\<^sub>R] \<in> x\<close> assms x by auto
  then have "\<forall>e. (e = Tock \<and> e \<in> Y) \<longrightarrow> e \<in> X"
    using TTM2_def \<open>\<forall>e. e = Tock \<and> e \<in> Y \<longrightarrow> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<notin> x\<close> \<open>\<rho> @ [[X]\<^sub>R] \<in> x\<close> assms x by auto

  have "Y \<subseteq> X"
    using \<open>\<forall>e. e = Tock \<and> e \<in> Y \<longrightarrow> e \<in> X\<close> \<open>\<forall>e. e \<noteq> Tock \<and> e \<in> Y \<longrightarrow> e \<in> X\<close> by blast
  then show ?thesis using def1 x unfolding unTT1_def apply auto
    by (metis assms sup.order_iff)
qed

lemma TT2_unTT1:
  assumes "TT P"
  shows "TT2(unTT1(P))"
  using assms unfolding TT2_def apply auto
  using TT2_unTT1_part by fastforce

lemma ttWFx_unTT1:
  assumes "TT1 P" "ttWFx P"
  shows "ttWFx(unTT1(P))"
  using assms unfolding ttWFx_def unTT1_def  apply auto
  using TT1_mkTT1_simp ttWFx_def TT_ttWFx by blast

lemma TTM2_unTT1:
  "TTM2(unTT1(P))"
  unfolding unTT1_def TTM2_def by auto

lemma TTM3_unTT1:
  "TTM3(unTT1(P))"
  unfolding unTT1_def TTM3_def by auto

lemma unTT1_TT_closure:
  assumes "TT P" "TT2 P" "TT3w P"
  shows "TT0 (unTT1 P)"
       "TTwf (unTT1 P)"
       "TT1w (unTT1 P)"
       "TT2 (unTT1 P)"
       "ttWFx (unTT1 P)"
       "TT3w (unTT1 P)"
       "TTM1 (unTT1 P)"
       "TTM2 (unTT1 P)"
       "TTM3 (unTT1 P)"
    using assms TT0_unTT1 TT_def apply blast
    using TTwf_unTT1 TT_def
    using TT_TTwf assms(1) apply blast
    apply (simp add: TT1w_unTT1)
         apply (simp add: TT2_unTT1 assms(1))
        apply (simp add: ttWFx_unTT1 TT_TT1 TT_ttWFx assms(1))
       apply (simp add: TT3w_unTT1 TT_TT1 assms(1) assms(3))
      apply (simp add: TTM1_unTT1)
   apply (simp add: TTM2_unTT1)
    by (simp add: TTM3_unTT1)

lemma mkTT1_TT_closure:
  assumes "TT0 P"
          "TTwf P"
          "TT1w P"
          "TT2 P"
          "ttWFx P"
          "TT3w P"
          "TTM1 P"
          "TTM2 P"
          "TTM3 P"
    shows "TTwf(mkTT1 P)" "TT0(mkTT1 P)" "TT1(mkTT1 P)" "TT2(mkTT1 P)" "ttWFx(mkTT1 P)" "TT3w(mkTT1 P)"
  using assms TTwf_mkTT1 apply blast
  using assms TT0_mkTT1 apply blast
  using assms TT1_mkTT1 apply blast
  using assms TT2_mkTT1 apply blast
  using assms ttWFx_mkTT1 apply blast
  using assms TT3w_mkTT1 by blast

lemma unTT1_subseteq:
  assumes "TT P"
  shows "unTT1 P \<subseteq> P"
  using assms apply (simp add:unTT1_def, auto)
  using TT1_mkTT1 TT1_mkTT1_simp by blast

lemma mkTT1_unTT1_subseteq:
  assumes "TT P"
  shows "mkTT1(unTT1 P) \<subseteq> P"
  by (metis TT1_fixpoint_mkTT1 TT_TT1 assms mkTT1_mono unTT1_subseteq)

lemma less_eq_unTT1_mkTT1:
  assumes "TT0 P"
          "TTwf P"
          "TT1w P"
          "TT2 P"
          "ttWFx P"
          "TT3w P"
          "TTM1 P"
          "TTM2 P"
          "TTM3 P"
  shows "P \<subseteq> unTT1(mkTT1 P)"
  using assms by (simp add:unTT1_def, auto)

end


theory Prelude_Composition
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize [\"Comp\", \"Comp1\"]"

consts
X__o__X :: "('b => 'c) * ('a => 'b) => 'a => 'c"

axioms
Comp [rule_format] :
"ALL f.
 ALL g. makePartial o X__o__X (f, g) = makePartial o (% x. f (g x))"

theorem Comp1 : "ALL f. ALL g. ALL y. X__o__X (f, g) y = f (g y)"
apply(auto)
thm Comp
apply(rule Comp)
by auto

ML "Header.record \"Comp1\""

end


theory Hex
  imports Main HOL.String "HOL-Library.Word"
begin

(* this file is going to contain some miscellaneous tools
such as hex reading/writing *)
definition hexread1_dom :: "char \<Rightarrow> bool" where
"hexread1_dom c = (c = CHR ''0'' \<or> c = CHR ''1'' \<or> c = CHR ''2'' \<or>
                   c = CHR ''3'' \<or> c = CHR ''4'' \<or> c = CHR ''5'' \<or>
                   c = CHR ''6'' \<or> c = CHR ''7'' \<or> c = CHR ''8'' \<or>
                   c = CHR ''9'' \<or> c = CHR ''A'' \<or> c = CHR ''B'' \<or>
                   c = CHR ''D'' \<or> c = CHR ''E'' \<or> c = CHR ''F'' \<or>
                   c = CHR ''a'' \<or> c = CHR ''b'' \<or> c = CHR ''d'' \<or>
                   c = CHR ''e'' \<or> c = CHR ''f'')"

definition hexread1 :: "char \<Rightarrow> nat" where
"hexread1 c = (if c = (CHR ''0'') then 0 else
               if c = (CHR ''1'') then 1 else
               if c = (CHR ''2'') then 2 else
               if c = (CHR ''3'') then 3 else
               if c = (CHR ''4'') then 4 else
               if c = (CHR ''5'') then 5 else
               if c = (CHR ''6'') then 6 else
               if c = (CHR ''7'') then 7 else
               if c = (CHR ''8'') then 8 else
               if c = (CHR ''9'') then 9 else
               if c = (CHR ''A'') then 10 else
               if c = (CHR ''B'') then 11 else
               if c = (CHR ''C'') then 12 else
               if c = (CHR ''D'') then 13 else
               if c = (CHR ''E'') then 14 else
               if c = (CHR ''F'') then 15 else
               if c = (CHR ''a'') then 10 else
               if c = (CHR ''b'') then 11 else
               if c = (CHR ''c'') then 12 else
               if c = (CHR ''d'') then 13 else
               if c = (CHR ''e'') then 14 else
               if c = (CHR ''f'') then 15 else
               undefined)"

definition hexwrite1_dom :: "nat \<Rightarrow> bool" where
"hexwrite1_dom n = (n < 16)"

definition hexwrite1_upper :: "nat \<Rightarrow> char" where
"hexwrite1_upper c = (if c = 0 then CHR ''0'' else
                if c = 1 then CHR ''1'' else
                if c = 2 then CHR ''2'' else
                if c = 3 then CHR ''3'' else
                if c = 4 then CHR ''4'' else
                if c = 5 then CHR ''5'' else
                if c = 6 then CHR ''6'' else
                if c = 7 then CHR ''7'' else
                if c = 8 then CHR ''8'' else
                if c = 9 then CHR ''9'' else
                if c = 10 then CHR ''A'' else
                if c = 11 then CHR ''B'' else
                if c = 12 then CHR ''C'' else
                if c = 13 then CHR ''D'' else
                if c = 14 then CHR ''E'' else
                if c = 15 then CHR ''F'' else undefined)"

definition hexwrite1 :: "nat \<Rightarrow> char" where
"hexwrite1 c = (if c = 0 then CHR ''0'' else
                if c = 1 then CHR ''1'' else
                if c = 2 then CHR ''2'' else
                if c = 3 then CHR ''3'' else
                if c = 4 then CHR ''4'' else
                if c = 5 then CHR ''5'' else
                if c = 6 then CHR ''6'' else
                if c = 7 then CHR ''7'' else
                if c = 8 then CHR ''8'' else
                if c = 9 then CHR ''9'' else
                if c = 10 then CHR ''a'' else
                if c = 11 then CHR ''b'' else
                if c = 12 then CHR ''c'' else
                if c = 13 then CHR ''d'' else
                if c = 14 then CHR ''e'' else
                if c = 15 then CHR ''f'' else undefined)"

(*
lemma hexread1_hexwrite1 : "hexread1_dom c \<Longrightarrow> hexwrite1 (hexread1 c) = c"
  apply (auto simp add:hexread1_dom_def hexread1_def hexwrite1_def)
  done
*)
lemma hexwrite1_help :
"n < 16 \<Longrightarrow>
    n \<noteq> 15 \<Longrightarrow>
    n \<noteq> 14 \<Longrightarrow>
    n \<noteq> 13 \<Longrightarrow>
    n \<noteq> 12 \<Longrightarrow>
    n \<noteq> 11 \<Longrightarrow>
    n \<noteq> 10 \<Longrightarrow>
    n \<noteq> 9 \<Longrightarrow>
    n \<noteq> 8 \<Longrightarrow>
    n \<noteq> 7 \<Longrightarrow>
    n \<noteq> 6 \<Longrightarrow>
    n \<noteq> 5 \<Longrightarrow>
    n \<noteq> 4 \<Longrightarrow>
    n \<noteq> 3 \<Longrightarrow>
    n \<noteq> 2 \<Longrightarrow>
    n \<noteq> Suc 0 \<Longrightarrow>
    0 < n \<Longrightarrow> False"
proof(induction n, auto)
qed

definition hexread2 :: "char \<Rightarrow> char \<Rightarrow> int" where
"hexread2 c1 c2 = (16 * (int (hexread1 c1)) + int (hexread1 c2))"

(* we need to reverse the input list? *)
fun hexread' :: "char list \<Rightarrow> int \<Rightarrow> int" where
"hexread' [] n = n"
| "hexread' [_] _ = undefined"
| "hexread' (n1#n2#t) a = hexread' t (hexread2 n1 n2 + 256 * a)"

definition hexread :: "char list \<Rightarrow> int" where
"hexread ls = hexread' ls 0"

fun hexwrite2 :: "8 word \<Rightarrow> (char * char)" where
"hexwrite2 w =
  (case Divides.divmod_nat (Word.unat w) 16 of
       (d,m) \<Rightarrow> (hexwrite1 d, hexwrite1 m))"

(* TODO: make sure we aren't supposed to do the reverse of this *)
fun hexwrite :: "8 word list \<Rightarrow> char list" where
"hexwrite [] = []"
| "hexwrite (h#t) = (case hexwrite2 h of
                     (c1, c2) \<Rightarrow> c1#c2#(hexwrite t))"

value "List.n_lists 2 [1 :: nat, 2, 3]"

(* splitting a hex string into bytes *)

fun hex_split_bytes' :: "char list \<Rightarrow> char list list" where
"hex_split_bytes' [] = []"
| "hex_split_bytes' [h] = [[h]]" (* should never happen *)
| "hex_split_bytes' (h1#h2#t) =
    (h1#h2#[])#(hex_split_bytes' t)"

fun hex_split_bytes ::
  "char list \<Rightarrow> char list list" where
"hex_split_bytes ls =
  (case divmod_nat (length ls) 2 of
    (_, 0) \<Rightarrow> hex_split_bytes' ls
  | (_, _) \<Rightarrow> hex_split_bytes' ((CHR ''0'') # ls))"

value "hex_split_bytes
''000000000000000000000000000000000000000000000000000000000000002a''"

(* TODO: this will still choke if given non-hex characters. *)
fun hex_splits :: "char list \<Rightarrow> 8 word list" where
"hex_splits l =
  List.map (\<lambda> x . Word.word_of_int (hexread x)) (hex_split_bytes l)"

value "hex_splits
''000000000000000000000000000000000000000000000000000000000000002a''"

(* decimal reading/writing - for use in generating error messages *)

definition decwrite1_dom :: "int \<Rightarrow> bool" where
"decwrite1_dom n = (n < 10)"

definition decwrite1 :: "int \<Rightarrow> char" where
"decwrite1 c = (if c = 0 then CHR ''0'' else
                if c = 1 then CHR ''1'' else
                if c = 2 then CHR ''2'' else
                if c = 3 then CHR ''3'' else
                if c = 4 then CHR ''4'' else
                if c = 5 then CHR ''5'' else
                if c = 6 then CHR ''6'' else
                if c = 7 then CHR ''7'' else
                if c = 8 then CHR ''8'' else
                if c = 9 then CHR ''9'' else undefined)"

(*
lemma hexread1_hexwrite1 : "hexread1_dom c \<Longrightarrow> hexwrite1 (hexread1 c) = c"
  apply (auto simp add:hexread1_dom_def hexread1_def hexwrite1_def)
  done
*)
lemma decwrite1_help :
"n < 10 \<Longrightarrow>
    n \<noteq> 9 \<Longrightarrow>
    n \<noteq> 8 \<Longrightarrow>
    n \<noteq> 7 \<Longrightarrow>
    n \<noteq> 6 \<Longrightarrow>
    n \<noteq> 5 \<Longrightarrow>
    n \<noteq> 4 \<Longrightarrow>
    n \<noteq> 3 \<Longrightarrow>
    n \<noteq> 2 \<Longrightarrow>
    n \<noteq> Suc 0 \<Longrightarrow>
    0 < n \<Longrightarrow> False"
proof(induction n, auto)
qed
(*
fun decwrite2 :: "int \<Rightarrow> (char * char)" where
"decwrite2 w =
  (case Divides.divmod_int w 10 of
       (d,m) \<Rightarrow> (decwrite1 d, decwrite1 m))"

function(sequential) decwrite' :: "nat \<Rightarrow> char list" where
"decwrite' n = (if n < 10 then [decwrite1 n] else
              (case Divides.divmod_nat n 10 of
                     (d, m) \<Rightarrow> (decwrite1 m # (decwrite' d))))"
  by pat_completeness auto

termination
  apply(relation "(measure (\<lambda> n . if n < 10 then 1 else Suc n))")
   apply(clarsimp)
  apply(clarsimp) apply(simp add:divmod_nat_def)
  done

fun decwrite :: "nat \<Rightarrow> char list" where
"decwrite n = rev (decwrite' n)"
*)

definition decread1_dom :: "char \<Rightarrow> bool" where
"decread1_dom c = (c = CHR ''0'' \<or> c = CHR ''1'' \<or> c = CHR ''2'' \<or>
                   c = CHR ''3'' \<or> c = CHR ''4'' \<or> c = CHR ''5'' \<or>
                   c = CHR ''6'' \<or> c = CHR ''7'' \<or> c = CHR ''8'' \<or>
                   c = CHR ''9'' )"

definition decread1 :: "char \<Rightarrow> int" where
"decread1 c = (if c = (CHR ''0'') then 0 else
               if c = (CHR ''1'') then 1 else
               if c = (CHR ''2'') then 2 else
               if c = (CHR ''3'') then 3 else
               if c = (CHR ''4'') then 4 else
               if c = (CHR ''5'') then 5 else
               if c = (CHR ''6'') then 6 else
               if c = (CHR ''7'') then 7 else
               if c = (CHR ''8'') then 8 else
               if c = (CHR ''9'') then 9 else
               undefined)"

(* TODO: finish this *)
fun decread' :: "char list \<Rightarrow> int \<Rightarrow> int" where
"decread' [] n = n"
| "decread' (n1#t) a =
   decread' t (decread1 n1 + 10 * a)"

definition decread :: "char list \<Rightarrow> int" where
"decread ls = decread' ls 0"

end


section \<open>Integrating the SIMP language into Picore\<close>

theory SIMP_plus
imports "SIMP/RG_Hoare"
begin

inductive rghoare_p :: "['a com option, 'a set, ('a \<times> 'a) set, ('a \<times> 'a) set, 'a set] \<Rightarrow> bool"
    ("\<turnstile>\<^sub>I _ sat\<^sub>p [_, _, _, _]" [60,0,0,0,0] 45)
where
(*  Some_hoare: "\<lbrakk> \<turnstile> Q sat [pre, rely, guar, post] \<rbrakk> \<Longrightarrow> \<turnstile>\<^sub>I (Some Q) sat\<^sub>p [pre, rely, guar, post]"*)
  Basic: "\<lbrakk> pre \<subseteq> {s. f s \<in> post}; {(s,t). s \<in> pre \<and> (t=f s)} \<subseteq> guar;
            stable pre rely; stable post rely \<rbrakk>
           \<Longrightarrow> \<turnstile>\<^sub>I Some (Basic f) sat\<^sub>p [pre, rely, guar, post]"

| Seq: "\<lbrakk> \<turnstile>\<^sub>I Some P sat\<^sub>p [pre, rely, guar, mid]; \<turnstile>\<^sub>I Some Q sat\<^sub>p [mid, rely, guar, post] \<rbrakk>
           \<Longrightarrow> \<turnstile>\<^sub>I Some (Seq P Q) sat\<^sub>p [pre, rely, guar, post]"

| Cond: "\<lbrakk> stable pre rely; \<turnstile>\<^sub>I Some P1 sat\<^sub>p [pre \<inter> b, rely, guar, post];
           \<turnstile>\<^sub>I Some P2 sat\<^sub>p [pre \<inter> -b, rely, guar, post]; \<forall>s. (s,s)\<in>guar \<rbrakk>
          \<Longrightarrow> \<turnstile>\<^sub>I Some (Cond b P1 P2) sat\<^sub>p [pre, rely, guar, post]"

| While: "\<lbrakk> stable pre rely; (pre \<inter> -b) \<subseteq> post; stable post rely;
            \<turnstile>\<^sub>I Some P sat\<^sub>p [pre \<inter> b, rely, guar, pre]; \<forall>s. (s,s)\<in>guar \<rbrakk>
          \<Longrightarrow> \<turnstile>\<^sub>I Some (While b P) sat\<^sub>p [pre, rely, guar, post]"

| Await: "\<lbrakk> stable pre rely; stable post rely;
            \<forall>V. \<turnstile>\<^sub>I Some P sat\<^sub>p [pre \<inter> b \<inter> {V}, {(s, t). s = t},
                UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
           \<Longrightarrow> \<turnstile>\<^sub>I Some (Await b P) sat\<^sub>p [pre, rely, guar, post]"

| None_hoare: "\<lbrakk> stable pre rely; pre \<subseteq> post \<rbrakk>  \<Longrightarrow> \<turnstile>\<^sub>I None sat\<^sub>p [pre, rely, guar, post]"

| Conseq: "\<lbrakk> pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
             \<turnstile>\<^sub>I P sat\<^sub>p [pre', rely', guar', post'] \<rbrakk>
            \<Longrightarrow> \<turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post]"

| Unprecond: "\<lbrakk> \<turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post]; \<turnstile>\<^sub>I P sat\<^sub>p [pre', rely, guar, post] \<rbrakk>
            \<Longrightarrow> \<turnstile>\<^sub>I P sat\<^sub>p [pre \<union> pre', rely, guar, post]"

| Intpostcond: "\<lbrakk> \<turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post]; \<turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post'] \<rbrakk>
            \<Longrightarrow> \<turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post \<inter> post']"

| Allprecond: "\<forall>v\<in>U. \<turnstile>\<^sub>I P sat\<^sub>p [{v}, rely, guar, post]
            \<Longrightarrow> \<turnstile>\<^sub>I P sat\<^sub>p [U, rely, guar, post]"

| Emptyprecond: "\<turnstile>\<^sub>I P sat\<^sub>p [{}, rely, guar, post]"

definition prog_validity :: "'a com option \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
                 ("\<Turnstile>\<^sub>I _ sat\<^sub>p [_, _, _, _]" [60,0,0,0,0] 45) where
  "\<Turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post] \<equiv>
   \<forall>s. cp P s \<inter> assum(pre, rely) \<subseteq> comm(guar, post)"

(*
lemma Basic_imp: "\<turnstile> Basic x sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I Some (Basic x) sat\<^sub>p [pre, rely, guar, post]"
apply(erule RG_Hoare.rghoare.induct)
  using Basic apply blast
  using Seq apply blast
  using Cond apply blast
  using While apply blast
  using Await apply blast
  using Conseq apply blast
done

lemma Seq_imp: "(\<turnstile> P1 sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I Some P1 sat\<^sub>p [pre, rely, guar, post]) \<Longrightarrow>
       (\<turnstile> P2 sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I Some P2 sat\<^sub>p [pre, rely, guar, post]) \<Longrightarrow>
       \<turnstile> Seq P1 P2 sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I Some (Seq P1 P2) sat\<^sub>p [pre, rely, guar, post]"
apply(erule RG_Hoare.rghoare.induct)
  using Basic apply blast
  using Seq apply blast
  using Cond apply blast
  using While apply blast
  using Await apply blast
  using Conseq apply blast
done

lemma Cond_imp: "(\<turnstile> P1 sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I Some P1 sat\<^sub>p [pre, rely, guar, post]) \<Longrightarrow>
       (\<turnstile> P2 sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I Some P2 sat\<^sub>p [pre, rely, guar, post]) \<Longrightarrow>
       \<turnstile> Cond x1a P1 P2 sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I Some (Cond x1a P1 P2) sat\<^sub>p [pre, rely, guar, post]"
apply(erule RG_Hoare.rghoare.induct)
  using Basic apply blast
  using Seq apply blast
  using Cond apply blast
  using While apply blast
  using Await apply blast
  using Conseq apply blast
done

lemma While_imp: " (\<turnstile> P sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I Some P sat\<^sub>p [pre, rely, guar, post]) \<Longrightarrow>
       \<turnstile> While x1a P sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I Some (While x1a P) sat\<^sub>p [pre, rely, guar, post]"
apply(erule RG_Hoare.rghoare.induct)
  using Basic apply blast
  using Seq apply blast
  using Cond apply blast
  using While apply blast
  using Await apply blast
  using Conseq apply blast
done

lemma Await_imp: " (\<turnstile> P sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I Some P sat\<^sub>p [pre, rely, guar, post]) \<Longrightarrow>
       \<turnstile> Await x1a P sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I Some (Await x1a P) sat\<^sub>p [pre, rely, guar, post]"
apply(erule RG_Hoare.rghoare.induct)
  using Basic apply blast
  using Seq apply blast
  using Cond apply blast
  using While apply blast
  using Await apply blast
  using Conseq apply blast
done

lemma "\<turnstile> P sat [pre, rely, guar, post] \<Longrightarrow> \<turnstile>\<^sub>I (Some P) sat\<^sub>p [pre, rely, guar, post]"
apply(induct P)
using Basic_imp apply blast
using Seq_imp apply blast
using Cond_imp apply blast
using While_imp apply blast
using Await_imp apply blast
done

thm rghoare_p.induct
*)

subsection \<open>lemmas of SIMP\<close>

lemma etran_or_ctran2_disjI3:
  "\<lbrakk> x\<in>cptn; Suc i<length x; \<not> x!i -c\<rightarrow> x!Suc i\<rbrakk> \<Longrightarrow> x!i -e\<rightarrow> x!Suc i"
apply(induct x arbitrary:i)
 apply simp
apply clarify
apply(rule cptn.cases)
  apply simp+
  using less_Suc_eq_0_disj etran.intros apply force
  apply(case_tac i,simp)
  by simp

lemma stable_id: "stable P Id"
  unfolding stable_def Id_def by auto

lemma stable_id2: "stable P {(s,t). s = t}"
  unfolding stable_def by auto

lemma stable_int2: "stable s r \<Longrightarrow> stable t r \<Longrightarrow> stable (s \<inter> t) r"
  by (metis (full_types) IntD1 IntD2 IntI stable_def)

lemma stable_int3: "stable k r \<Longrightarrow> stable s r \<Longrightarrow> stable t r \<Longrightarrow> stable (k \<inter> s \<inter> t) r"
  by (metis (full_types) IntD1 IntD2 IntI stable_def)

lemma stable_int4: "stable k r \<Longrightarrow> stable s r \<Longrightarrow> stable t r \<Longrightarrow> stable v r \<Longrightarrow>
                    stable (k \<inter> s \<inter> t \<inter> v) r"
  by (metis (full_types) IntD1 IntD2 IntI stable_def)

lemma stable_int5: "stable k r \<Longrightarrow> stable s r \<Longrightarrow> stable t r \<Longrightarrow> stable v r \<Longrightarrow>
                    stable y r \<Longrightarrow> stable (k \<inter> s \<inter> t \<inter> v \<inter> y) r"
  by (metis (full_types) IntD1 IntD2 IntI stable_def)

lemma stable_un2: "stable s r \<Longrightarrow> stable t r \<Longrightarrow> stable (s \<union> t) r"
  by (simp add: stable_def)

(*
lemma Seq2: "\<lbrakk> \<turnstile> P sat [pre, rely, guar, mida]; mida \<subseteq> midb; \<turnstile> Q sat [midb, rely, guar, post] \<rbrakk>
  \<Longrightarrow> \<turnstile>\<^sub>I Some (Seq P Q) sat\<^sub>p [pre, rely, guar, post]"
  using Seq[of P pre rely guar mida Q post] Some_hoare[of "Seq P Q" pre rely guar post]
        RG_Hoare.Conseq[of mida midb rely rely guar guar post post Q]
  by blast*)

lemma Seq2: "\<lbrakk> \<turnstile>\<^sub>I Some P sat\<^sub>p [pre, rely, guar, mida]; mida \<subseteq> midb; \<turnstile>\<^sub>I Some Q sat\<^sub>p [midb, rely, guar, post] \<rbrakk>
  \<Longrightarrow> \<turnstile>\<^sub>I Some (Seq P Q) sat\<^sub>p [pre, rely, guar, post]"
  using Seq[of P pre rely guar mida Q post]
        Conseq[of mida midb rely rely guar guar post post]
  by blast

(*
lemma Intpostcond_sound':
  assumes p0: " \<Turnstile> P sat [pre, rely, guar, post]"
    and  p1: " \<Turnstile> P sat [pre, rely, guar, post']"
   shows " \<Turnstile> P sat [pre, rely, guar, post \<inter> post']"
proof -
{
  fix s c
  assume a0: "c \<in> cp (Some P) s \<inter> assum(pre, rely)"
  with p0 have "c \<in> comm(guar, post)" unfolding com_validity_def by auto
  moreover
  from a0 p1 have "c \<in> comm(guar, post')" unfolding com_validity_def by auto
  ultimately have "c \<in> comm(guar, post \<inter> post')"
    by (simp add: comm_def)
}
then show ?thesis unfolding com_validity_def by auto
qed

lemma "\<lbrakk> \<turnstile> P sat [pre, rely, guar, post]; \<turnstile> P sat [pre, rely, guar, post'] \<rbrakk>
            \<Longrightarrow> \<Turnstile> P sat [pre, rely, guar, post \<inter> post']"
using Intpostcond_sound' rgsound by blast
*)

subsection\<open>Soundness of the Rule of Consequence\<close>

lemma Conseq_sound:
  "\<lbrakk>pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
  \<Turnstile>\<^sub>I P sat\<^sub>p [pre', rely', guar', post']\<rbrakk>
  \<Longrightarrow> \<Turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post]"
apply(simp add:prog_validity_def assum_def comm_def)
apply clarify
apply(erule_tac x=s in allE)
apply(drule_tac c=x in subsetD)
 apply force
apply force
done

subsection\<open>Soundness of the Rule of Unprecond\<close>

lemma Unprecond_sound:
  assumes p0: " \<Turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post]"
    and  p1: " \<Turnstile>\<^sub>I P sat\<^sub>p [pre', rely, guar, post]"
   shows " \<Turnstile>\<^sub>I P sat\<^sub>p [pre \<union> pre', rely, guar, post]"
proof -
{
  fix s c
  assume "c \<in> cp P s \<inter> assum(pre \<union> pre', rely)"
  hence a1: "c \<in> cp P s" and
        a2: "c \<in> assum(pre \<union> pre', rely)" by auto
  hence "c \<in> assum(pre, rely) \<or> c \<in> assum(pre', rely)"
    by (metis (no_types, lifting) CollectD CollectI Un_iff assum_def prod.simps(2))
  hence "c \<in> comm(guar, post)"
    proof
      assume "c \<in> assum (pre, rely)"
      with p0 a1 show "c \<in> comm (guar, post)"
        unfolding prog_validity_def by auto
    next
      assume "c \<in> assum (pre', rely)"
      with p1 a1 show "c \<in> comm (guar, post)"
        unfolding prog_validity_def by auto
    qed
}
then show ?thesis unfolding prog_validity_def by auto
qed

subsection\<open>Soundness of the Rule of Intpostcond\<close>

lemma Intpostcond_sound:
  assumes p0: " \<Turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post]"
    and  p1: " \<Turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post']"
   shows " \<Turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post \<inter> post']"
proof -
{
  fix s c
  assume a0: "c \<in> cp P s \<inter> assum(pre, rely)"
  with p0 have "c \<in> comm(guar, post)" unfolding prog_validity_def by auto
  moreover
  from a0 p1 have "c \<in> comm(guar, post')" unfolding prog_validity_def by auto
  ultimately have "c \<in> comm(guar, post \<inter> post')"
    by (simp add: comm_def)
}
then show ?thesis unfolding prog_validity_def by auto
qed

subsection\<open>Soundness of the Rule of Allprecond\<close>

lemma Allprecond_sound:
  assumes p1: "\<forall>v\<in>U. \<Turnstile>\<^sub>I P sat\<^sub>p [{v}, rely, guar, post]"
    shows " \<Turnstile>\<^sub>I P sat\<^sub>p [U, rely, guar, post]"
proof -
{
  fix s c
  assume a0: "c \<in> cp P s \<inter> assum(U, rely)"
  then obtain x where a1: "x\<in>U \<and> snd (c!0) = x"
    by (metis (no_types, lifting) CollectD IntD2 assum_def prod.simps(2))

  with p1 have "\<Turnstile>\<^sub>I P sat\<^sub>p [{x}, rely, guar, post]" by simp
  hence a2: "\<forall>s. cp P s \<inter> assum({x}, rely) \<subseteq> comm(guar, post)" unfolding prog_validity_def by simp

  from a0 have "c \<in> assum(U, rely)" by simp
  hence "snd (c!0) \<in> U \<and> (\<forall>i. Suc i<length c \<longrightarrow>
               c!i -e\<rightarrow> c!(Suc i) \<longrightarrow> (snd (c!i), snd (c!Suc i)) \<in> rely)" by (simp add:assum_def)
  with a1 have "snd (c!0) \<in> {x} \<and> (\<forall>i. Suc i<length c \<longrightarrow>
               c!i -e\<rightarrow> c!(Suc i) \<longrightarrow> (snd (c!i), snd (c!Suc i)) \<in> rely)" by simp

  hence "c\<in>assum({x}, rely)" by (simp add:assum_def)
  with a0 a2 have "c \<in> comm(guar, post)" by auto
}
then show ?thesis using prog_validity_def by blast
qed

subsection\<open>Soundness of the Rule of Emptyprecond\<close>

lemma Emptyprecond_sound: " \<Turnstile>\<^sub>I P sat\<^sub>p [{}, rely, guar, post]"
unfolding prog_validity_def by(simp add:assum_def)

subsection\<open>Soundness of None rule\<close>

lemma none_all_none: "c!0=(None,s) \<and> c \<in> cptn \<Longrightarrow> \<forall>i<length c. fst (c ! i) = None"
proof(induct c arbitrary:s)
  case Nil
  then show ?case by simp
next
  case (Cons a c)
  assume p1: "\<And>s. c ! 0 = (None, s) \<and> c \<in> cptn \<Longrightarrow> \<forall>i<length c. fst (c ! i) = None"
    and  p2: "(a # c) ! 0 = (None, s) \<and> a # c \<in> cptn"
  hence a0: "a = (None,s)" by simp
  thus ?case
    proof(cases "c = []")
      case True
      with a0 show ?thesis by auto
    next
      case False
      assume b0: "c \<noteq> []"
      with p2 have c_cpts: "c \<in> cptn" using tl_in_cptn by fast
      from b0 obtain c' and b where bc': "c = b # c'"
        using list.exhaust by blast
      from a0 have "\<not> a -c\<rightarrow> b" by(force elim: ctran.cases)
      with p2 have "a -e\<rightarrow> b"  using bc' etran_or_ctran2_disjI3[of "a#c" 0] by auto
      hence "fst b = None" using etran.cases
        by (metis a0 prod.collapse)
      with p1 bc' c_cpts have "\<forall>i<length c. fst (c ! i) = None"
        by (metis nth_Cons_0 prod.collapse)
      with a0 show ?thesis
        by (simp add: nth_Cons')
    qed

qed

lemma None_sound_h: "\<forall>x. x \<in> pre \<longrightarrow> (\<forall>y. (x, y) \<in> rely \<longrightarrow> y \<in> pre) \<Longrightarrow>
         pre \<subseteq> post \<Longrightarrow>
         snd (c ! 0) \<in> pre \<Longrightarrow>
         c \<noteq> [] \<Longrightarrow> \<forall>i. Suc i < length c \<longrightarrow> (snd (c ! i), snd (c ! Suc i)) \<in> rely
      \<Longrightarrow> i < length c \<Longrightarrow> snd (c ! i) \<in> pre"
apply(induct i) by auto

lemma None_sound:
  "\<lbrakk> stable pre rely; pre \<subseteq> post \<rbrakk>
  \<Longrightarrow> \<Turnstile>\<^sub>I None sat\<^sub>p [pre, rely, guar, post]"
proof -
  assume p0: "stable pre rely"
    and  p2: "pre \<subseteq> post"
  {
    fix s c
    assume a0: "c \<in> cp None s \<inter> assum(pre, rely)"
    hence c1: "c!0=(None,s) \<and> c \<in> cptn" by (simp add:cp_def)
    from a0 have c2: "snd (c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
               c!i -e\<rightarrow> c!(Suc i) \<longrightarrow> (snd (c!i), snd (c!Suc i)) \<in> rely)"
      by (simp add:assum_def)
    from c1 have c_ne_empty: "c \<noteq> []"
      by auto
    from c1 have c_all_none: "\<forall>i<length c. fst (c ! i) = None" using none_all_none by fast

    (* have "(\<forall>i. Suc i<length c \<longrightarrow>
               c!i -impc\<rightarrow> c!(Suc i) \<longrightarrow> (gets_p (c!i), gets_p (c!Suc i)) \<in> guar)" *)
    {
      fix i
      assume suci: "Suc i<length c"
        and cc: "c!i -c\<rightarrow> c!(Suc i)"
      from suci c_all_none have "c!i -e\<rightarrow> c!(Suc i)"
        by (metis Suc_lessD etran.intros prod.collapse)
      with cc have"(snd (c!i), snd (c!Suc i)) \<in> guar"
        using c1 etran_or_ctran2_disjI1 suci by auto
    }
    moreover
    {
      assume last_none: "fst (last c) = None"
      from c2 c_all_none have "\<forall>i. Suc i<length c \<longrightarrow> (snd (c!i), snd (c!Suc i)) \<in> rely"
        by (metis Suc_lessD etran.intros prod.collapse)
      with p0 p2 c2 c_ne_empty have "\<forall>i. i < length c \<longrightarrow> snd (c ! i) \<in> pre"
        apply(simp add: stable_def) apply clarify using None_sound_h by blast
      with p2 c_ne_empty have "snd (last c) \<in> post"
        using One_nat_def c_ne_empty last_conv_nth by force
    }
    ultimately have "c \<in> comm(guar, post)" by (simp add:comm_def)
  }
  thus "\<Turnstile>\<^sub>I None sat\<^sub>p [pre, rely, guar, post]" using prog_validity_def by blast
qed

subsection\<open>Soundness of the Await rule\<close>

lemma Await_sound:
  "\<lbrakk>stable pre rely; stable post rely;
  \<forall>V. \<turnstile>\<^sub>I Some P sat\<^sub>p [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
                 UNIV, {s. (V, s) \<in> guar} \<inter> post] \<and>
  \<Turnstile>\<^sub>I Some P sat\<^sub>p [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
                 UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
  \<Longrightarrow> \<Turnstile>\<^sub>I Some (Await b P) sat\<^sub>p [pre, rely, guar, post]"
apply(unfold prog_validity_def)
apply clarify
apply(simp add:comm_def)
apply(rule conjI)
 apply clarify
 apply(simp add:cp_def assum_def)
 apply clarify
 apply(frule_tac j=0 and k=i and p=pre in stability,simp_all)
   apply(erule_tac x=ia in allE,simp)
  apply(subgoal_tac "x\<in> cp (Some(Await b P)) s")
  apply(erule_tac i=i in unique_ctran_Await,force,simp_all)
  apply(simp add:cp_def)
(*--\<open>here starts the different part.\<close>*)
 apply(erule ctran.cases,simp_all)
 apply(drule Star_imp_cptn)
 apply clarify
 apply(erule_tac x=sa in allE)
 apply clarify
 apply(erule_tac x=sa in allE)
 apply(drule_tac c=l in subsetD)
  apply (simp add:cp_def)
  apply clarify
  apply(erule_tac x=ia and P="\<lambda>i. H i \<longrightarrow> (J i, I i)\<in>ctran" for H J I in allE,simp)
  apply(erule etranE,simp)
 apply simp
apply clarify
apply(simp add:cp_def)
apply clarify
apply(frule_tac i="length x - 1" in exists_ctran_Await_None,force)
  apply (case_tac x,simp+)
 apply(rule last_fst_esp,simp add:last_length)
 apply(case_tac x, simp+)
apply clarify
apply(simp add:assum_def)
apply clarify
apply(frule_tac j=0 and k="j" and p=pre in stability,simp_all)
  apply(erule_tac x=i in allE,simp)
 apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
apply(case_tac "x!j")
apply clarify
apply simp
apply(drule_tac s="Some (Await b P)" in sym,simp)
apply(case_tac "x!Suc j",simp)
apply(rule ctran.cases,simp)
apply(simp_all)
apply(drule Star_imp_cptn)
apply clarify
apply(erule_tac x=sa in allE)
apply clarify
apply(erule_tac x=sa in allE)
apply(drule_tac c=l in subsetD)
 apply (simp add:cp_def)
 apply clarify
 apply(erule_tac x=i and P="\<lambda>i. H i \<longrightarrow> (J i, I i)\<in>ctran" for H J I in allE,simp)
 apply(erule etranE,simp)
apply simp
apply clarify
apply(frule_tac j="Suc j" and k="length x - 1" and p=post in stability,simp_all)
 apply(case_tac x,simp+)
 apply(erule_tac x=i in allE)
apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
 apply arith+
apply(case_tac x)
apply(simp add:last_length)+
done

theorem rgsound_p:
  "\<turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post] \<Longrightarrow> \<Turnstile>\<^sub>I P sat\<^sub>p [pre, rely, guar, post]"
apply(erule rghoare_p.induct)
using RG_Hoare.Basic_sound apply(simp add:prog_validity_def com_validity_def) apply blast
using RG_Hoare.Seq_sound apply(simp add:prog_validity_def com_validity_def) apply blast
using RG_Hoare.Cond_sound apply(simp add:prog_validity_def com_validity_def) apply blast
using RG_Hoare.While_sound apply(simp add:prog_validity_def com_validity_def) apply blast
using Await_sound apply fastforce
apply(force elim:None_sound)
apply(erule Conseq_sound,simp+)
apply(erule Unprecond_sound,simp+)
apply(erule Intpostcond_sound,simp+)
using Allprecond_sound apply force
using Emptyprecond_sound apply force
done

end


theory SepLog_Misc
imports "Imperative_HOL_Time.SepAuto_Time"
begin

subsection \<open>models rules\<close>

declare mod_ex_dist [simp]

lemma mod_star_trueI: "h\<Turnstile>P \<Longrightarrow> h\<Turnstile>P*true"
  by (metis assn_times_comm entailsD' entails_true mult.left_neutral)

lemma mod_false[simp]: "\<not> h\<Turnstile>false"
  by (simp add: pure_assn_rule)

lemmas mod_pure_star_dist[simp] = mod_pure_star_dist

lemma mod_pure_star_dist'[simp]: "h\<Turnstile>\<up>b*P \<longleftrightarrow> h\<Turnstile>P \<and> b"
  using mod_pure_star_dist
  by (simp add: mult.commute)

lemma mod_starD: "h\<Turnstile>A*B \<Longrightarrow> \<exists>h1 h2. h1\<Turnstile>A \<and> h2\<Turnstile>B"
  by (metis assn_ext mod_star_convE)

subsection \<open>entailment rules\<close>

lemmas ent_true[simp] = entails_true

declare entails_triv [simp]

lemma inst_ex_assn: "A \<Longrightarrow>\<^sub>A B x \<Longrightarrow> A \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. B x)"
  using entails_ex_post by blast

lemma ent_iffI:
  assumes "A\<Longrightarrow>\<^sub>AB"
  assumes "B\<Longrightarrow>\<^sub>AA"
  shows "A=B"
  apply(rule assn_ext)
  using assms
  using entails_def by blast

lemma ent_star_mono: "\<lbrakk> P \<Longrightarrow>\<^sub>A P'; Q \<Longrightarrow>\<^sub>A Q'\<rbrakk> \<Longrightarrow> P*Q \<Longrightarrow>\<^sub>A P'*Q'"
  using  entails_trans2 entails_frame  by blast

lemma merge_true_star_ctx: "true * (true * P) = true * P"
  by (metis assn_times_assoc top_assn_reduce)

lemma ent_true_drop:
  "P\<Longrightarrow>\<^sub>AQ*true \<Longrightarrow> P*R\<Longrightarrow>\<^sub>AQ*true"
  "P\<Longrightarrow>\<^sub>AQ \<Longrightarrow> P\<Longrightarrow>\<^sub>AQ*true"
  apply (metis assn_times_comm ent_star_mono ent_true merge_true_star_ctx)
  apply (metis assn_one_left ent_star_mono ent_true mult.commute)
  done

lemma ent_true_drop_fst:
  "R\<Longrightarrow>\<^sub>AQ*true \<Longrightarrow> P*R\<Longrightarrow>\<^sub>AQ*true"
  apply (metis assn_times_comm ent_star_mono ent_true merge_true_star_ctx)
  done

lemma ent_true_drop_fstf:
  "R\<Longrightarrow>\<^sub>Atrue*Q \<Longrightarrow> P*R\<Longrightarrow>\<^sub>Atrue*Q"
  apply (metis ent_star_mono ent_true merge_true_star_ctx)
  done

lemma ent_ex_preI: "(\<And>x. P x \<Longrightarrow>\<^sub>A Q) \<Longrightarrow> \<exists>\<^sub>Ax. P x \<Longrightarrow>\<^sub>A Q"
  by (meson entails_ex)

lemma ent_ex_postI: "Q \<Longrightarrow>\<^sub>A P x \<Longrightarrow> Q \<Longrightarrow>\<^sub>A \<exists>\<^sub>Ax. P x "
  using entails_ex_post by blast

lemma entailsI:
  assumes "\<And>h. h\<Turnstile>P \<Longrightarrow> h\<Turnstile>Q"
  shows "P \<Longrightarrow>\<^sub>A Q"
  using assms unfolding entails_def by auto

lemma ent_trans[trans]: "\<lbrakk> P \<Longrightarrow>\<^sub>A Q; Q \<Longrightarrow>\<^sub>AR \<rbrakk> \<Longrightarrow> P \<Longrightarrow>\<^sub>A R"
  by (auto intro: entailsI dest: entailsD)

lemma ent_frame_fwd:
  assumes R: "P \<Longrightarrow>\<^sub>A R"
  assumes F: "Ps \<Longrightarrow>\<^sub>A P*F"
  assumes I: "R*F \<Longrightarrow>\<^sub>A Q"
  shows "Ps \<Longrightarrow>\<^sub>A Q"
  using assms
  by (metis entails_triv ent_star_mono ent_trans)

lemma ent_pure_pre_iff[simp]: "(P*\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (b \<longrightarrow> (P \<Longrightarrow>\<^sub>A Q))"
  unfolding entails_def
  by (auto   )

lemma ent_pure_pre_iff_sng[simp]:
  "(\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (b \<longrightarrow> (emp \<Longrightarrow>\<^sub>A Q))"
  using ent_pure_pre_iff[where P=emp]
  by simp

lemma ent_pure_post_iff[simp]:
  "(P \<Longrightarrow>\<^sub>A Q*\<up>b) \<longleftrightarrow> ((\<forall>h. h\<Turnstile>P \<longrightarrow> b) \<and> (P \<Longrightarrow>\<^sub>A Q))"
  unfolding entails_def
  by (auto)

lemma ent_pure_post_iff_sng[simp]:
  "(P \<Longrightarrow>\<^sub>A \<up>b) \<longleftrightarrow> ((\<forall>h. h\<Turnstile>P \<longrightarrow> b) \<and> (P \<Longrightarrow>\<^sub>A emp))"
  using ent_pure_post_iff[where Q=emp]
  by simp

lemma ent_false: "false \<Longrightarrow>\<^sub>A P" by simp

lemma ex_assn_cases: "(Q x \<Longrightarrow>\<^sub>A P) \<or> \<not> (\<exists>\<^sub>A y. Q y \<Longrightarrow>\<^sub>A P)"
  using entails_ex by blast

lemma fr_refl': "A \<Longrightarrow>\<^sub>A B \<Longrightarrow> C * A \<Longrightarrow>\<^sub>A C * B"
  by (blast intro: ent_star_mono entails_triv)

subsection \<open>assertion normalization rules\<close>

lemmas [simp] = zero_time

lemmas merge_true_star[simp] = top_assn_reduce

lemma false_absorb[simp]: "false * R = false"
  by (simp add: assn_ext mod_false')

lemma star_false_right[simp]: "P * false = false"
  using false_absorb by (simp add: assn_times_comm)

lemma pure_true[simp]: "\<up>True = emp"
  by (auto intro: assn_ext simp: one_assn_rule pure_assn_rule)

lemma pure_assn_eq_conv[simp]: "\<up>P = \<up>Q \<longleftrightarrow> P=Q"
  by (metis (full_types) assn_times_comm empty_iff in_range.simps mod_false' mod_pure_star_dist top_assn_rule)

lemma ex_distrib_star': "Q * (\<exists>\<^sub>Ax. P x ) = (\<exists>\<^sub>Ax. Q * P x)"
proof -
  have "Q * (\<exists>\<^sub>Ax. P x ) = (\<exists>\<^sub>Ax. P x ) * Q"
    by (simp add: assn_times_comm)
  also have "\<dots> = (\<exists>\<^sub>Ax. P x * Q )"
    unfolding ex_distrib_star by simp
  also have "\<dots> = (\<exists>\<^sub>Ax. Q * P x )"
    by (simp add: assn_times_comm)
  finally show ?thesis .
qed

lemma ex_false_iff_false[simp]: "(\<exists>\<^sub>A x. false) = false" by (simp add: ent_ex_preI ent_iffI)

subsection "for relH"

text "Transitivity"
lemma relH_trans[trans]: "\<lbrakk>relH as h1 h2; relH as h2 h3\<rbrakk> \<Longrightarrow> relH as h1 h3"
  unfolding relH_def
  by auto

lemma in_range_subset:
  "\<lbrakk>as \<subseteq> as'; in_range (h,as')\<rbrakk> \<Longrightarrow> in_range (h,as)"
  by auto

lemma relH_subset:
  assumes "relH bs h h'"
  assumes "as \<subseteq> bs"
  shows "relH as h h'"
  using assms unfolding relH_def by (auto intro: in_range_subset)

subsection "new_addrs"

lemma new_addrs_id[simp]: "(new_addrs h as h) = as" unfolding new_addrs_def by auto

subsection "entailst"

definition entailst :: "assn \<Rightarrow> assn \<Rightarrow> bool" (infix "\<Longrightarrow>\<^sub>t" 10)
  where "entailst A B \<equiv> A \<Longrightarrow>\<^sub>A B * true"
lemma enttI: "A\<Longrightarrow>\<^sub>AB*true \<Longrightarrow> A\<Longrightarrow>\<^sub>tB" unfolding entailst_def .
lemma enttD: "A\<Longrightarrow>\<^sub>tB \<Longrightarrow> A\<Longrightarrow>\<^sub>AB*true" unfolding entailst_def .

lemma entt_refl': "P\<Longrightarrow>\<^sub>A P * true"
  by (simp add: entailsI mod_star_trueI)

lemma entt_fr_drop: "F\<Longrightarrow>\<^sub>tF' \<Longrightarrow> F*A \<Longrightarrow>\<^sub>t F'"
  using ent_true_drop(1) enttD enttI by blast

lemma entt_trans:
  "entailst A B \<Longrightarrow> entailst B C \<Longrightarrow> entailst A C"
  unfolding entailst_def
  apply (erule ent_trans)
  by (metis assn_times_assoc ent_star_mono ent_true merge_true_star)

lemma ent_imp_entt: "P\<Longrightarrow>\<^sub>AQ \<Longrightarrow> P\<Longrightarrow>\<^sub>tQ"
  apply (rule enttI)
  apply (erule ent_trans)
  by (simp add: entailsI mod_star_trueI)

lemma entt_refl[simp, intro!]: "P\<Longrightarrow>\<^sub>t P "
  by (simp add: entailst_def entailsI mod_star_trueI)

lemma entt_star_mono: "\<lbrakk>entailst A B; entailst C D\<rbrakk> \<Longrightarrow> entailst (A*C) (B*D)"
  unfolding entailst_def
proof -
  assume a1: "A \<Longrightarrow>\<^sub>A B * true"
  assume "C \<Longrightarrow>\<^sub>A D * true"
  then have "A * C \<Longrightarrow>\<^sub>A true * B * (true * D)"
    using a1 assn_times_comm ent_star_mono by force
  then show "A * C \<Longrightarrow>\<^sub>A B * D * true"
    by (simp add: ab_semigroup_mult_class.mult.left_commute assn_times_comm)
qed

lemma entt_emp[simp, intro!]:
  "entailst A emp"
  unfolding entailst_def by simp

lemma entt_star_true_simp[simp]:
  "entailst A (B*true) \<longleftrightarrow> entailst A B"
  "entailst (A*true) B \<longleftrightarrow> entailst A B"
  unfolding entailst_def
  subgoal by (auto simp: assn_times_assoc)
  subgoal
    apply (intro iffI)
    subgoal using entails_def mod_star_trueI by blast
    subgoal by (metis assn_times_assoc entails_triv ent_star_mono merge_true_star)
    done
  done

lemma entt_def_true: "(P\<Longrightarrow>\<^sub>tQ) \<equiv> (P*true \<Longrightarrow>\<^sub>A Q*true)"
  unfolding entailst_def
  apply (rule eq_reflection)
  using entailst_def entt_star_true_simp(2) by auto

lemma entt_frame_fwd:
  assumes "entailst P Q"
  assumes "entailst A (P*F)"
  assumes "entailst (Q*F) B"
  shows "entailst A B"
  using assms
  by (metis entt_refl entt_star_mono entt_trans)

subsection "Heap Or"

declare or_assn_conv [simp]

lemma ex_distrib_or: "(\<exists>\<^sub>Ax. Q x) \<or>\<^sub>A P = (\<exists>\<^sub>Ax. Q x \<or>\<^sub>A P)"
  by (auto intro!: assn_ext simp: mod_ex_dist)

lemma sup_commute: "P \<or>\<^sub>A Q = Q \<or>\<^sub>A P"
  by (meson assn_ext or_assn_conv)

lemma ent_disjI1:
  assumes "P \<or>\<^sub>A Q \<Longrightarrow>\<^sub>A R"
  shows "P \<Longrightarrow>\<^sub>A R" using assms unfolding entails_def by simp

lemma ent_disjI2:
  assumes "P \<or>\<^sub>A Q \<Longrightarrow>\<^sub>A R"
  shows "Q \<Longrightarrow>\<^sub>A R" using assms unfolding entails_def by simp

lemma ent_disjI1_direct[simp]: "A \<Longrightarrow>\<^sub>A A \<or>\<^sub>A B"
  by (simp add: entailsI)

lemma ent_disjI2_direct[simp]: "B \<Longrightarrow>\<^sub>A A \<or>\<^sub>A B"
  by (simp add: entailsI)

lemma entt_disjI1_direct[simp]: "A \<Longrightarrow>\<^sub>t A \<or>\<^sub>A B"
  by (rule ent_imp_entt[OF ent_disjI1_direct])

lemma entt_disjI2_direct[simp]: "B \<Longrightarrow>\<^sub>t A \<or>\<^sub>A B"
  by (rule ent_imp_entt[OF ent_disjI2_direct])

lemma entt_disjI1': "A\<Longrightarrow>\<^sub>tB \<Longrightarrow> A\<Longrightarrow>\<^sub>tB\<or>\<^sub>AC"
  using entt_disjI1_direct entt_trans by blast

lemma entt_disjI2': "A\<Longrightarrow>\<^sub>tC \<Longrightarrow> A\<Longrightarrow>\<^sub>tB\<or>\<^sub>AC"
  using entt_disjI2_direct entt_trans by blast

lemma ent_disjE: "\<lbrakk> A\<Longrightarrow>\<^sub>AC; B\<Longrightarrow>\<^sub>AC \<rbrakk> \<Longrightarrow> A\<or>\<^sub>AB \<Longrightarrow>\<^sub>AC"
  by (simp add: entails_def)

lemma entt_disjD1: "A\<or>\<^sub>AB\<Longrightarrow>\<^sub>tC \<Longrightarrow> A\<Longrightarrow>\<^sub>tC"
  using entt_disjI1_direct entt_trans by blast

lemma entt_disjD2: "A\<or>\<^sub>AB\<Longrightarrow>\<^sub>tC \<Longrightarrow> B\<Longrightarrow>\<^sub>tC"
  using entt_disjI2_direct entt_trans by blast

lemma star_or_dist1:
  "(A \<or>\<^sub>A B)*C = (A*C \<or>\<^sub>A B*C)"
  apply (rule ent_iffI)
  unfolding entails_def
  by (fastforce simp: mod_star_conv )+

lemma star_or_dist2:
  "C*(A \<or>\<^sub>A B) = (C*A \<or>\<^sub>A C*B)"
  apply (rule ent_iffI)
  unfolding entails_def
  by (fastforce simp: mod_star_conv )+

lemmas star_or_dist = star_or_dist1 star_or_dist2

lemma ent_disjI1': "A\<Longrightarrow>\<^sub>AB \<Longrightarrow> A\<Longrightarrow>\<^sub>AB\<or>\<^sub>AC"
  by (auto simp: entails_def star_or_dist)

lemma ent_disjI2': "A\<Longrightarrow>\<^sub>AC \<Longrightarrow> A\<Longrightarrow>\<^sub>AB\<or>\<^sub>AC"
  by (auto simp: entails_def star_or_dist)

lemma merge_pure_or[simp]:
  "\<up>a \<or>\<^sub>A \<up>b = \<up>(a\<or>b)"
  by(auto intro!: assn_ext simp add: and_assn_conv pure_assn_rule)

lemma or_assn_false[simp]:
  "R \<or>\<^sub>A false = R"
  "false \<or>\<^sub>A R = R"
  by (simp_all add: ent_disjE ent_iffI)

subsection \<open>New command ureturn\<close>

definition ureturn :: "'a \<Rightarrow> 'a Heap" where
  [code del]: "ureturn x = Heap_Time_Monad.heap (\<lambda>h. (x,h,0))"

lemma execute_ureturn [execute_simps]:
  "execute (ureturn x) = Some \<circ> (\<lambda>h. (x,h,0))"
  by (simp add: ureturn_def execute_simps)

lemma success_ureturnI [success_intros]:
  "success (ureturn x) h"
  by (rule successI) (simp add: execute_simps)

lemma effect_ureturnI [effect_intros]:
  "h = h' \<Longrightarrow> effect (ureturn x) h h' x 0"
  by (rule effectI) (simp add: execute_simps)

lemma effect_ureturnE [effect_elims]:
  assumes "effect (ureturn x) h h' r n"
  obtains "r = x" "h' = h" "n=0"
  using assms by (rule effectE) (simp add: execute_simps)

lemma ureturn_bind [simp]: "ureturn x \<bind> f =   f x"
  apply (rule Heap_eqI)
  by (auto simp add: execute_simps )

lemma bind_ureturn [simp]: "f \<bind> ureturn =   f"
  by (rule Heap_eqI) (simp add: bind_def execute_simps split: option.splits)

lemma execute_ureturn' [rewrite]: "execute (ureturn x) h = Some (x, h, 0)" by (metis comp_eq_dest_lhs execute_ureturn)

lemma run_ureturnD: "run (ureturn x) (Some h) \<sigma> r t \<Longrightarrow> \<sigma> = Some h \<and> r = x \<and> t = 0"
  by (auto simp add: execute_ureturn' run.simps)

lemma return_rule:
  "<$0> ureturn x <\<lambda>r. \<up>(r = x)>"
  unfolding hoare_triple_def by (auto dest!: run_ureturnD simp: relH_def timeCredit_assn_rule)

subsection "Heap And"

lemma mod_and_dist: "h\<Turnstile>P\<and>\<^sub>AQ \<longleftrightarrow> h\<Turnstile>P \<and> h\<Turnstile>Q"
  by (rule and_assn_conv)

lemma [simp]: "false\<and>\<^sub>AQ = false"
  apply(rule assn_ext)
  by(simp add: mod_and_dist)
lemma [simp]: "Q\<and>\<^sub>Afalse = false"
  apply(rule assn_ext)
  by(simp add: mod_and_dist)

lemma ent_conjI: "\<lbrakk> A\<Longrightarrow>\<^sub>AB; A\<Longrightarrow>\<^sub>AC \<rbrakk> \<Longrightarrow> A \<Longrightarrow>\<^sub>A B \<and>\<^sub>A C"
  unfolding entails_def by (auto simp: mod_and_dist)

lemma ent_conjE1: "\<lbrakk>A\<Longrightarrow>\<^sub>AC\<rbrakk> \<Longrightarrow> A\<and>\<^sub>AB\<Longrightarrow>\<^sub>AC"
  unfolding entails_def by (auto simp: mod_and_dist)
lemma ent_conjE2: "\<lbrakk>B\<Longrightarrow>\<^sub>AC\<rbrakk> \<Longrightarrow> A\<and>\<^sub>AB\<Longrightarrow>\<^sub>AC"
  unfolding entails_def by (auto simp: mod_and_dist)

lemma true_conj: "true \<and>\<^sub>A P = P"
  using ent_conjE2 ent_conjI ent_iffI by auto

lemma hand_commute[simp]: "A \<and>\<^sub>A B = B \<and>\<^sub>A A"
using ent_conjE1 ent_conjE2 ent_conjI ent_iffI by auto

lemma and_extract_pure_left_iff[simp]: "\<up>b \<and>\<^sub>A Q = (emp\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemma and_extract_pure_left_ctx_iff[simp]: "P*\<up>b \<and>\<^sub>A Q = (P\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemma and_extract_pure_right_iff[simp]: "P \<and>\<^sub>A \<up>b = (emp\<and>\<^sub>AP)*\<up>b"
  by (cases b) (auto simp: hand_commute)

lemma and_extract_pure_right_ctx_iff[simp]: "P \<and>\<^sub>A Q*\<up>b = (P\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemma [simp]: "(x \<and>\<^sub>A y) \<and>\<^sub>A z = x \<and>\<^sub>A y \<and>\<^sub>A z"
  using assn_ext and_assn_conv by presburger

lemma emp_and [simp]: "emp \<and>\<^sub>A emp = emp"
  unfolding and_assn_def
  apply (subst (3) one_assn_def)
  by (auto simp: one_assn_rule)

lemma pure_and: "\<up>P \<and>\<^sub>A \<up>Q = \<up>(P \<and> Q)"
  by (auto simp add: pure_conj)

lemma "h \<Turnstile> r \<mapsto>\<^sub>r x \<and>\<^sub>A r' \<mapsto>\<^sub>r y \<Longrightarrow> (r = r' \<and> x = y \<and> card (addrOf h) = 1)"
  by (cases h) (auto simp: and_assn_conv sngr_assn_rule)

subsection \<open>Precision\<close>
text \<open>
  Precision rules describe that parts of an assertion may depend only on the
  underlying heap. For example, the data where a pointer points to is the same
  for the same heap.
\<close>
text \<open>Precision rules should have the form:
  @{text [display] "\<forall>x y. (h\<Turnstile>(P x * F1) \<and>\<^sub>A (P y * F2)) \<longrightarrow> x=y"}\<close>
definition "precise R \<equiv> \<forall>a a' h p F F'.
  h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F' \<longrightarrow> a = a'"

lemma preciseI[intro?]:
  assumes "\<And>a a' h p F F'. h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F' \<Longrightarrow> a = a'"
  shows "precise R"
  using assms unfolding precise_def by blast

lemma preciseD:
  assumes "precise R"
  assumes "h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F'"
  shows "a=a'"
  using assms unfolding precise_def by blast

lemma preciseD':
  assumes "precise R"
  assumes "h \<Turnstile> R a p * F"
  assumes "h \<Turnstile> R a' p * F'"
  shows "a=a'"
  apply (rule preciseD)
  apply (rule assms)
  apply (simp only: mod_and_dist)
  apply (blast intro: assms)
  done

lemma precise_extr_pure[simp]:
  "precise (\<lambda>x y. \<up>P * R x y) \<longleftrightarrow> (P \<longrightarrow> precise R)"
  "precise (\<lambda>x y. R x y * \<up>P) \<longleftrightarrow> (P \<longrightarrow> precise R)"
   subgoal apply (cases P) by (auto intro!: preciseI)
   subgoal apply (cases P) by (auto intro!: preciseI simp: assn_times_comm and_assn_conv)
   done

lemma sngr_prec: "precise (\<lambda>x p. p\<mapsto>\<^sub>rx)"
  apply rule
  apply (clarsimp simp: mod_and_dist)
  subgoal for a a' h
    apply(cases h)
    by(auto dest!: mod_star_convE simp: sngr_assn_rule)
  done

lemma snga_prec: "precise (\<lambda>x p. p\<mapsto>\<^sub>ax)"
  apply rule
  apply (clarsimp simp: mod_and_dist)
  subgoal for a a' h
    apply(cases h)
    by(auto dest!: mod_star_convE simp: snga_assn_rule)
  done

text \<open>Apply precision rule with frame inference.\<close>
lemma prec_frame:
  assumes PREC: "precise P"
  assumes M1: "h\<Turnstile>(R1 \<and>\<^sub>A R2)"
  assumes F1: "R1 \<Longrightarrow>\<^sub>A P x p * F1"
  assumes F2: "R2 \<Longrightarrow>\<^sub>A P y p * F2"
  shows "x=y"
  using preciseD[OF PREC] M1 F1 F2
  by (meson mod_and_dist entailsD)

subsection \<open>is_pure_assn\<close>

definition "is_pure_assn a \<equiv> \<exists>P. a=\<up>P"
lemma is_pure_assnE: assumes "is_pure_assn a" obtains P where "a=\<up>P"
  using assms
  by (auto simp: is_pure_assn_def)

lemma is_pure_assn_pure[simp, intro!]: "is_pure_assn (\<up>P)"
  by (auto simp add: is_pure_assn_def)

lemma is_pure_assn_basic_simps[simp]:
  "is_pure_assn false"
  "is_pure_assn emp"
proof -
  have "is_pure_assn (\<up>False)" by rule thus "is_pure_assn false" by simp
  have "is_pure_assn (\<up>True)" by rule thus "is_pure_assn emp" by simp
qed

lemma is_pure_assn_starI[simp,intro!]:
  "\<lbrakk>is_pure_assn a; is_pure_assn b\<rbrakk> \<Longrightarrow> is_pure_assn (a*b)"
    by (auto simp: pure_conj[symmetric] elim!: is_pure_assnE)

subsection "some automation"

text \<open>Move existential quantifiers to the front of assertions\<close>
lemma ex_assn_move_out[simp]:
  "\<And>Q R. (\<exists>\<^sub>Ax. Q x) * R = (\<exists>\<^sub>Ax. (Q x * R))"
  "\<And>Q R. R * (\<exists>\<^sub>Ax. Q x) = (\<exists>\<^sub>Ax. (R * Q x))"

  "\<And>P Q. (\<exists>\<^sub>Ax. Q x) \<or>\<^sub>A P = (\<exists>\<^sub>Ax. (Q x \<or>\<^sub>A P))"
  "\<And>P Q. Q \<or>\<^sub>A (\<exists>\<^sub>Ax. P x) = (\<exists>\<^sub>Ax. (Q \<or>\<^sub>A P x))"
  apply -
  apply (simp add: ex_distrib_star)
  apply (subst mult.commute)
  apply (subst (2) mult.commute)
  apply (simp add: ex_distrib_star)

  apply (simp add: ex_distrib_or)
  apply (subst sup_commute)
  apply (subst (2) sup_commute)
  apply (simp add: ex_distrib_or)
  done

lemmas star_aci =
  mult.assoc[where 'a=assn] mult.commute[where 'a=assn] mult.left_commute[where 'a=assn]
  assn_one_left mult_1_right[where 'a=assn]
  merge_true_star merge_true_star_ctx

declare pure_assn_rule [simp]

subsection \<open>two references pointing to same address\<close>

text \<open>Two disjoint parts of the heap cannot be pointed to by the
  same pointer\<close>
lemma sngr_same_false_aux: "p \<mapsto>\<^sub>r x * p \<mapsto>\<^sub>r y \<Longrightarrow>\<^sub>A false"
  unfolding entails_def
  apply clarify
  apply (case_tac h)
  apply clarify
  apply (drule mod_star_convE)
  apply (clarsimp simp add: sngr_assn_rule)
  done

lemma snga_same_false_aux: "p \<mapsto>\<^sub>a x * p \<mapsto>\<^sub>a y \<Longrightarrow>\<^sub>A false"
  unfolding entails_def
  apply clarify
  apply (case_tac h)
  apply clarify
  apply (drule mod_star_convE)
  apply clarify
  apply (subst (asm) snga_assn_rule)
  apply (subst (asm) snga_assn_rule)
  apply clarify
  apply (clarsimp simp add: snga_assn_rule)
  done

lemma sngr_same_false[simp]:
  "p \<mapsto>\<^sub>r x * p \<mapsto>\<^sub>r y = false"
by (intro sngr_same_false_aux ent_false ent_iffI)

lemma snga_same_false[simp]:
  "p \<mapsto>\<^sub>a x * p \<mapsto>\<^sub>a y = false"
  by (intro snga_same_false_aux ent_false ent_iffI)

subsection \<open>Hoare consequence rules\<close>

lemmas fi_rule = pre_rule''

lemma cons_post_rule: "<P> c <Q> \<Longrightarrow> (\<And>x. Q x \<Longrightarrow>\<^sub>A Q' x) \<Longrightarrow> <P> c <Q'>"
  using post_rule by blast

lemma cons_rule:
  assumes "<P> c <Q>" "P' \<Longrightarrow>\<^sub>A P" "\<And>x. Q x \<Longrightarrow>\<^sub>A Q' x"
  shows "<P'> c <Q'>"
  using assms pre_rule cons_post_rule by blast

lemma cons_rulet:
  assumes T: "<P> c <Q>\<^sub>t" and PRE: "P' \<Longrightarrow>\<^sub>t P" and POST:"\<And>x. Q x \<Longrightarrow>\<^sub>t Q' x"
  shows "<P'> c <Q'>\<^sub>t"
proof -
  have "<P'> c <\<lambda>a. Q a * true>\<^sub>t"
    using PRE \<open><P> c <Q>\<^sub>t\<close> fi_rule entailst_def by blast
  then show ?thesis
    using POST by (meson entailst_def cons_post_rule ent_true_drop(1))
qed

end