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

theory CSP_T_contraction
imports CSP_T_traces CSP.RS_prod
begin

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

         1. contraction traces
         2. contraction [[ ]]Tfun

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

(*============================================*
 |                   gSKIP                    |
 *============================================*)

lemma gSKIP_to_Tick_notin_traces:
  "ALL P M. gSKIP P --> <Tick> ~:t traces (P) M"
apply (intro allI)
apply (induct_tac P)
apply (simp_all add: in_traces)
apply (intro impI conjI allI)

 apply (erule noTick_rmTickE)
 apply (simp)
 apply (auto)
 apply (erule noTick_rmTickE)
 apply (simp)
 apply (erule noTick_rmTickE)
 apply (simp)
done

(*--------------------------------*
 |        STOP,SKIP,DIV           |
 *--------------------------------*)

(*** Constant_contraction ***)

lemma map_alpha_Constant: "0 <= alpha ==> map_alpha (%M. C) alpha"
apply (simp add: map_alpha_def)
(* for Isabelle 2013
apply (simp add: real_mult_order_eq)
*)
done

(*** non_expanding_Constant ***)

lemma non_expanding_Constant: "non_expanding (%M. C)"
by (simp add: non_expanding_def map_alpha_Constant)

(*** Constant_contraction_alpha ***)

lemma contraction_alpha_Constant:
   "[| 0 <= alpha ; 1 > alpha |] ==> contraction_alpha (%M. C) alpha"
by (simp add: contraction_alpha_def map_alpha_Constant)

(*** STOP ***)

lemma map_alpha_traces_STOP:
  "0 <= alpha ==> map_alpha (traces (STOP)) alpha"
by (simp add: traces_iff map_alpha_Constant)

lemma non_expanding_traces_STOP:
  "non_expanding (traces (STOP))"
by (simp add: non_expanding_def map_alpha_traces_STOP)

lemma contraction_alpha_traces_STOP:
  "[| 0 <= alpha ; 1 > alpha |] ==> contraction_alpha (traces (STOP)) alpha"
by (simp add: traces_iff contraction_alpha_Constant)

(*** SKIP ***)

lemma map_alpha_traces_SKIP:
  "0 <= alpha ==> map_alpha (traces (SKIP)) alpha"
by (simp add: traces_iff map_alpha_Constant)

lemma non_expanding_traces_SKIP:
  "non_expanding (traces (SKIP))"
by (simp add: non_expanding_def map_alpha_traces_SKIP)

lemma contraction_alpha_traces_SKIP:
  "[| 0 <= alpha ; 1 > alpha |] ==> contraction_alpha (traces (SKIP)) alpha"
by (simp add: traces_iff contraction_alpha_Constant)

(*** DIV ***)

lemma map_alpha_traces_DIV:
  "0 <= alpha ==> map_alpha (traces (DIV)) alpha"
by (simp add: traces_iff map_alpha_Constant)

lemma non_expanding_traces_DIV:
  "non_expanding (traces (DIV))"
by (simp add: non_expanding_def map_alpha_traces_DIV)

lemma contraction_alpha_traces_DIV:
  "[| 0 <= alpha ; 1 > alpha |] ==> contraction_alpha (traces (DIV)) alpha"
by (simp add: traces_iff contraction_alpha_Constant)

(*--------------------------------*
 |          Act_prefix            |
 *--------------------------------*)

lemma contraction_half_traces_Act_prefix_lm:
   "distance (traces (a -> P) M1, traces (a -> Q) M2) * 2
    = distance (traces P M1, traces Q M2)"
apply (rule sym)
apply (simp add: to_distance_rs)

apply (rule rest_Suc_dist_half[simplified])
apply (rule allI)
apply (simp add: rest_domT_eq_iff)
apply (rule iffI)

 (* => *)
 apply (rule allI)
 apply (simp add: in_traces)
 apply (rule iffI)

  (* => *)
  apply (elim conjE exE disjE, simp)
  apply (drule_tac x="sa" in spec)
  apply (simp)
  (* <= *)
  apply (elim conjE exE disjE, simp)
  apply (drule_tac x="sa" in spec)
  apply (simp)

 (* <= *)
 apply (rule allI)
 apply (drule_tac x="<Ev a> ^^^ s" in spec)
 apply (simp add: in_traces)
done

(***  contraction_half ***)

lemma contraction_half_traces_Act_prefix:
 "non_expanding (traces P)
  ==> contraction_alpha (traces (a -> P)) (1 / 2)"
apply (simp add: contraction_alpha_def non_expanding_def map_alpha_def)
apply (intro allI)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (simp add: contraction_half_traces_Act_prefix_lm)
done

(***  contraction ***)

lemma contraction_traces_Act_prefix:
 "non_expanding (traces P)
  ==> contraction (traces (a -> P))"
apply (simp add: contraction_def)
apply (rule_tac x="1/2" in exI)
by (simp add: contraction_half_traces_Act_prefix)

(*** non_expanding ***)

lemma non_expanding_traces_Act_prefix:
 "non_expanding (traces P)
  ==> non_expanding (traces (a -> P))"
apply (rule contraction_non_expanding)
by (simp add: contraction_traces_Act_prefix)

(*--------------------------------*
 |        Ext_pre_choice          |
 *--------------------------------*)

(*** rest_domT (subset) ***)

lemma Ext_pre_choice_Act_prefix_rest_domT_sub:
   "[| ALL a : X.
         traces (a -> Pf a) M1 .|. n <= traces (a -> Qf a) M2 .|. n |]
    ==> traces (? a:X -> Pf a) M1 .|. n <=
        traces (? a:X -> Qf a) M2 .|. n"
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_rest_domT)
apply (simp add: in_traces)
apply (elim conjE exE disjE)
apply (simp_all)

apply (drule_tac x="a" in bspec, simp)
apply (drule_tac x="t" in spec)
apply (simp add: in_traces)
done

(*** rest_domT (equal) ***)

lemma Ext_pre_choice_Act_prefix_rest_domT:
   "[| ALL a : X.
         traces (a -> Pf a) M1 .|. n = traces (a -> Qf a) M2 .|. n |]
    ==> traces (? a:X -> Pf a) M1 .|. n =
        traces (? a:X -> Qf a) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Ext_pre_choice_Act_prefix_rest_domT_sub)

(*** distT lemma ***)

lemma Ext_pre_choice_Act_prefix_distT_nonempty:
"[| X ~= {} ; PQs = {(traces (a -> Pf a) M1, traces (a -> Qf a) M2)|a. a : X} |]
 ==> (EX PQ. PQ:PQs &
             distance(traces (? a:X -> Pf a) M1, traces (? a:X -> Qf a) M2)
          <= distance(fst PQ, snd PQ))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair)
apply (force)

apply (intro allI impI)
apply (rule Ext_pre_choice_Act_prefix_rest_domT)
apply (rule ballI)
apply (simp)
apply (drule_tac x="traces (a -> Pf a) M1" in spec)
apply (drule_tac x="traces (a -> Qf a) M2" in spec)
by (auto)

(*** contraction lemma ***)

lemma contraction_half_traces_Ext_pre_choice_lm:
  "[| X ~= {} ; ALL a. distance (traces (Pf a) M1, traces (Qf a) M2)
                    <= distance (x1, x2) |]
    ==> distance (traces (? a:X -> Pf a) M1, traces (? a:X -> Qf a) M2) * 2
     <= distance (x1, x2)"
apply (insert Ext_pre_choice_Act_prefix_distT_nonempty
       [of X "{(traces (a -> Pf a) M1, traces (a -> Qf a) M2) |a. a : X}" Pf M1 Qf M2])
apply (simp)
apply (elim conjE exE)
apply (simp)
apply (subgoal_tac
    "distance (traces (aa -> Pf aa) M1, traces (aa -> Qf aa) M2) * 2
   = distance (traces (Pf aa) M1, traces (Qf aa) M2)")
apply (drule_tac x="aa" in spec)
apply (force)
by (simp add: contraction_half_traces_Act_prefix_lm)

(*** contraction_half ***)

lemma contraction_half_traces_Ext_pre_choice:
 "ALL a. non_expanding (traces (Pf a))
  ==> contraction_alpha (traces (? :X -> Pf)) (1 / 2)"
apply (simp add: contraction_alpha_def non_expanding_def map_alpha_def)
apply (case_tac "X = {}")
apply (simp add: traces_iff)
by (simp add: contraction_half_traces_Ext_pre_choice_lm)

(*** Ext_pre_choice_evalT_contraction ***)

lemma contraction_traces_Ext_pre_choice:
 "ALL a. non_expanding (traces (Pf a))
  ==> contraction (traces (? :X -> Pf))"
apply (simp add: contraction_def)
apply (rule_tac x="1/2" in exI)
by (simp add: contraction_half_traces_Ext_pre_choice)

(*** Ext_pre_choice_evalT_non_expanding ***)

lemma non_expanding_traces_Ext_pre_choice:
 "ALL a. non_expanding (traces (Pf a))
  ==> non_expanding (traces (? :X -> Pf))"
apply (rule contraction_non_expanding)
by (simp add: contraction_traces_Ext_pre_choice)

(*--------------------------------*
 |          Ext_choice            |
 *--------------------------------*)

(*** rest_domT (subset) ***)

lemma Ext_choice_rest_domT_sub:
   "[| traces P1 M1 .|. n <= traces P2 M2 .|. n ;
       traces Q1 M1 .|. n <= traces Q2 M2 .|. n  |]
    ==> traces (P1 [+] Q1) M1 .|. n <= traces (P2 [+] Q2) M2 .|. n"
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_rest_domT)
apply (simp add: in_traces)
by (auto)

(*** rest_domT (equal) ***)

lemma Ext_choice_rest_domT:
   "[| traces P1 M1 .|. n = traces P2 M2 .|. n ;
       traces Q1 M1 .|. n = traces Q2 M2 .|. n  |]
    ==> traces (P1 [+] Q1) M1 .|. n = traces (P2 [+] Q2) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Ext_choice_rest_domT_sub)

(*** distT lemma ***)

lemma Ext_choice_distT:
"PQs = {(traces P1 M1, traces P2 M2), (traces Q1 M1, traces Q2 M2)}
 ==> (EX PQ. PQ:PQs &
             distance(traces (P1 [+] Q1) M1, traces (P2 [+] Q2) M2)
          <= distance((fst PQ), (snd PQ)))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair)
by (auto intro: Ext_choice_rest_domT)

(*** map_alpha T lemma ***)

lemma map_alpha_traces_Ext_choice_lm:
  "[| distance (traces P1 M1, traces P2 M2) <= alpha * distance (x1, x2) ;
      distance (traces Q1 M1, traces Q2 M2) <= alpha * distance (x1, x2) |]
    ==> distance (traces (P1 [+] Q1) M1, traces (P2 [+] Q2) M2)
     <= alpha * distance (x1, x2)"
apply (insert Ext_choice_distT)
apply (insert Ext_choice_distT
       [of "{(traces P1 M1, traces P2 M2), (traces Q1 M1, traces Q2 M2)}"
           P1 M1 P2 M2 Q1 Q2])
by (auto)

(*** map_alpha ***)

lemma map_alpha_traces_Ext_choice:
 "[| map_alpha (traces P) alpha ; map_alpha (traces Q) alpha |]
  ==> map_alpha (traces (P [+] Q)) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_traces_Ext_choice_lm)

(*** non_expanding ***)

lemma non_expanding_traces_Ext_choice:
 "[| non_expanding (traces P) ; non_expanding (traces Q) |]
  ==> non_expanding (traces (P [+] Q))"
by (simp add: non_expanding_def map_alpha_traces_Ext_choice)

(*** contraction ***)

lemma contraction_alpha_traces_Ext_choice:
 "[| contraction_alpha (traces P) alpha ;
     contraction_alpha (traces Q) alpha|]
  ==> contraction_alpha (traces (P [+] Q)) alpha"
by (simp add: contraction_alpha_def map_alpha_traces_Ext_choice)

(*--------------------------------*
 |          Int_choice            |
 *--------------------------------*)

(*** map_alpha ***)

lemma map_alpha_traces_Int_choice:
 "[| map_alpha (traces P) alpha ; map_alpha (traces Q) alpha |]
  ==> map_alpha (traces (P |~| Q)) alpha"
by (simp add: map_alpha_traces_Ext_choice traces_Int_choice_Ext_choice)

(*** non_expanding ***)

lemma non_expanding_traces_Int_choice:
 "[| non_expanding (traces P) ; non_expanding (traces Q) |]
  ==> non_expanding (traces (P |~| Q))"
by (simp add: non_expanding_traces_Ext_choice traces_Int_choice_Ext_choice)

(*** contraction ***)

lemma contraction_alpha_traces_Int_choice:
 "[| contraction_alpha (traces P) alpha ;
     contraction_alpha (traces Q) alpha|]
  ==> contraction_alpha (traces (P |~| Q)) alpha"
by (simp add: contraction_alpha_traces_Ext_choice traces_Int_choice_Ext_choice)

(*--------------------------------*
 |        Rep_int_choice          |
 *--------------------------------*)

(*** rest_domT (subset) ***)

lemma Rep_int_choice_rest_domT_sub:
   "[| ALL c : sumset C.
         traces (Pf c) M1 .|. n <= traces (Qf c) M2 .|. n |]
    ==>  traces (!! :C .. Pf) M1 .|. n <=
         traces (!! :C .. Qf) M2 .|. n"
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_rest_domT)
apply (simp add: in_traces)
by (auto)

(*** rest_domT (equal) ***)

lemma Rep_int_choice_rest_domT:
   "[| ALL c : sumset C.
         traces (Pf c) M1 .|. n = traces (Qf c) M2 .|. n |]
    ==>  traces (!! :C .. Pf) M1 .|. n =
         traces (!! :C .. Qf) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Rep_int_choice_rest_domT_sub)

(*** distT lemma ***)

lemma Rep_int_choice_distT_nonempty:
"[| sumset C ~= {} ;
    PQs = {(traces (Pf c) M1, traces (Qf c) M2)|c. c : sumset C} |]
 ==> (EX PQ. PQ:PQs &
             distance(traces (!! :C .. Pf) M1, traces (!! :C .. Qf) M2)
          <= distance(fst PQ, snd PQ))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair)
apply (fast)

apply (intro allI impI)
apply (rule Rep_int_choice_rest_domT)
by (auto)

(*** map_alpha T lemma ***)

lemma map_alpha_traces_Rep_int_choice_lm:
"[| sumset C ~= {} ;
    ALL c. distance (traces (Pf c) M1, traces (Qf c) M2)
                  <= alpha * distance (x1, x2) |]
 ==> distance(traces(!! :C .. Pf) M1, (traces(!! :C .. Qf) M2))
  <= alpha * distance(x1, x2)"
apply (insert Rep_int_choice_distT_nonempty
       [of C "{(traces (Pf c) M1, traces (Qf c) M2)|c. c : sumset C}"
           Pf M1 Qf M2])
apply (simp)
apply (elim conjE exE, simp)
apply (drule_tac x="c" in spec)
by (force)

(*** map_alpha ***)
lemma map_alpha_traces_Rep_int_choice:
 "ALL c. map_alpha (traces (Pf c)) alpha
  ==> map_alpha (traces (!! :C .. Pf)) alpha"
apply (simp add: map_alpha_def)
apply (case_tac "sumset C = {}")
 apply (simp add: traces_iff)
(* for Isabelle 2013
apply (simp add: real_mult_order_eq)
*)
apply (simp add: map_alpha_traces_Rep_int_choice_lm)
done

(*** non_expanding ***)

lemma non_expanding_traces_Rep_int_choice:
 "ALL c. non_expanding (traces (Pf c))
  ==> non_expanding (traces (!! :C .. Pf))"
by (simp add: non_expanding_def map_alpha_traces_Rep_int_choice)

(*** Rep_int_choice_evalT_contraction_alpha ***)

lemma contraction_alpha_traces_Rep_int_choice:
 "ALL c. contraction_alpha (traces (Pf c)) alpha
     ==> contraction_alpha (traces (!! :C .. Pf)) alpha"
by (simp add: contraction_alpha_def map_alpha_traces_Rep_int_choice)

(*--------------------------------*
 |               IF               |
 *--------------------------------*)

(*** rest_domT (subset) ***)

lemma IF_rest_domT_sub:
   "[| traces P1 M1 .|. n <= traces P2 M2 .|. n ;
       traces Q1 M1 .|. n <= traces Q2 M2 .|. n  |]
    ==> traces (IF b THEN P1 ELSE Q1) M1 .|. n <=
        traces (IF b THEN P2 ELSE Q2) M2 .|. n"
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_rest_domT)
apply (simp add: in_traces)
done

(*** rest_domT (equal) ***)

lemma IF_rest_domT:
   "[| traces P1 M1 .|. n = traces P2 M2 .|. n ;
       traces Q1 M1 .|. n = traces Q2 M2 .|. n  |]
    ==> traces (IF b THEN P1 ELSE Q1) M1 .|. n =
        traces (IF b THEN P2 ELSE Q2) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: IF_rest_domT_sub)

(*** distT lemma ***)

lemma IF_distT:
   "PQs = {(traces P1 M1, traces P2 M2), (traces Q1 M1, traces Q2 M2)}
    ==> (EX PQ. PQ:PQs &
             distance(traces (IF b THEN P1 ELSE Q1) M1,
                      traces (IF b THEN P2 ELSE Q2) M2)
          <= distance((fst PQ), (snd PQ)))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair)
by (auto intro: IF_rest_domT)

(*** map_alpha T lemma (not used) ***)

lemma map_alpha_traces_IF_lm:
  "[| distance (traces P1 M1, traces P2 M2) <= alpha * distance (x1, x2) ;
      distance (traces Q1 M1, traces Q2 M2) <= alpha * distance (x1, x2) |]
    ==> distance(traces (IF b THEN P1 ELSE Q1) M1,
                 traces (IF b THEN P2 ELSE Q2) M2)
     <= alpha * distance (x1, x2)"
apply (insert IF_distT
       [of "{(traces P1 M1, traces P2 M2),
             (traces Q1 M1, traces Q2 M2)}"  P1 M1 P2 M2 Q1 Q2 b])
by (auto)

(*** map_alpha ***)

lemma map_alpha_traces_IF:
 "[| map_alpha (traces P) alpha ; map_alpha (traces Q) alpha |]
  ==> map_alpha (traces (IF b THEN P ELSE Q)) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
apply (simp add: traces_iff)
done

(*** non_expanding ***)

lemma non_expanding_traces_IF:
 "[| non_expanding (traces P) ; non_expanding (traces Q) |]
  ==> non_expanding (traces (IF b THEN P ELSE Q))"
by (simp add: non_expanding_def map_alpha_traces_IF)

(*** contraction_alpha ***)

lemma contraction_alpha_traces_IF:
 "[| contraction_alpha (traces P) alpha ; contraction_alpha (traces Q) alpha|]
  ==> contraction_alpha (traces (IF b THEN P ELSE Q)) alpha"
by (simp add: contraction_alpha_def map_alpha_traces_IF)

(*--------------------------------*
 |           Parallel             |
 *--------------------------------*)

(*** rest_domT (subset) ***)

lemma Parallel_rest_domT_sub:
   "[| traces P1 M1 .|. n <= traces P2 M2 .|. n ;
       traces Q1 M1 .|. n <= traces Q2 M2 .|. n  |]
    ==> traces (P1 |[X]| Q1) M1 .|. n <= traces (P2 |[X]| Q2) M2 .|. n"
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_rest_domT)
apply (simp add: in_traces)
apply (elim conjE exE)
apply (rule_tac x="s" in exI)
apply (rule_tac x="ta" in exI)
apply (simp)

apply (erule par_tr_lengthtE)
by (auto)

(*** rest_domT (equal) ***)

lemma Parallel_rest_domT:
   "[| traces P1 M1 .|. n = traces P2 M2 .|. n ;
       traces Q1 M1 .|. n = traces Q2 M2 .|. n  |]
    ==> traces (P1 |[X]| Q1) M1 .|. n = traces (P2 |[X]| Q2) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Parallel_rest_domT_sub)

(*** distT lemma ***)

lemma Parallel_distT:
"PQs = {(traces P1 M1, traces P2 M2), (traces Q1 M1, traces Q2 M2)}
 ==> (EX PQ. PQ:PQs &
             distance(traces (P1 |[X]| Q1) M1, traces (P2 |[X]| Q2) M2)
          <= distance((fst PQ), (snd PQ)))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair)
by (auto intro: Parallel_rest_domT)

(*** map_alpha T lemma ***)

lemma map_alpha_traces_Parallel_lm:
  "[| distance (traces P1 M1, traces P2 M2) <= alpha * distance (x1, x2) ;
      distance (traces Q1 M1, traces Q2 M2) <= alpha * distance (x1, x2) |]
    ==> distance (traces (P1 |[X]| Q1) M1, traces (P2 |[X]| Q2) M2)
     <= alpha * distance (x1, x2)"
apply (insert Parallel_distT
       [of "{(traces P1 M1, traces P2 M2), (traces Q1 M1, traces Q2 M2)}"
           P1 M1 P2 M2 Q1 Q2 X])
by (auto)

(*** map_alpha ***)

lemma map_alpha_traces_Parallel:
 "[| map_alpha (traces P) alpha ; map_alpha (traces Q) alpha |]
  ==> map_alpha (traces (P |[X]| Q)) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_traces_Parallel_lm)

(*** non_expanding ***)

lemma non_expanding_traces_Parallel:
 "[| non_expanding (traces P) ; non_expanding (traces Q) |]
  ==> non_expanding (traces (P |[X]| Q))"
by (simp add: non_expanding_def map_alpha_traces_Parallel)

(*** contraction_alpha ***)

lemma contraction_alpha_traces_Parallel:
 "[| contraction_alpha (traces P) alpha ;
     contraction_alpha (traces Q) alpha |]
  ==> contraction_alpha (traces (P |[X]| Q)) alpha"
by (simp add: contraction_alpha_def map_alpha_traces_Parallel)

(*--------------------------------*
 |            Hiding              |
 *--------------------------------*)

(* cms rules for Hiding is not necessary
   because processes are guarded. *)

(*--------------------------------*
 |           Renaming             |
 *--------------------------------*)

(*** rest_domT (subset) ***)

lemma Renaming_rest_domT_sub:
   "traces P M1 .|. n <= traces Q M2 .|. n
    ==> traces (P [[r]]) M1 .|. n <= traces (Q [[r]]) M2 .|. n"
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_rest_domT)
apply (simp add: in_traces)
apply (elim conjE exE)
apply (rule_tac x="s" in exI)
apply (drule_tac x="s" in spec)
by (simp add: ren_tr_lengtht)

(*** rest_domT (equal) ***)

lemma Renaming_rest_domT:
   "traces P M1 .|. n = traces Q M2 .|. n
    ==> traces (P [[r]]) M1 .|. n = traces (Q [[r]]) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Renaming_rest_domT_sub)

(*** distT lemma ***)

lemma Renaming_distT:
     "distance(traces (P [[r]]) M1, traces (Q [[r]]) M2) <=
      distance(traces P M1, traces Q M2)"
apply (simp only: to_distance_rs)
apply (rule rest_distance_subset)
by (auto intro: Renaming_rest_domT)

(*** map_alphaT lemma ***)

lemma map_alpha_traces_Renaming_lm:
  "distance(traces P M1, traces Q M2) <= alpha * distance (x1, x2)
    ==> distance(traces (P [[r]]) M1, traces (Q [[r]]) M2)
     <= alpha * distance(x1, x2)"
apply (insert Renaming_distT[of P r M1 Q M2])
by (simp)

(*** map_alpha ***)

lemma map_alpha_traces_Renaming:
 "map_alpha (traces P) alpha
  ==> map_alpha (traces (P [[r]])) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_traces_Renaming_lm)

(*** non_expanding ***)

lemma non_expanding_traces_Renaming:
 "non_expanding (traces P)
  ==> non_expanding (traces (P [[r]]))"
by (simp add: non_expanding_def map_alpha_traces_Renaming)

(*** contraction_alpha ***)

lemma contraction_alpha_traces_Renaming:
 "contraction_alpha (traces P) alpha
  ==> contraction_alpha (traces (P [[r]])) alpha"
by (simp add: contraction_alpha_def map_alpha_traces_Renaming)

(*--------------------------------*
 |           Seq_compo            |
 *--------------------------------*)

(*** rest_domT (subset) ***)

lemma Seq_compo_rest_domT_sub:
   "[| traces P1 M1 .|. n <= traces P2 M2 .|. n ;
       traces Q1 M1 .|. n <= traces Q2 M2 .|. n  |]
    ==> traces (P1 ;; Q1) M1 .|. n <= traces (P2 ;; Q2) M2 .|. n"
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_rest_domT)
apply (simp add: in_traces)
apply (elim conjE exE disjE)

 (* case 1 *)
 apply (rule disjI1)
 apply (insert trace_last_noTick_or_Tick)
 apply (rotate_tac -1)
 apply (drule_tac x="s" in spec)
 apply (erule disjE)
 apply (rule_tac x="s" in exI, simp)

 apply (elim conjE exE)
 apply (rule_tac x="sa" in exI, simp)
 apply (drule_tac x="sa" in spec, simp)
 apply (drule mp)
 apply (rule memT_prefix_closed, simp_all, simp)

 (* case 2 *)
 apply (case_tac "~ noTick s", simp)
 apply (insert trace_last_nil_or_unnil)
 apply (rotate_tac -1)
 apply (drule_tac x="ta" in spec)
 apply (erule disjE)

  apply (rule disjI1)                (* ta = []t *)
  apply (rule_tac x="s" in exI, simp)
  apply (drule_tac x="s" in spec, simp)
  apply (drule mp)
  apply (rule memT_prefix_closed, simp_all, simp)

  apply (rule disjI2)                (* ta ~= []t *)
  apply (elim conjE exE, simp)

  apply (drule_tac x="s ^^^ <Tick>" in spec)
  apply (drule_tac x=" sa ^^^ <a>" in spec)
  apply (simp)
  apply (rule_tac x="s" in exI)
  apply (rule_tac x="sa ^^^ <a>" in exI)
  apply (simp)
done

(*** rest_domT (equal) ***)

lemma Seq_compo_rest_domT:
   "[| traces P1 M1 .|. n = traces P2 M2 .|. n ;
       traces Q1 M1 .|. n = traces Q2 M2 .|. n  |]
    ==> traces (P1 ;; Q1) M1 .|. n = traces (P2 ;; Q2) M2 .|. n"
apply (rule order_antisym)
by (simp_all add: Seq_compo_rest_domT_sub)

(*** distT lemma ***)

lemma Seq_compo_distT:
"PQs = {(traces P1 M1, traces P2 M2), (traces Q1 M1, traces Q2 M2)}
 ==> (EX PQ. PQ:PQs &
             distance(traces (P1 ;; Q1) M1, traces (P2 ;; Q2) M2)
          <= distance((fst PQ), (snd PQ)))"
apply (simp only: to_distance_rs)
apply (rule rest_to_dist_pair)
by (auto intro: Seq_compo_rest_domT)

(*** map_alpha T lemma ***)

lemma map_alpha_traces_Seq_compo_lm:
  "[| distance (traces P1 M1, traces P2 M2) <= alpha * distance (x1, x2) ;
      distance (traces Q1 M1, traces Q2 M2) <= alpha * distance (x1, x2) |]
    ==> distance (traces (P1 ;; Q1) M1, traces (P2 ;; Q2) M2)
     <= alpha * distance (x1, x2)"
apply (insert Seq_compo_distT)
apply (insert Seq_compo_distT
       [of "{(traces P1 M1, traces P2 M2), (traces Q1 M1, traces Q2 M2)}"
           P1 M1 P2 M2 Q1 Q2])
by (auto)

(*** map_alpha ***)

lemma map_alpha_traces_Seq_compo:
 "[| map_alpha (traces P) alpha ; map_alpha (traces Q) alpha |]
  ==> map_alpha (traces (P ;; Q)) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_traces_Seq_compo_lm)

(*** non_expanding ***)

lemma non_expanding_traces_Seq_compo:
 "[| non_expanding (traces P) ; non_expanding (traces Q) |]
  ==> non_expanding (traces (P ;; Q))"
by (simp add: non_expanding_def map_alpha_traces_Seq_compo)

(*** contraction_alpha ***)

lemma contraction_alpha_traces_Seq_compo:
 "[| contraction_alpha (traces P) alpha ;
     contraction_alpha (traces Q) alpha|]
  ==> contraction_alpha (traces (P ;; Q)) alpha"
by (simp add: contraction_alpha_def map_alpha_traces_Seq_compo)

(*--------------------------------*
 |       Seq_compo  (gSKIP)       |
 *--------------------------------*)

(*** rest_domT (subset) ***)

lemma gSKIP_Seq_compo_rest_domT_sub:
   "[| traces P1 M1 .|. (Suc n) <= traces P2 M2 .|. (Suc n) ;
       traces Q1 M1 .|. n <= traces Q2 M2 .|. n ;
       <Tick> ~:t traces P1 M1 ;
       <Tick> ~:t traces P2 M2 |]
    ==> traces (P1 ;; Q1) M1 .|. (Suc n) <= traces (P2 ;; Q2) M2 .|. (Suc n)"
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (simp add: in_rest_domT)
apply (simp add: in_traces)
apply (elim conjE exE disjE)

 (* case 1 *)
 apply (rule disjI1)
 apply (insert trace_last_noTick_or_Tick)
 apply (rotate_tac -1)
 apply (drule_tac x="s" in spec)
 apply (erule disjE)
 apply (rule_tac x="s" in exI, simp)

 apply (elim conjE exE)
 apply (rule_tac x="sa" in exI, simp)
 apply (drule_tac x="sa" in spec, simp)
 apply (drule mp)
 apply (rule memT_prefix_closed, simp_all, simp)

 (* case 2 *)
 apply (case_tac "~ noTick s", simp)
 apply (insert trace_last_nil_or_unnil)
 apply (rotate_tac -1)
 apply (drule_tac x="ta" in spec)
 apply (erule disjE)

  apply (rule disjI1)                (* ta = []t *)
  apply (rule_tac x="s" in exI, simp)
  apply (drule_tac x="s" in spec, simp)
  apply (drule mp)
  apply (rule memT_prefix_closed, simp_all, simp)

  apply (rule disjI2)                (* ta ~= []t *)
  apply (elim conjE exE, simp)

  apply (drule_tac x="s ^^^ <Tick>" in spec)
  apply (drule_tac x=" sa ^^^ <a>" in spec)
  apply (simp)
  apply (rule_tac x="s" in exI)
  apply (rule_tac x="sa ^^^ <a>" in exI)
  apply (simp)

 apply (insert trace_last_nil_or_unnil)
 apply (rotate_tac -1)
 apply (drule_tac x="s" in spec)
 apply (erule disjE)
  apply (auto)
done

(*** rest_domT (equal) ***)

lemma gSKIP_Seq_compo_rest_domT:
   "[| traces P1 M1 .|. (Suc n) = traces P2 M2 .|. (Suc n) ;
       traces Q1 M1 .|. n = traces Q2 M2 .|. n ;
       <Tick> ~:t traces P1 M1 ;
       <Tick> ~:t traces P2 M2 |]
    ==> traces (P1 ;; Q1) M1 .|. (Suc n) = traces (P2 ;; Q2) M2 .|. (Suc n)"
apply (rule order_antisym)
by (simp_all add: gSKIP_Seq_compo_rest_domT_sub)

(*** map_alpha T lemma ***)

lemma gSKIP_map_alpha_traces_Seq_compo_lm:
  "[| distance (traces P1 M1, traces P2 M2) * 2 <= (1/2)^n ;
      distance (traces Q1 M1, traces Q2 M2) <= (1/2)^n ;
       <Tick> ~:t traces P1 M1 ;
       <Tick> ~:t traces P2 M2 |]
    ==> distance (traces (P1 ;; Q1) M1, traces (P2 ;; Q2) M2) * 2
     <= (1/2)^n"
apply (insert gSKIP_Seq_compo_rest_domT)
apply (insert gSKIP_Seq_compo_rest_domT[of P1 M1 n P2 M2 Q1 Q2])
apply (simp only: to_distance_rs)
apply (simp add: distance_rs_le_1)
done

(*** map_alpha ***)

lemma gSKIP_contraction_half_traces_Seq_compo:
 "[| contraction_alpha (traces P) (1/2) ; non_expanding (traces Q) ;
     gSKIP P |]
  ==> contraction_alpha (traces (P ;; Q)) (1/2)"
apply (simp add: contraction_alpha_def non_expanding_def map_alpha_def)
apply (intro allI)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)

apply (case_tac "x = y", simp)
apply (simp only: to_distance_rs)
apply (simp add: distance_iff)
apply (insert gSKIP_to_Tick_notin_traces)
apply (frule_tac x="P" in spec)
apply (drule_tac x="P" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (simp)
apply (fold to_distance_rs)
apply (simp add: gSKIP_map_alpha_traces_Seq_compo_lm)
done

(*--------------------------------*
 |          Depth_rest            |
 *--------------------------------*)

(*** rest_domT (equal) ***)

lemma Depth_rest_rest_domT:
   "traces P M1 .|. n = traces Q M2 .|. n
    ==> traces (P |. m) M1 .|. n = traces (Q |. m) M2 .|. n"
apply (simp add: traces.simps)
apply (simp add: min_rs)
apply (rule rest_equal_preserve)
apply (simp)
apply (simp add: min_def)
done

(*** distT lemma ***)

lemma Depth_rest_distT:
     "distance(traces (P |. m) M1, traces (Q |. m) M2) <=
      distance(traces P M1, traces Q M2)"
apply (simp only: to_distance_rs)
apply (rule rest_distance_subset)
by (auto intro: Depth_rest_rest_domT)

(*** map_alphaT lemma ***)

lemma map_alpha_traces_Depth_rest_lm:
  "distance(traces P M1, traces Q M2) <= alpha * distance (x1, x2)
    ==> distance(traces (P |. m) M1, traces (Q |. m) M2)
     <= alpha * distance(x1, x2)"
apply (insert Depth_rest_distT[of P m M1 Q M2])
by (simp)

(*** map_alpha ***)

lemma map_alpha_traces_Depth_rest:
 "map_alpha (traces P) alpha
  ==> map_alpha (traces (P |. m)) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (erule conjE)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
by (simp add: map_alpha_traces_Depth_rest_lm)

(*** non_expanding ***)

lemma non_expanding_traces_Depth_rest:
 "non_expanding (traces P)
  ==> non_expanding (traces (P |. m))"
by (simp add: non_expanding_def map_alpha_traces_Depth_rest)

(*** contraction_alpha ***)

lemma contraction_alpha_traces_Depth_rest:
 "contraction_alpha (traces P) alpha
  ==> contraction_alpha (traces (P |. m)) alpha"
by (simp add: contraction_alpha_def map_alpha_traces_Depth_rest)

(*--------------------------------*
 |            variable            |
 *--------------------------------*)

(*** non_expanding ***)

lemma non_expanding_traces_variable:
   "non_expanding (traces ($p))"
apply (simp add: traces_iff)
apply (simp add: non_expanding_prod_variable)
done

(*--------------------------------*
 |            Procfun             |
 *--------------------------------*)

(*****************************************************************
 |                         non_expanding                         |
 *****************************************************************)

lemma non_expanding_traces_lm:
  "noHide P --> non_expanding (traces P)"
apply (induct_tac P)
apply (simp add: non_expanding_traces_STOP)
apply (simp add: non_expanding_traces_SKIP)
apply (simp add: non_expanding_traces_DIV)
apply (simp add: non_expanding_traces_Act_prefix)
apply (simp add: non_expanding_traces_Ext_pre_choice)
apply (simp add: non_expanding_traces_Ext_choice)
apply (simp add: non_expanding_traces_Int_choice)
apply (simp add: non_expanding_traces_Rep_int_choice)
apply (simp add: non_expanding_traces_IF)
apply (simp add: non_expanding_traces_Parallel)

(* hiding --> const *)
apply (intro impI)
(* apply (subgoal_tac "EX T. (traces (proc -- fun) = (%M. T))") isabelle 2011 *)
(* apply (subgoal_tac "EX T. (traces (proc -- set) = (%M. T))") *)
apply (subgoal_tac "EX T. (traces (x1 -- x2) = (%M. T))")
apply (erule exE)
apply (simp)
apply (simp add: non_expanding_Constant)
apply (rule traces_noPN_Constant)
apply (simp)

apply (simp add: non_expanding_traces_Renaming)
apply (simp add: non_expanding_traces_Seq_compo)

(* Depth_res *)
apply (simp add: non_expanding_traces_Depth_rest)
apply (simp add: traces_iff)
apply (simp add: zero_rs_domT)
apply (simp add: non_expanding_Constant)

apply (simp add: non_expanding_traces_variable)
done

lemma non_expanding_traces:
  "noHide P ==> non_expanding (traces P)"
apply (simp add: non_expanding_traces_lm)
done

(*=============================================================*
 |                          [[P]]Tf                            |
 *=============================================================*)

lemma non_expanding_semTf:
  "noHide P ==> non_expanding [[P]]Tf"
apply (simp add: semTf_def)
apply (simp add: non_expanding_traces)
done

(*=============================================================*
 |                         [[P]]Tfun                           |
 *=============================================================*)

lemma non_expanding_semTfun:
  "noHidefun Pf ==> non_expanding [[Pf]]Tfun"
apply (simp add: noHidefun_def)
apply (simp add: prod_non_expand)
apply (simp add: semTfun_def)
apply (simp add: proj_fun_def)
apply (simp add: comp_def)
apply (simp add: non_expanding_semTf)
done

(*****************************************************************
 |                         contraction                           |
 *****************************************************************)

lemma contraction_alpha_traces_lm:
  "guarded P --> contraction_alpha (traces P) (1/2)"
apply (induct_tac P)
apply (simp add: contraction_alpha_traces_STOP)
apply (simp add: contraction_alpha_traces_SKIP)
apply (simp add: contraction_alpha_traces_DIV)
apply (simp add: contraction_half_traces_Act_prefix
                 non_expanding_traces)
apply (simp add: contraction_half_traces_Ext_pre_choice
                 non_expanding_traces)
apply (simp add: contraction_alpha_traces_Ext_choice)
apply (simp add: contraction_alpha_traces_Int_choice)
apply (simp add: contraction_alpha_traces_Rep_int_choice)
apply (simp add: contraction_alpha_traces_IF)
apply (simp add: contraction_alpha_traces_Parallel)

(* hiding --> const *)
apply (intro impI)
(* apply (subgoal_tac "EX T. (traces (proc -- fun) = (%M. T))") isabelle 2011 *)
(* apply (subgoal_tac "EX T. (traces (proc -- set) = (%M. T))") *)
apply (subgoal_tac "EX T. (traces (x1 -- x2) = (%M. T))")
apply (erule exE)
apply (simp add: contraction_alpha_Constant)
apply (rule traces_noPN_Constant)
apply (simp)

apply (simp add: contraction_alpha_traces_Renaming)

(* Seq_compo *)
apply (simp)
apply (intro conjI impI)
apply (simp add: gSKIP_contraction_half_traces_Seq_compo
                 non_expanding_traces)
apply (simp add: contraction_alpha_traces_Seq_compo)

(* Depth_res *)
apply (simp add: contraction_alpha_traces_Depth_rest)
apply (simp add: traces_iff)
apply (simp add: zero_rs_domT)
apply (simp add: contraction_alpha_Constant)

apply (simp)
done

lemma contraction_alpha_traces:
  "guarded P ==> contraction_alpha (traces P) (1/2)"
by (simp add: contraction_alpha_traces_lm)

(*=============================================================*
 |                          [[P]]Tf                            |
 *=============================================================*)

lemma contraction_alpha_semTf:
  "guarded P ==> contraction_alpha [[P]]Tf (1/2)"
apply (simp add: semTf_def)
apply (simp add: contraction_alpha_traces)
done

(*=============================================================*
 |                         [[P]]Tfun                           |
 *=============================================================*)

lemma contraction_alpha_semTfun:
  "guardedfun Pf ==> contraction_alpha [[Pf]]Tfun (1/2)"
apply (simp add: guardedfun_def)
apply (simp add: prod_contra_alpha)
apply (simp add: semTfun_def)
apply (simp add: proj_fun_def)
apply (simp add: comp_def)
apply (simp add: contraction_alpha_semTf)
done

(*=============================================================*
 |                        contraction                          |
 *=============================================================*)

lemma contraction_semTfun:
  "guardedfun Pf ==> contraction [[Pf]]Tfun"
apply (simp add: contraction_def)
apply (rule_tac x="1/2" in exI)
apply (simp add:contraction_alpha_semTfun)
done

end


section {* Theory of invariants *}

theory utp_invariants
  imports utp_designs
begin

subsection {* Operation invariants *}

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

declare OIH_def [upred_defs]

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

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

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

subsection {* State invariants *}

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

declare ISH_def [upred_defs]

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

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

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

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

declare OSH_def [upred_defs]

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

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

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

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

declare SIH_def [upred_defs]

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


(*  Title:      Sequents/Modal0.thy
    Author:     Martin Coen
    Copyright   1991  University of Cambridge
*)

theory Modal0
imports LK0
begin

ML_file \<open>modal.ML\<close>

consts
  box           :: "o\<Rightarrow>o"       ("[]_" [50] 50)
  dia           :: "o\<Rightarrow>o"       ("<>_" [50] 50)
  Lstar         :: "two_seqi"
  Rstar         :: "two_seqi"

syntax
  "_Lstar"      :: "two_seqe"   ("(_)|L>(_)" [6,6] 5)
  "_Rstar"      :: "two_seqe"   ("(_)|R>(_)" [6,6] 5)

ML \<open>
  fun star_tr c [s1, s2] = Syntax.const c $ seq_tr s1 $ seq_tr s2;
  fun star_tr' c [s1, s2] = Syntax.const c $ seq_tr' s1 $ seq_tr' s2;
\<close>

parse_translation \<open>
 [(\<^syntax_const>\<open>_Lstar\<close>, K (star_tr \<^const_syntax>\<open>Lstar\<close>)),
  (\<^syntax_const>\<open>_Rstar\<close>, K (star_tr \<^const_syntax>\<open>Rstar\<close>))]
\<close>

print_translation \<open>
 [(\<^const_syntax>\<open>Lstar\<close>, K (star_tr' \<^syntax_const>\<open>_Lstar\<close>)),
  (\<^const_syntax>\<open>Rstar\<close>, K (star_tr' \<^syntax_const>\<open>_Rstar\<close>))]
\<close>

definition strimp :: "[o,o]\<Rightarrow>o"   (infixr "--<" 25)
  where "P --< Q == [](P \<longrightarrow> Q)"

definition streqv :: "[o,o]\<Rightarrow>o"   (infixr ">-<" 25)
  where "P >-< Q == (P --< Q) \<and> (Q --< P)"

lemmas rewrite_rls = strimp_def streqv_def

lemma iffR: "\<lbrakk>$H,P \<turnstile> $E,Q,$F;  $H,Q \<turnstile> $E,P,$F\<rbrakk> \<Longrightarrow> $H \<turnstile> $E, P \<longleftrightarrow> Q, $F"
  apply (unfold iff_def)
  apply (assumption | rule conjR impR)+
  done

lemma iffL: "\<lbrakk>$H,$G \<turnstile> $E,P,Q;  $H,Q,P,$G \<turnstile> $E \<rbrakk> \<Longrightarrow> $H, P \<longleftrightarrow> Q, $G \<turnstile> $E"
  apply (unfold iff_def)
  apply (assumption | rule conjL impL basic)+
  done

lemmas safe_rls = basic conjL conjR disjL disjR impL impR notL notR iffL iffR
  and unsafe_rls = allR exL
  and bound_rls = allL exR

end


theory IICF_Array_List
imports
  "../Intf/IICF_List"
 (*  Separation_Logic_Imperative_HOL.Array_Blit *)
begin

  type_synonym 'a array_list = "'a Heap.array \<times> nat"

  definition "is_array_list l \<equiv> \<lambda>(a,n). \<exists>\<^sub>Al'. a \<mapsto>\<^sub>a l' * \<up>(n \<le> length l' \<and> l = take n l' \<and> length l'>0)"

  lemma is_array_list_prec[safe_constraint_rules]: "precise is_array_list"
    unfolding is_array_list_def[abs_def]
    apply(rule preciseI)
    apply(simp split: prod.splits)
  	using preciseD snga_prec by fastforce

  definition "initial_capacity \<equiv> 16::nat"
  definition "minimum_capacity \<equiv> 16::nat"

  definition "arl_empty \<equiv> do {
    a \<leftarrow> Array.new initial_capacity default;
    return (a,0)
  }"

  definition "arl_empty_sz init_cap \<equiv> do {
    a \<leftarrow> Array.new (max init_cap minimum_capacity) default;
    return (a,0)
  }"

  definition "arl_append \<equiv> \<lambda>(a,n) x. do {
    len \<leftarrow> Array.len a;

    if n<len then do {
      a \<leftarrow> Array.upd n x a;
      return (a,n+1)
    } else do {
      let newcap = 2 * len;
      a \<leftarrow> array_grow a newcap default;
      a \<leftarrow> Array.upd n x a;
      return (a,n+1)
    }
  }"

  definition "arl_copy \<equiv> \<lambda>(a,n). do {
    a \<leftarrow> array_copy a;
    return (a,n)
  }"

  definition arl_length :: "'a::heap array_list \<Rightarrow> nat Heap" where
    "arl_length \<equiv> \<lambda>(a,n). return (n)"

  definition arl_is_empty :: "'a::heap array_list \<Rightarrow> bool Heap" where
    "arl_is_empty \<equiv> \<lambda>(a,n). return (n=0)"

  definition arl_last :: "'a::heap array_list \<Rightarrow> 'a Heap" where
    "arl_last \<equiv> \<lambda>(a,n). do {
      Array.nth a (n - 1)
    }"

  definition arl_butlast :: "'a::heap array_list \<Rightarrow> 'a array_list Heap" where
    "arl_butlast \<equiv> \<lambda>(a,n). do {
      let n = n - 1;
      len \<leftarrow> Array.len a;
      if (n*4 < len \<and> n*2\<ge>minimum_capacity) then do {
        a \<leftarrow> array_shrink a (n*2);
        return (a,n)
      } else
        return (a,n)
    }"

  definition arl_get :: "'a::heap array_list \<Rightarrow> nat \<Rightarrow> 'a Heap" where
    "arl_get \<equiv> \<lambda>(a,n) i. Array.nth a i"

  definition arl_set :: "'a::heap array_list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a array_list Heap" where
    "arl_set \<equiv> \<lambda>(a,n) i x. do { a \<leftarrow> Array.upd i x a; return (a,n)}"

  lemma arl_empty_rule[sep_heap_rules]: "< emp > arl_empty <is_array_list []>"
    by (sep_auto simp: arl_empty_def is_array_list_def initial_capacity_def)

  lemma arl_empty_sz_rule[sep_heap_rules]: "< emp > arl_empty_sz N <is_array_list []>"
    by (sep_auto simp: arl_empty_sz_def is_array_list_def minimum_capacity_def)

  lemma arl_copy_rule[sep_heap_rules]: "< is_array_list l a > arl_copy a <\<lambda>r. is_array_list l a * is_array_list l r>"
    by (sep_auto simp: arl_copy_def is_array_list_def)

  lemma arl_append_rule[sep_heap_rules]: "
    < is_array_list l a >
      arl_append a x
    <\<lambda>a. is_array_list (l@[x]) a >\<^sub>t"
    by (sep_auto
      simp: arl_append_def is_array_list_def take_update_last neq_Nil_conv
      split: prod.splits nat.split)

  lemma arl_length_rule[sep_heap_rules]: "
    <is_array_list l a>
      arl_length a
    <\<lambda>r. is_array_list l a * \<up>(r=length l)>"
    by (sep_auto simp: arl_length_def is_array_list_def)

  lemma arl_is_empty_rule[sep_heap_rules]: "
    <is_array_list l a>
      arl_is_empty a
    <\<lambda>r. is_array_list l a * \<up>(r\<longleftrightarrow>(l=[]))>"
    by (sep_auto simp: arl_is_empty_def is_array_list_def)

  lemma arl_last_rule[sep_heap_rules]: "
    l\<noteq>[] \<Longrightarrow>
    <is_array_list l a>
      arl_last a
    <\<lambda>r. is_array_list l a * \<up>(r=last l)>"
    by (sep_auto simp: arl_last_def is_array_list_def last_take_nth_conv)

  lemma arl_butlast_rule[sep_heap_rules]: "
    l\<noteq>[] \<Longrightarrow>
    <is_array_list l a>
      arl_butlast a
    <is_array_list (butlast l)>\<^sub>t"
  proof -
    assume [simp]: "l\<noteq>[]"

    have [simp]: "\<And>x. min (x-Suc 0) ((x-Suc 0)*2) = x-Suc 0" by auto

    show ?thesis
      by (sep_auto
        split: prod.splits
        simp: arl_butlast_def is_array_list_def butlast_take minimum_capacity_def)
  qed

  lemma arl_get_rule[sep_heap_rules]: "
    i<length l \<Longrightarrow>
    <is_array_list l a>
      arl_get a i
    <\<lambda>r. is_array_list l a * \<up>(r=l!i)>"
    by (sep_auto simp: arl_get_def is_array_list_def split: prod.split)

  lemma arl_set_rule[sep_heap_rules]: "
    i<length l \<Longrightarrow>
    <is_array_list l a>
      arl_set a i x
    <is_array_list (l[i:=x])>"
    by (sep_auto simp: arl_set_def is_array_list_def split: prod.split)

  definition "arl_assn A \<equiv> hr_comp is_array_list (\<langle>the_pure A\<rangle>list_rel)"
  lemmas [safe_constraint_rules] = CN_FALSEI[of is_pure "arl_assn A" for A]

  lemma arl_assn_comp: "is_pure A \<Longrightarrow> hr_comp (arl_assn A) (\<langle>B\<rangle>list_rel) = arl_assn (hr_comp A B)"
    unfolding arl_assn_def
    by (auto simp: hr_comp_the_pure hr_comp_assoc list_rel_compp)

  lemma arl_assn_comp': "hr_comp (arl_assn id_assn) (\<langle>B\<rangle>list_rel) = arl_assn (pure B)"
    by (simp add: arl_assn_comp)

context
  notes [fcomp_norm_unfold] = arl_assn_def[symmetric] arl_assn_comp'
  notes [intro!] = hfrefI hn_refineI[THEN hn_refine_preI]
  notes [simp] = pure_def hn_ctxt_def invalid_assn_def
begin

  lemma arl_empty_hnr_aux: "(uncurry0 arl_empty,uncurry0 (RETURN op_list_empty)) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a is_array_list"
    by sep_auto
  sepref_decl_impl (no_register) arl_empty: arl_empty_hnr_aux .

  lemma arl_empty_sz_hnr_aux: "(uncurry0 (arl_empty_sz N),uncurry0 (RETURN op_list_empty)) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a is_array_list"
    by sep_auto
  sepref_decl_impl (no_register) arl_empty_sz: arl_empty_sz_hnr_aux .

  definition "op_arl_empty \<equiv> op_list_empty"
  definition "op_arl_empty_sz (N::nat) \<equiv> op_list_empty"

  lemma arl_copy_hnr_aux: "(arl_copy,RETURN o op_list_copy) \<in> is_array_list\<^sup>k \<rightarrow>\<^sub>a is_array_list"
    by sep_auto
  sepref_decl_impl arl_copy: arl_copy_hnr_aux .

  lemma arl_append_hnr_aux: "(uncurry arl_append,uncurry (RETURN oo op_list_append)) \<in> (is_array_list\<^sup>d *\<^sub>a id_assn\<^sup>k) \<rightarrow>\<^sub>a is_array_list"
    by sep_auto
  sepref_decl_impl arl_append: arl_append_hnr_aux .

  lemma arl_length_hnr_aux: "(arl_length,RETURN o op_list_length) \<in> is_array_list\<^sup>k \<rightarrow>\<^sub>a nat_assn"
    by sep_auto
  sepref_decl_impl arl_length: arl_length_hnr_aux .

  lemma arl_is_empty_hnr_aux: "(arl_is_empty,RETURN o op_list_is_empty) \<in> is_array_list\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    by sep_auto
  sepref_decl_impl arl_is_empty: arl_is_empty_hnr_aux .

  lemma arl_last_hnr_aux: "(arl_last,RETURN o op_list_last) \<in> [pre_list_last]\<^sub>a is_array_list\<^sup>k \<rightarrow> id_assn"
    by sep_auto
  sepref_decl_impl arl_last: arl_last_hnr_aux .

  lemma arl_get_hnr_aux: "(uncurry arl_get,uncurry (RETURN oo op_list_get)) \<in> [\<lambda>(l,i). i<length l]\<^sub>a (is_array_list\<^sup>k *\<^sub>a nat_assn\<^sup>k) \<rightarrow> id_assn"
    by sep_auto
  sepref_decl_impl arl_get: arl_get_hnr_aux .

  lemma arl_set_hnr_aux: "(uncurry2 arl_set,uncurry2 (RETURN ooo op_list_set)) \<in> [\<lambda>((l,i),_). i<length l]\<^sub>a (is_array_list\<^sup>d *\<^sub>a nat_assn\<^sup>k *\<^sub>a id_assn\<^sup>k) \<rightarrow> is_array_list"
    by sep_auto
  sepref_decl_impl arl_set: arl_set_hnr_aux .

  sepref_definition arl_swap is "uncurry2 mop_list_swap" :: "((arl_assn id_assn)\<^sup>d *\<^sub>a nat_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a arl_assn id_assn)"
    unfolding gen_mop_list_swap[abs_def]
    by sepref
  sepref_decl_impl (ismop) arl_swap: arl_swap.refine .
end

interpretation arl: list_custom_empty "arl_assn A" arl_empty op_arl_empty
  apply unfold_locales
  apply (rule arl_empty_hnr)
  by (auto simp: op_arl_empty_def)

end


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

imports
  "Monads.TraceMonadVCG"
  "Monads.Strengthen"

begin

text \<open>This is a simple (almost trivial) definition of refinement,
which simply resolves nondeterminism to a smaller set of options.\<close>
definition
  triv_refinement :: "('s,'a) tmonad \<Rightarrow> ('s,'a) tmonad \<Rightarrow> bool"
where
  "triv_refinement aprog cprog = (\<forall>s. cprog s \<subseteq> aprog s)"

lemma triv_refinement_mono_bind:
  "triv_refinement a c \<Longrightarrow> triv_refinement (a >>= b) (c >>= b)"
  "(\<forall>x. triv_refinement (b x) (d x)) \<Longrightarrow> triv_refinement (a >>= b) (a >>= d)"
   apply (simp add: triv_refinement_def bind_def)
   apply (intro allI UN_mono; simp)
  apply (simp only: triv_refinement_def bind_def2 split_def)
  apply (intro Un_mono allI order_refl UN_mono image_mono)
  apply simp
  done

lemma triv_refinement_trans:
  "triv_refinement f g \<Longrightarrow> triv_refinement g h
    \<Longrightarrow> triv_refinement f h"
  by (auto simp add: triv_refinement_def)

lemma triv_refinement_bind:
  "triv_refinement a c
    \<Longrightarrow> (\<forall>x. triv_refinement (b x) (d x))
    \<Longrightarrow> triv_refinement (bind a b) (bind c d)"
  by (metis triv_refinement_mono_bind triv_refinement_trans)

lemma triv_refinement_mono_parallel:
  "triv_refinement a b \<Longrightarrow> triv_refinement (parallel a c) (parallel b c)"
  apply (simp add: triv_refinement_def parallel_def split_def)
  apply blast
  done

lemma triv_refinement_mono_parallel':
  "triv_refinement a b \<Longrightarrow> triv_refinement (parallel c a) (parallel c b)"
  apply (simp add: triv_refinement_def parallel_def split_def)
  apply blast
  done

lemma triv_refinement_parallel:
  "triv_refinement a b
    \<Longrightarrow> triv_refinement c d
    \<Longrightarrow> triv_refinement (parallel a c) (parallel b d)"
  by (metis triv_refinement_mono_parallel triv_refinement_mono_parallel'
    triv_refinement_trans)

lemma select_subset:
  "(select S s \<subseteq> select S' s') = (S \<subseteq> S' \<and> (S \<noteq> {} \<longrightarrow> s = s'))"
  by (auto simp add: select_def)

lemma triv_refinement_select:
  "S' \<subseteq> S \<Longrightarrow> triv_refinement (select S) (select S')"
  by (simp add: triv_refinement_def select_subset)

lemma triv_refinement_select_eq:
  "triv_refinement (select S) (select S') = (S' \<subseteq> S)"
  by (simp add: triv_refinement_def select_subset)

lemma triv_refinement_rely:
  "(\<And>s0 s. R' s0 s \<Longrightarrow> R s0 s) \<Longrightarrow>
   triv_refinement (rely f R s0) (rely f R' s0)"
  unfolding rely_def triv_refinement_def rely_cond_def
  by auto

lemma triv_refinement_rely2:
  "triv_refinement f g \<Longrightarrow>
   triv_refinement (rely f R s0) (rely g R s0)"
  unfolding rely_def triv_refinement_def rely_cond_def
  by auto

lemma rely_rely_triv_refinement:
 "(\<And>s0 s. R s0 s \<Longrightarrow> R' s0 s) \<Longrightarrow>
 triv_refinement (rely f R' s0) (rely (rely f R s0) R' s0)"
  by (clarsimp simp: triv_refinement_def rely_def parallel_def)

lemma validI_triv_refinement:
  "triv_refinement f g
    \<Longrightarrow> \<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>G\<rbrace>,\<lbrace>Q\<rbrace>
    \<Longrightarrow> prefix_closed g
    \<Longrightarrow> \<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> g \<lbrace>G\<rbrace>,\<lbrace>Q\<rbrace>"
  unfolding rely_def triv_refinement_def validI_def
  by fastforce

lemma valid_triv_refinement:
  "triv_refinement f g
    \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>
    \<Longrightarrow> \<lbrace>P\<rbrace> g \<lbrace>Q\<rbrace>"
  unfolding rely_def triv_refinement_def valid_def mres_def
  by (fastforce elim: image_eqI[rotated])

lemma triv_refinement_refl:
  "triv_refinement f f"
  by (simp add: triv_refinement_def)

lemma triv_refinement_select_concrete_All:
  "\<forall>x \<in> S. triv_refinement aprog (cprog x)
    \<Longrightarrow> triv_refinement aprog (select S >>= cprog)"
  by (auto simp add: triv_refinement_def bind_def select_def)

lemma triv_refinement_select_abstract_x:
  "x \<in> S \<Longrightarrow> triv_refinement (aprog x) cprog
    \<Longrightarrow> triv_refinement (select S >>= aprog) cprog"
  by (auto simp add: triv_refinement_def bind_def select_def)

lemmas triv_refinement_elemD
    = triv_refinement_def[THEN iffD1, rule_format, THEN subsetD]

end


(*    Title:              SatSolverVerification/SatSolverCode.thy
      Author:             Filip Maric
      Maintainer:         Filip Maric <filip at matf.bg.ac.yu>
*)

section\<open>Functional implementation of a SAT solver with Two Watch literal propagation.\<close>
theory SatSolverCode
imports SatSolverVerification "HOL-Library.Code_Target_Numeral"
begin

(******************************************************************************)
subsection\<open>Specification\<close>
(******************************************************************************)

lemma [code_unfold]:
  fixes literal :: Literal and clause :: Clause
  shows "literal el clause = List.member clause literal"
  by (auto simp add: member_def)

datatype ExtendedBool = TRUE | FALSE | UNDEF

record State =
  \<comment> \<open>Satisfiability flag: UNDEF, TRUE or FALSE\<close>
"getSATFlag" :: ExtendedBool
  \<comment> \<open>Formula\<close>
"getF"       :: Formula
  \<comment> \<open>Assertion Trail\<close>
"getM"       :: LiteralTrail
  \<comment> \<open>Conflict flag\<close>
"getConflictFlag"   :: bool   \<comment> \<open>raised iff M falsifies F\<close>
  \<comment> \<open>Conflict clause index\<close>
"getConflictClause" :: nat    \<comment> \<open>corresponding clause from F is false in M\<close>
  \<comment> \<open>Unit propagation queue\<close>
"getQ" :: "Literal list"
  \<comment> \<open>Unit propagation graph\<close>
"getReason" :: "Literal \<Rightarrow> nat option" \<comment> \<open>index of a clause that is a reason for propagation of a literal\<close>
  \<comment> \<open>Two-watch literal scheme\<close>
  \<comment> \<open>clause indices instead of clauses are used\<close>
"getWatch1" :: "nat \<Rightarrow> Literal option"  \<comment> \<open>First watch of a clause\<close>
"getWatch2" :: "nat \<Rightarrow> Literal option"  \<comment> \<open>Second watch of a clause\<close>
"getWatchList" :: "Literal \<Rightarrow> nat list" \<comment> \<open>Watch list of a given literal\<close>
  \<comment> \<open>Conflict analysis data structures\<close>
"getC"   :: Clause             \<comment> \<open>Conflict analysis clause - always false in M\<close>
"getCl"  :: Literal            \<comment> \<open>Last asserted literal in (opposite getC)\<close>
"getCll" :: Literal            \<comment> \<open>Second last asserted literal in (opposite getC)\<close>
"getCn"  :: nat                \<comment> \<open>Number of literals of (opposite getC) on the (currentLevel M)\<close>

definition
setWatch1 :: "nat \<Rightarrow> Literal \<Rightarrow> State \<Rightarrow> State"
where
"setWatch1 clause literal state =
    state\<lparr> getWatch1 := (getWatch1 state)(clause := Some literal),
           getWatchList := (getWatchList state)(literal := clause # (getWatchList state literal))
         \<rparr>
"
declare setWatch1_def[code_unfold]

definition
setWatch2 :: "nat \<Rightarrow> Literal \<Rightarrow> State \<Rightarrow> State"
where
"setWatch2 clause literal state =
    state\<lparr> getWatch2 := (getWatch2 state)(clause := Some literal),
           getWatchList := (getWatchList state)(literal := clause # (getWatchList state literal))
         \<rparr>
"
declare setWatch2_def[code_unfold]

definition
swapWatches :: "nat \<Rightarrow> State \<Rightarrow> State"
where
"swapWatches clause state ==
    state\<lparr> getWatch1 := (getWatch1 state)(clause := (getWatch2 state clause)),
           getWatch2 := (getWatch2 state)(clause := (getWatch1 state clause))
         \<rparr>
"
declare swapWatches_def[code_unfold]

primrec getNonWatchedUnfalsifiedLiteral :: "Clause \<Rightarrow> Literal \<Rightarrow> Literal \<Rightarrow> LiteralTrail \<Rightarrow> Literal option"
where
"getNonWatchedUnfalsifiedLiteral [] w1 w2 M = None" |
"getNonWatchedUnfalsifiedLiteral (literal # clause) w1 w2 M =
    (if literal \<noteq> w1 \<and>
        literal \<noteq> w2 \<and>
        \<not> (literalFalse literal (elements M)) then
            Some literal
     else
            getNonWatchedUnfalsifiedLiteral clause w1 w2 M
    )
"

definition
setReason :: "Literal \<Rightarrow> nat \<Rightarrow> State \<Rightarrow> State"
where
"setReason literal clause state =
    state\<lparr> getReason := (getReason state)(literal := Some clause) \<rparr>
"
declare setReason_def[code_unfold]

primrec notifyWatches_loop::"Literal \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> State \<Rightarrow> State"
where
"notifyWatches_loop literal [] newWl state = state\<lparr> getWatchList := (getWatchList state)(literal := newWl) \<rparr>" |
"notifyWatches_loop literal (clause # list') newWl state =
    (let state' = (if Some literal = (getWatch1 state clause) then
                       (swapWatches clause state)
                   else
                       state) in
    case (getWatch1 state' clause) of
        None \<Rightarrow> state
    |   Some w1 \<Rightarrow> (
    case (getWatch2 state' clause) of
        None \<Rightarrow> state
    |   Some w2 \<Rightarrow>
    (if (literalTrue w1 (elements (getM state'))) then
        notifyWatches_loop literal list' (clause # newWl) state'
     else
        (case (getNonWatchedUnfalsifiedLiteral (nth (getF state') clause) w1 w2 (getM state')) of
            Some l' \<Rightarrow>
                notifyWatches_loop literal list' newWl (setWatch2 clause l' state')
          | None \<Rightarrow>
                (if (literalFalse w1 (elements (getM state'))) then
                    let state'' = (state'\<lparr> getConflictFlag := True, getConflictClause := clause \<rparr>) in
                    notifyWatches_loop literal list' (clause # newWl) state''
                else
                    let state'' = state'\<lparr> getQ := (if w1 el (getQ state') then
                                                      (getQ state')
                                                  else
                                                      (getQ state') @ [w1]
                                                  )
                                        \<rparr> in
                   let state''' = (setReason w1 clause state'') in
                   notifyWatches_loop literal list' (clause # newWl) state'''
                )
        )
    )
    )
    )
"

definition
notifyWatches :: "Literal \<Rightarrow> State \<Rightarrow> State"
where
"notifyWatches literal state ==
    notifyWatches_loop literal (getWatchList state literal) [] state
"
declare notifyWatches_def[code_unfold]

definition
assertLiteral :: "Literal \<Rightarrow> bool \<Rightarrow> State \<Rightarrow> State"
where
"assertLiteral literal decision state ==
    let state' = (state\<lparr> getM := (getM state) @ [(literal, decision)] \<rparr>) in
    notifyWatches (opposite literal) state'
"

definition
applyUnitPropagate :: "State \<Rightarrow> State"
where
"applyUnitPropagate state =
    (let state' = (assertLiteral (hd (getQ state)) False state) in
    state'\<lparr> getQ := tl (getQ state')\<rparr>)
"

partial_function (tailrec)
exhaustiveUnitPropagate :: "State \<Rightarrow> State"
where
exhaustiveUnitPropagate_unfold[code]:
"exhaustiveUnitPropagate state =
    (if (getConflictFlag state) \<or> (getQ state) = [] then
        state
    else
        exhaustiveUnitPropagate (applyUnitPropagate state)
    )
"

inductive
exhaustiveUnitPropagate_dom :: "State \<Rightarrow> bool"
where
step: "(\<not> getConflictFlag state \<Longrightarrow> getQ state \<noteq> []
   \<Longrightarrow> exhaustiveUnitPropagate_dom (applyUnitPropagate state))
   \<Longrightarrow> exhaustiveUnitPropagate_dom state"

definition
addClause :: "Clause \<Rightarrow> State \<Rightarrow> State"
where
"addClause clause state =
    (let clause' = (remdups (removeFalseLiterals clause (elements (getM state)))) in
    (if (clauseTrue clause' (elements (getM state))) then
        state
    else (if clause'=[] then
        state\<lparr> getSATFlag := FALSE \<rparr>
    else (if (length clause' = 1) then
        let state' = (assertLiteral (hd clause') False state) in
        exhaustiveUnitPropagate state'
    else (if (clauseTautology clause') then
        state
    else
        let clauseIndex = length (getF state) in
        let state'   = state\<lparr> getF := (getF state) @ [clause']\<rparr> in
        let state''  = setWatch1 clauseIndex (nth clause' 0) state' in
        let state''' = setWatch2 clauseIndex (nth clause' 1) state'' in
        state'''
   )))
 ))"

definition
initialState :: "State"
where
"initialState =
    \<lparr> getSATFlag = UNDEF,
      getF = [],
      getM = [],
      getConflictFlag = False,
      getConflictClause = 0,
      getQ = [],
      getReason = \<lambda> l. None,
      getWatch1 = \<lambda> c. None,
      getWatch2 = \<lambda> c. None,
      getWatchList = \<lambda> l. [],
      getC = [],
      getCl = (Pos 0),
      getCll = (Pos 0),
      getCn = 0
    \<rparr>
"

primrec initialize :: "Formula \<Rightarrow> State \<Rightarrow> State"
where
"initialize [] state = state" |
"initialize (clause # formula) state = initialize formula (addClause clause state)"

definition
findLastAssertedLiteral :: "State \<Rightarrow> State"
where
"findLastAssertedLiteral state =
   state \<lparr> getCl := getLastAssertedLiteral (oppositeLiteralList (getC state)) (elements (getM state)) \<rparr>"

definition
countCurrentLevelLiterals :: "State \<Rightarrow> State"
where
"countCurrentLevelLiterals state =
   (let cl = currentLevel (getM state) in
        state \<lparr> getCn := length (filter (\<lambda> l. elementLevel (opposite l) (getM state) = cl) (getC state)) \<rparr>)"

definition setConflictAnalysisClause :: "Clause \<Rightarrow> State \<Rightarrow> State"
where
"setConflictAnalysisClause clause state =
  (let oppM0 = oppositeLiteralList (elements (prefixToLevel 0 (getM state))) in
   let state' = state (| getC := remdups (list_diff clause oppM0) |) in
     countCurrentLevelLiterals (findLastAssertedLiteral state')
  )"

definition
applyConflict :: "State \<Rightarrow> State"
where
"applyConflict state =
   (let conflictClause = (nth (getF state) (getConflictClause state)) in
    setConflictAnalysisClause conflictClause state)"

definition
applyExplain :: "Literal \<Rightarrow> State \<Rightarrow> State"
where
"applyExplain literal state =
    (case (getReason state literal) of
        None \<Rightarrow>
            state
    |   Some reason \<Rightarrow>
            let res = resolve (getC state) (nth (getF state) reason) (opposite literal) in
            setConflictAnalysisClause res state

    )
"

partial_function (tailrec)
applyExplainUIP :: "State \<Rightarrow> State"
where
applyExplainUIP_unfold:
"applyExplainUIP state =
    (if (getCn state = 1) then
         state
     else
         applyExplainUIP (applyExplain (getCl state) state)
    )
"

inductive
applyExplainUIP_dom :: "State \<Rightarrow> bool"
where
step:
"(getCn state \<noteq> 1
    \<Longrightarrow> applyExplainUIP_dom (applyExplain (getCl state) state))
  \<Longrightarrow> applyExplainUIP_dom state
"

definition
applyLearn :: "State \<Rightarrow> State"
where
"applyLearn state =
        (if getC state = [opposite (getCl state)] then
            state
         else
            let state' = state\<lparr> getF := (getF state) @ [getC state] \<rparr> in
            let l  = (getCl state) in
            let ll = (getLastAssertedLiteral (removeAll l (oppositeLiteralList (getC state))) (elements (getM state))) in
            let clauseIndex = length (getF state) in
            let state''  = setWatch1 clauseIndex (opposite l) state' in
            let state''' = setWatch2 clauseIndex (opposite ll) state'' in
            state'''\<lparr> getCll := ll \<rparr>
        )
"

definition
getBackjumpLevel :: "State \<Rightarrow> nat"
where
"getBackjumpLevel state ==
    (if getC state = [opposite (getCl state)] then
        0
     else
        elementLevel (getCll state) (getM state)
     )
"

definition
applyBackjump :: "State \<Rightarrow> State"
where
"applyBackjump state =
    (let l = (getCl state) in
     let level = getBackjumpLevel state in
     let state' = state\<lparr> getConflictFlag := False, getQ := [], getM := (prefixToLevel level (getM state))\<rparr> in
     let state'' = (if level > 0 then setReason (opposite l) (length (getF state) - 1) state' else state') in
     assertLiteral (opposite l) False state''
    )
"

axiomatization selectLiteral :: "State \<Rightarrow> Variable set \<Rightarrow> Literal"
where
selectLiteral_def:
"Vbl - vars (elements (getM state)) \<noteq> {} \<longrightarrow>
    var (selectLiteral state Vbl) \<in> (Vbl - vars (elements (getM state)))"

definition
applyDecide :: "State \<Rightarrow> Variable set \<Rightarrow> State"
where
"applyDecide state Vbl =
    assertLiteral (selectLiteral state Vbl) True state
"

definition
solve_loop_body :: "State \<Rightarrow> Variable set \<Rightarrow> State"
where
"solve_loop_body state Vbl =
    (let state' = exhaustiveUnitPropagate state in
    (if (getConflictFlag state') then
        (if (currentLevel (getM state')) = 0 then
            state'\<lparr> getSATFlag := FALSE \<rparr>
         else
            (applyBackjump
            (applyLearn
            (applyExplainUIP
            (applyConflict
                state'
            )
            )
            )
            )
         )
     else
        (if (vars (elements (getM state')) \<supseteq> Vbl) then
            state'\<lparr> getSATFlag := TRUE \<rparr>
         else
            applyDecide state' Vbl
        )
    )
    )
"

partial_function (tailrec)
solve_loop :: "State \<Rightarrow> Variable set \<Rightarrow> State"
where
solve_loop_unfold:
"solve_loop state Vbl =
    (if (getSATFlag state) \<noteq> UNDEF then
        state
     else
        let state' = solve_loop_body state Vbl in
        solve_loop state' Vbl
    )
"

inductive
solve_loop_dom :: "State \<Rightarrow> Variable set \<Rightarrow> bool"
where
step:
"(getSATFlag state = UNDEF
    \<Longrightarrow> solve_loop_dom (solve_loop_body state Vbl) Vbl)
  \<Longrightarrow> solve_loop_dom state Vbl"

definition solve::"Formula \<Rightarrow> ExtendedBool"
where
"solve F0 =
    (getSATFlag
        (solve_loop
            (initialize F0 initialState) (vars F0)
        )
    )
"

(*
code_modulename SML
  Nat Numbers
  Int Numbers
  Ring_and_Field Numbers

code_modulename OCaml
  Nat Numbers
  Int Numbers
  Ring_and_Field Numbers

export_code solve in OCaml file "code/solve.ML"
                  in SML file "code/solve.ocaml
                  in Haskell file "code/"
*)

(******************************************************************************)
(*      I N V A R I A N T S                                                   *)
(******************************************************************************)

definition
InvariantWatchListsContainOnlyClausesFromF :: "(Literal \<Rightarrow> nat list) \<Rightarrow> Formula \<Rightarrow> bool"
where
"InvariantWatchListsContainOnlyClausesFromF Wl F =
    (\<forall> (l::Literal) (c::nat). c \<in>  set (Wl l) \<longrightarrow> 0 \<le> c \<and> c < length F)
"

definition
InvariantWatchListsUniq :: "(Literal \<Rightarrow> nat list) \<Rightarrow> bool"
where
"InvariantWatchListsUniq Wl =
    (\<forall> l. uniq (Wl l))
"

definition
InvariantWatchListsCharacterization :: "(Literal \<Rightarrow> nat list) \<Rightarrow> (nat \<Rightarrow> Literal option) \<Rightarrow> (nat \<Rightarrow> Literal option) \<Rightarrow> bool"
where
"InvariantWatchListsCharacterization Wl w1 w2 =
    (\<forall> (c::nat) (l::Literal). c \<in> set (Wl l) = (Some l = (w1 c) \<or> Some l = (w2 c)))
"

definition
InvariantWatchesEl :: "Formula \<Rightarrow> (nat \<Rightarrow> Literal option) \<Rightarrow> (nat \<Rightarrow> Literal option) \<Rightarrow> bool"
where
"InvariantWatchesEl formula watch1 watch2 ==
    \<forall> (clause::nat). 0 \<le> clause \<and> clause < length formula \<longrightarrow>
        (\<exists> (w1::Literal) (w2::Literal). watch1 clause = Some w1 \<and> watch2 clause = Some w2 \<and>
             w1 el (nth formula clause) \<and> w2 el (nth formula clause))
"

definition
InvariantWatchesDiffer :: "Formula \<Rightarrow> (nat \<Rightarrow> Literal option) \<Rightarrow> (nat \<Rightarrow> Literal option) \<Rightarrow> bool"
where
"InvariantWatchesDiffer formula watch1 watch2 ==
    \<forall> (clause::nat). 0 \<le> clause \<and> clause < length formula \<longrightarrow> watch1 clause \<noteq> watch2 clause
"

definition
watchCharacterizationCondition::"Literal \<Rightarrow> Literal \<Rightarrow> LiteralTrail \<Rightarrow> Clause \<Rightarrow> bool"
where
"watchCharacterizationCondition w1 w2 M clause =
    (literalFalse w1 (elements M) \<longrightarrow>
        ( (\<exists> l. l el clause \<and> literalTrue l (elements M) \<and> elementLevel l M \<le> elementLevel (opposite w1) M) \<or>
          (\<forall> l. l el clause \<and> l \<noteq> w1 \<and> l \<noteq> w2 \<longrightarrow>
                literalFalse l (elements M) \<and> elementLevel (opposite l) M \<le> elementLevel (opposite w1) M)
          )
    )
"

definition
InvariantWatchCharacterization::"Formula \<Rightarrow> (nat \<Rightarrow> Literal option) \<Rightarrow> (nat \<Rightarrow> Literal option) \<Rightarrow> LiteralTrail \<Rightarrow> bool"
where
"InvariantWatchCharacterization F watch1 watch2 M =
    (\<forall> c w1 w2. (0 \<le> c \<and> c < length F \<and> Some w1 = watch1 c \<and> Some w2 = watch2 c) \<longrightarrow>
          watchCharacterizationCondition w1 w2 M (nth F c) \<and>
          watchCharacterizationCondition w2 w1 M (nth F c)
    )
"

definition
InvariantQCharacterization :: "bool \<Rightarrow> Literal list \<Rightarrow> Formula \<Rightarrow> LiteralTrail \<Rightarrow> bool"
where
"InvariantQCharacterization conflictFlag Q F M ==
   \<not> conflictFlag \<longrightarrow> (\<forall> (l::Literal). l el Q = (\<exists> (c::Clause). c el F \<and> isUnitClause c l (elements M)))
"

definition
InvariantUniqQ :: "Literal list \<Rightarrow> bool"
where
"InvariantUniqQ Q =
    uniq Q
"

definition
InvariantConflictFlagCharacterization :: "bool \<Rightarrow> Formula \<Rightarrow> LiteralTrail \<Rightarrow> bool"
where
"InvariantConflictFlagCharacterization conflictFlag F M ==
    conflictFlag = formulaFalse F (elements M)
"

definition
InvariantNoDecisionsWhenConflict :: "Formula \<Rightarrow> LiteralTrail \<Rightarrow> nat \<Rightarrow> bool"
where
"InvariantNoDecisionsWhenConflict F M level=
    (\<forall> level'. level' < level \<longrightarrow>
              \<not> formulaFalse F (elements (prefixToLevel level' M))
    )
"

definition
InvariantNoDecisionsWhenUnit :: "Formula \<Rightarrow> LiteralTrail \<Rightarrow> nat \<Rightarrow> bool"
where
"InvariantNoDecisionsWhenUnit F M level =
    (\<forall> level'. level' < level \<longrightarrow>
              \<not> (\<exists> clause literal. clause el F \<and>
                                   isUnitClause clause literal (elements (prefixToLevel level' M)))
    )
"

definition InvariantEquivalentZL :: "Formula \<Rightarrow> LiteralTrail \<Rightarrow> Formula \<Rightarrow> bool"
where
"InvariantEquivalentZL F M F0 =
    equivalentFormulae (F @ val2form (elements (prefixToLevel 0 M))) F0
"

definition
InvariantGetReasonIsReason :: "(Literal \<Rightarrow> nat option) \<Rightarrow> Formula \<Rightarrow> LiteralTrail \<Rightarrow> Literal set \<Rightarrow> bool"
where
"InvariantGetReasonIsReason GetReason F M Q ==
     \<forall> literal. (literal el (elements M) \<and> \<not> literal el (decisions M) \<and> elementLevel literal M > 0 \<longrightarrow>
                   (\<exists> (reason::nat). (GetReason literal) = Some reason \<and> 0 \<le> reason \<and> reason < length F \<and>
                         isReason (nth F reason) literal (elements M)
                   )
                 ) \<and>
                (currentLevel M > 0 \<and> literal \<in> Q \<longrightarrow>
                   (\<exists> (reason::nat). (GetReason literal) = Some reason \<and> 0 \<le> reason \<and> reason < length F \<and>
                         (isUnitClause (nth F reason) literal (elements M) \<or> clauseFalse (nth F reason) (elements M))
                   )
                 )
"

definition
InvariantConflictClauseCharacterization :: "bool \<Rightarrow> nat \<Rightarrow> Formula \<Rightarrow> LiteralTrail \<Rightarrow> bool"
where
"InvariantConflictClauseCharacterization conflictFlag conflictClause F M  ==
         conflictFlag \<longrightarrow> (conflictClause < length F \<and>
                           clauseFalse (nth F conflictClause) (elements M))"

definition
InvariantClCharacterization :: "Literal \<Rightarrow> Clause \<Rightarrow> LiteralTrail \<Rightarrow> bool"
where
"InvariantClCharacterization Cl C M ==
  isLastAssertedLiteral Cl (oppositeLiteralList C) (elements M)"

definition
InvariantCllCharacterization :: "Literal \<Rightarrow> Literal \<Rightarrow> Clause \<Rightarrow> LiteralTrail \<Rightarrow> bool"
where
"InvariantCllCharacterization Cl Cll C M ==
  set C \<noteq> {opposite Cl} \<longrightarrow>
      isLastAssertedLiteral Cll (removeAll Cl (oppositeLiteralList C)) (elements M)"

definition
InvariantClCurrentLevel :: "Literal \<Rightarrow> LiteralTrail \<Rightarrow> bool"
where
"InvariantClCurrentLevel Cl M ==
  elementLevel Cl M = currentLevel M"

definition
InvariantCnCharacterization :: "nat \<Rightarrow> Clause \<Rightarrow> LiteralTrail \<Rightarrow> bool"
where
"InvariantCnCharacterization Cn C M ==
  Cn = length (filter (\<lambda> l. elementLevel (opposite l) M = currentLevel M) (remdups C))
"

definition
InvariantUniqC :: "Clause \<Rightarrow> bool"
where
"InvariantUniqC clause = uniq clause"

definition
InvariantVarsQ :: "Literal list \<Rightarrow> Formula \<Rightarrow> Variable set \<Rightarrow> bool"
where
"InvariantVarsQ Q F0 Vbl ==
  vars Q \<subseteq> vars F0 \<union> Vbl"

(******************************************************************************)

end


theory "CR_paper_cert_auto"
imports
  "ESPLogic"
begin

(* section:  The Running Example of Our CSF'10 Paper  *)

role C
where "C =
  [ Send ''1'' ( PEnc ( sN ''k'' ) ( sPK ''S'' ) )
  , Recv ''2'' ( PHash ( sN ''k'' ) )
  ]"

role S
where "S =
  [ Recv ''1'' ( PEnc ( sMV ''k'' ) ( sPK ''S'' ) )
  , Send ''2'' ( PHash ( sMV ''k'' ) )
  ]"

protocol CR
where "CR = { C, S }"

locale restricted_CR_state = CR_state

type_invariant CR_msc_typing for CR
where "CR_msc_typing = mk_typing
  [ ((S, ''k''), (SumT (KnownT S_1) (NonceT C ''k'')))
  ]"

sublocale CR_state < CR_msc_typing_state
proof -
  have "(t,r,s) : approx CR_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF CR_msc_typing.monoTyp, completeness_cases_rule])
    case (S_1_k t r s tid0)
    then interpret state: CR_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_1_k
    thus ?case
    proof(sources! " Enc ( s(MV ''k'' tid0) ) ( PK ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  qed
  thus "CR_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context CR_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

lemma (in restricted_CR_state) C_k_secrecy:
  assumes facts:
    "roleMap r tid0 = Some C"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "LN ''k'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''k'' tid0 ")
  case C_1_k note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_CR_state) C_ni_synch:
  assumes facts:
    "roleMap r tid1 = Some C"
    "RLKR(s(AV ''S'' tid1)) ~: reveals t"
    "( tid1, C_2 ) : steps t"
  shows
    "(?  tid2.
        roleMap r tid2 = Some S &
        s(AV ''S'' tid1) = s(AV ''S'' tid2) &
        LN ''k'' tid1 = s(MV ''k'' tid2) &
        predOrd t (St( tid1, C_1 )) (St( tid2, S_1 )) &
        predOrd t (St( tid2, S_1 )) (St( tid2, S_2 )) &
        predOrd t (St( tid2, S_2 )) (St( tid1, C_2 )))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! " Hash ( LN ''k'' tid1 ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: C_k_secrecy intro: event_predOrdI)
  next
    case (S_2_hash tid2) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc ( LN ''k'' tid1 ) ( PK ( s(AV ''S'' tid2) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: C_k_secrecy intro: event_predOrdI)
    next
      case (C_1_enc tid3) note_unified facts = this facts
      thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end


(*  Title:       Deriving class instances for datatypes
    Author:      Christian Sternagel and René Thiemann  <christian.sternagel|rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)
section \<open>Generating Hash-Functions\<close>

theory Hash_Generator
imports
  "../Generator_Aux"
  "../Derive_Manager"
  Collections.HashCode
begin

text \<open>As usual, in the generator we use a dedicated function to combine the results
  from evaluating the hash-function of the arguments of a constructor, to deliver
  the global hash-value.\<close>

fun hash_combine :: "hashcode list \<Rightarrow> hashcode list \<Rightarrow> hashcode" where
  "hash_combine [] [x] = x"
| "hash_combine (y # ys) (z # zs) = y * z + hash_combine ys zs"
| "hash_combine _ _ = 0"

text \<open>The first argument of @{const hash_combine} originates from evaluating the hash-function
  on the arguments of a constructor, and the second argument of @{const hash_combine} will be static \emph{magic} numbers
  which are generated within the generator.\<close>

subsection \<open>Improved Code for Non-Lazy Languages\<close>

lemma hash_combine_unfold:
  "hash_combine [] [x] = x"
  "hash_combine (y # ys) (z # zs) = y * z + hash_combine ys zs"
  by auto

subsection \<open>The Generator\<close>

ML_file \<open>hash_generator.ML\<close>

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* License: BSD, terms see file ./LICENSE *)

theory Addr_Type
imports "HOL-Word.Word"
begin

type_synonym addr_bitsize = "64"
type_synonym addr = "addr_bitsize word"
definition addr_bitsize :: nat where "addr_bitsize \<equiv> 64"
definition addr_align :: nat where "addr_align \<equiv> 3"
declare addr_align_def[simp]

definition addr_card :: nat where
  "addr_card \<equiv> card (UNIV::addr set)"

declare addr_bitsize_def[simp]

lemma addr_card:
  "addr_card = 2^addr_bitsize"
  by (simp add: addr_card_def card_word)

lemma len_of_addr_card:
  "2 ^ len_of TYPE(addr_bitsize) = addr_card"
  by (simp add: addr_card)

lemma of_nat_addr_card [simp]:
  "of_nat addr_card = (0::addr)"
  by (simp add: addr_card)

end