(*  Title:      ZF/UNITY/SubstAx.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge

Theory ported from HOL.
*)

section\<open>Weak LeadsTo relation (restricted to the set of reachable states)\<close>

theory SubstAx
imports WFair Constrains
begin

definition
  (* The definitions below are not `conventional', but yield simpler rules *)
  Ensures :: "[i,i] => i"            (infixl \<open>Ensures\<close> 60)  where
  "A Ensures B == {F \<in> program. F \<in> (reachable(F) \<inter> A) ensures (reachable(F) \<inter> B) }"

definition
  LeadsTo :: "[i, i] => i"            (infixl \<open>\<longmapsto>w\<close> 60)  where
  "A \<longmapsto>w B == {F \<in> program. F:(reachable(F) \<inter> A) \<longmapsto> (reachable(F) \<inter> B)}"

(*Resembles the previous definition of LeadsTo*)

(* Equivalence with the HOL-like definition *)
lemma LeadsTo_eq:
"st_set(B)==> A \<longmapsto>w B = {F \<in> program. F:(reachable(F) \<inter> A) \<longmapsto> B}"
apply (unfold LeadsTo_def)
apply (blast dest: psp_stable2 leadsToD2 constrainsD2 intro: leadsTo_weaken)
done

lemma LeadsTo_type: "A \<longmapsto>w B <=program"
by (unfold LeadsTo_def, auto)

(*** Specialized laws for handling invariants ***)

(** Conjoining an Always property **)
lemma Always_LeadsTo_pre: "F \<in> Always(I) ==> (F:(I \<inter> A) \<longmapsto>w A') \<longleftrightarrow> (F \<in> A \<longmapsto>w A')"
by (simp add: LeadsTo_def Always_eq_includes_reachable Int_absorb2 Int_assoc [symmetric] leadsToD2)

lemma Always_LeadsTo_post: "F \<in> Always(I) ==> (F \<in> A \<longmapsto>w (I \<inter> A')) \<longleftrightarrow> (F \<in> A \<longmapsto>w A')"
apply (unfold LeadsTo_def)
apply (simp add: Always_eq_includes_reachable Int_absorb2 Int_assoc [symmetric] leadsToD2)
done

(* Like 'Always_LeadsTo_pre RS iffD1', but with premises in the good order *)
lemma Always_LeadsToI: "[| F \<in> Always(C); F \<in> (C \<inter> A) \<longmapsto>w A' |] ==> F \<in> A \<longmapsto>w A'"
by (blast intro: Always_LeadsTo_pre [THEN iffD1])

(* Like 'Always_LeadsTo_post RS iffD2', but with premises in the good order *)
lemma Always_LeadsToD: "[| F \<in> Always(C);  F \<in> A \<longmapsto>w A' |] ==> F \<in> A \<longmapsto>w (C \<inter> A')"
by (blast intro: Always_LeadsTo_post [THEN iffD2])

(*** Introduction rules \<in> Basis, Trans, Union ***)

lemma LeadsTo_Basis: "F \<in> A Ensures B ==> F \<in> A \<longmapsto>w B"
by (auto simp add: Ensures_def LeadsTo_def)

lemma LeadsTo_Trans:
     "[| F \<in> A \<longmapsto>w B;  F \<in> B \<longmapsto>w C |] ==> F \<in> A \<longmapsto>w C"
apply (simp (no_asm_use) add: LeadsTo_def)
apply (blast intro: leadsTo_Trans)
done

lemma LeadsTo_Union:
"[|(!!A. A \<in> S ==> F \<in> A \<longmapsto>w B); F \<in> program|]==>F \<in> \<Union>(S) \<longmapsto>w B"
apply (simp add: LeadsTo_def)
apply (subst Int_Union_Union2)
apply (rule leadsTo_UN, auto)
done

(*** Derived rules ***)

lemma leadsTo_imp_LeadsTo: "F \<in> A \<longmapsto> B ==> F \<in> A \<longmapsto>w B"
apply (frule leadsToD2, clarify)
apply (simp (no_asm_simp) add: LeadsTo_eq)
apply (blast intro: leadsTo_weaken_L)
done

(*Useful with cancellation, disjunction*)
lemma LeadsTo_Un_duplicate: "F \<in> A \<longmapsto>w (A' \<union> A') ==> F \<in> A \<longmapsto>w A'"
by (simp add: Un_ac)

lemma LeadsTo_Un_duplicate2:
     "F \<in> A \<longmapsto>w (A' \<union> C \<union> C) ==> F \<in> A \<longmapsto>w (A' \<union> C)"
by (simp add: Un_ac)

lemma LeadsTo_UN:
    "[|(!!i. i \<in> I ==> F \<in> A(i) \<longmapsto>w B); F \<in> program|]
     ==>F:(\<Union>i \<in> I. A(i)) \<longmapsto>w B"
apply (simp add: LeadsTo_def)
apply (simp (no_asm_simp) del: UN_simps add: Int_UN_distrib)
apply (rule leadsTo_UN, auto)
done

(*Binary union introduction rule*)
lemma LeadsTo_Un:
     "[| F \<in> A \<longmapsto>w C; F \<in> B \<longmapsto>w C |] ==> F \<in> (A \<union> B) \<longmapsto>w C"
apply (subst Un_eq_Union)
apply (rule LeadsTo_Union)
apply (auto dest: LeadsTo_type [THEN subsetD])
done

(*Lets us look at the starting state*)
lemma single_LeadsTo_I:
    "[|(!!s. s \<in> A ==> F:{s} \<longmapsto>w B); F \<in> program|]==>F \<in> A \<longmapsto>w B"
apply (subst UN_singleton [symmetric], rule LeadsTo_UN, auto)
done

lemma subset_imp_LeadsTo: "[| A \<subseteq> B; F \<in> program |] ==> F \<in> A \<longmapsto>w B"
apply (simp (no_asm_simp) add: LeadsTo_def)
apply (blast intro: subset_imp_leadsTo)
done

lemma empty_LeadsTo: "F \<in> 0 \<longmapsto>w A \<longleftrightarrow> F \<in> program"
by (auto dest: LeadsTo_type [THEN subsetD]
            intro: empty_subsetI [THEN subset_imp_LeadsTo])
declare empty_LeadsTo [iff]

lemma LeadsTo_state: "F \<in> A \<longmapsto>w state \<longleftrightarrow> F \<in> program"
by (auto dest: LeadsTo_type [THEN subsetD] simp add: LeadsTo_eq)
declare LeadsTo_state [iff]

lemma LeadsTo_weaken_R: "[| F \<in> A \<longmapsto>w A';  A'<=B'|] ==> F \<in> A \<longmapsto>w B'"
apply (unfold LeadsTo_def)
apply (auto intro: leadsTo_weaken_R)
done

lemma LeadsTo_weaken_L: "[| F \<in> A \<longmapsto>w A'; B \<subseteq> A |] ==> F \<in> B \<longmapsto>w A'"
apply (unfold LeadsTo_def)
apply (auto intro: leadsTo_weaken_L)
done

lemma LeadsTo_weaken: "[| F \<in> A \<longmapsto>w A'; B<=A; A'<=B' |] ==> F \<in> B \<longmapsto>w B'"
by (blast intro: LeadsTo_weaken_R LeadsTo_weaken_L LeadsTo_Trans)

lemma Always_LeadsTo_weaken:
"[| F \<in> Always(C);  F \<in> A \<longmapsto>w A'; C \<inter> B \<subseteq> A;   C \<inter> A' \<subseteq> B' |]
      ==> F \<in> B \<longmapsto>w B'"
apply (blast dest: Always_LeadsToI intro: LeadsTo_weaken Always_LeadsToD)
done

(** Two theorems for "proof lattices" **)

lemma LeadsTo_Un_post: "F \<in> A \<longmapsto>w B ==> F:(A \<union> B) \<longmapsto>w B"
by (blast dest: LeadsTo_type [THEN subsetD]
             intro: LeadsTo_Un subset_imp_LeadsTo)

lemma LeadsTo_Trans_Un: "[| F \<in> A \<longmapsto>w B;  F \<in> B \<longmapsto>w C |]
      ==> F \<in> (A \<union> B) \<longmapsto>w C"
apply (blast intro: LeadsTo_Un subset_imp_LeadsTo LeadsTo_weaken_L LeadsTo_Trans dest: LeadsTo_type [THEN subsetD])
done

(** Distributive laws **)
lemma LeadsTo_Un_distrib: "(F \<in> (A \<union> B) \<longmapsto>w C)  \<longleftrightarrow> (F \<in> A \<longmapsto>w C & F \<in> B \<longmapsto>w C)"
by (blast intro: LeadsTo_Un LeadsTo_weaken_L)

lemma LeadsTo_UN_distrib: "(F \<in> (\<Union>i \<in> I. A(i)) \<longmapsto>w B) \<longleftrightarrow>  (\<forall>i \<in> I. F \<in> A(i) \<longmapsto>w B) & F \<in> program"
by (blast dest: LeadsTo_type [THEN subsetD]
             intro: LeadsTo_UN LeadsTo_weaken_L)

lemma LeadsTo_Union_distrib: "(F \<in> \<Union>(S) \<longmapsto>w B)  \<longleftrightarrow>  (\<forall>A \<in> S. F \<in> A \<longmapsto>w B) & F \<in> program"
by (blast dest: LeadsTo_type [THEN subsetD]
             intro: LeadsTo_Union LeadsTo_weaken_L)

(** More rules using the premise "Always(I)" **)

lemma EnsuresI: "[| F:(A-B) Co (A \<union> B);  F \<in> transient (A-B) |] ==> F \<in> A Ensures B"
apply (simp add: Ensures_def Constrains_eq_constrains)
apply (blast intro: ensuresI constrains_weaken transient_strengthen dest: constrainsD2)
done

lemma Always_LeadsTo_Basis: "[| F \<in> Always(I); F \<in> (I \<inter> (A-A')) Co (A \<union> A');
         F \<in> transient (I \<inter> (A-A')) |]
  ==> F \<in> A \<longmapsto>w A'"
apply (rule Always_LeadsToI, assumption)
apply (blast intro: EnsuresI LeadsTo_Basis Always_ConstrainsD [THEN Constrains_weaken] transient_strengthen)
done

(*Set difference: maybe combine with leadsTo_weaken_L??
  This is the most useful form of the "disjunction" rule*)
lemma LeadsTo_Diff:
     "[| F \<in> (A-B) \<longmapsto>w C;  F \<in> (A \<inter> B) \<longmapsto>w C |] ==> F \<in> A \<longmapsto>w C"
by (blast intro: LeadsTo_Un LeadsTo_weaken)

lemma LeadsTo_UN_UN:
     "[|(!!i. i \<in> I ==> F \<in> A(i) \<longmapsto>w A'(i)); F \<in> program |]
      ==> F \<in> (\<Union>i \<in> I. A(i)) \<longmapsto>w (\<Union>i \<in> I. A'(i))"
apply (rule LeadsTo_Union, auto)
apply (blast intro: LeadsTo_weaken_R)
done

(*Binary union version*)
lemma LeadsTo_Un_Un:
  "[| F \<in> A \<longmapsto>w A'; F \<in> B \<longmapsto>w B' |] ==> F:(A \<union> B) \<longmapsto>w (A' \<union> B')"
by (blast intro: LeadsTo_Un LeadsTo_weaken_R)

(** The cancellation law **)

lemma LeadsTo_cancel2: "[| F \<in> A \<longmapsto>w(A' \<union> B); F \<in> B \<longmapsto>w B' |] ==> F \<in> A \<longmapsto>w (A' \<union> B')"
by (blast intro: LeadsTo_Un_Un subset_imp_LeadsTo LeadsTo_Trans dest: LeadsTo_type [THEN subsetD])

lemma Un_Diff: "A \<union> (B - A) = A \<union> B"
by auto

lemma LeadsTo_cancel_Diff2: "[| F \<in> A \<longmapsto>w (A' \<union> B); F \<in> (B-A') \<longmapsto>w B' |] ==> F \<in> A \<longmapsto>w (A' \<union> B')"
apply (rule LeadsTo_cancel2)
prefer 2 apply assumption
apply (simp (no_asm_simp) add: Un_Diff)
done

lemma LeadsTo_cancel1: "[| F \<in> A \<longmapsto>w (B \<union> A'); F \<in> B \<longmapsto>w B' |] ==> F \<in> A \<longmapsto>w (B' \<union> A')"
apply (simp add: Un_commute)
apply (blast intro!: LeadsTo_cancel2)
done

lemma Diff_Un2: "(B - A) \<union> A = B \<union> A"
by auto

lemma LeadsTo_cancel_Diff1: "[| F \<in> A \<longmapsto>w (B \<union> A'); F \<in> (B-A') \<longmapsto>w B' |] ==> F \<in> A \<longmapsto>w (B' \<union> A')"
apply (rule LeadsTo_cancel1)
prefer 2 apply assumption
apply (simp (no_asm_simp) add: Diff_Un2)
done

(** The impossibility law **)

(*The set "A" may be non-empty, but it contains no reachable states*)
lemma LeadsTo_empty: "F \<in> A \<longmapsto>w 0 ==> F \<in> Always (state -A)"
apply (simp (no_asm_use) add: LeadsTo_def Always_eq_includes_reachable)
apply (cut_tac reachable_type)
apply (auto dest!: leadsTo_empty)
done

(** PSP \<in> Progress-Safety-Progress **)

(*Special case of PSP \<in> Misra's "stable conjunction"*)
lemma PSP_Stable: "[| F \<in> A \<longmapsto>w A';  F \<in> Stable(B) |]==> F:(A \<inter> B) \<longmapsto>w (A' \<inter> B)"
apply (simp add: LeadsTo_def Stable_eq_stable, clarify)
apply (drule psp_stable, assumption)
apply (simp add: Int_ac)
done

lemma PSP_Stable2: "[| F \<in> A \<longmapsto>w A'; F \<in> Stable(B) |] ==> F \<in> (B \<inter> A) \<longmapsto>w (B \<inter> A')"
apply (simp (no_asm_simp) add: PSP_Stable Int_ac)
done

lemma PSP: "[| F \<in> A \<longmapsto>w A'; F \<in> B Co B'|]==> F \<in> (A \<inter> B') \<longmapsto>w ((A' \<inter> B) \<union> (B' - B))"
apply (simp (no_asm_use) add: LeadsTo_def Constrains_eq_constrains)
apply (blast dest: psp intro: leadsTo_weaken)
done

lemma PSP2: "[| F \<in> A \<longmapsto>w A'; F \<in> B Co B' |]==> F:(B' \<inter> A) \<longmapsto>w ((B \<inter> A') \<union> (B' - B))"
by (simp (no_asm_simp) add: PSP Int_ac)

lemma PSP_Unless:
"[| F \<in> A \<longmapsto>w A'; F \<in> B Unless B'|]==> F:(A \<inter> B) \<longmapsto>w ((A' \<inter> B) \<union> B')"
apply (unfold op_Unless_def)
apply (drule PSP, assumption)
apply (blast intro: LeadsTo_Diff LeadsTo_weaken subset_imp_LeadsTo)
done

(*** Induction rules ***)

(** Meta or object quantifier ????? **)
lemma LeadsTo_wf_induct: "[| wf(r);
         \<forall>m \<in> I. F \<in> (A \<inter> f-``{m}) \<longmapsto>w
                            ((A \<inter> f-``(converse(r) `` {m})) \<union> B);
         field(r)<=I; A<=f-``I; F \<in> program |]
      ==> F \<in> A \<longmapsto>w B"
apply (simp (no_asm_use) add: LeadsTo_def)
apply auto
apply (erule_tac I = I and f = f in leadsTo_wf_induct, safe)
apply (drule_tac [2] x = m in bspec, safe)
apply (rule_tac [2] A' = "reachable (F) \<inter> (A \<inter> f -`` (converse (r) ``{m}) \<union> B) " in leadsTo_weaken_R)
apply (auto simp add: Int_assoc)
done

lemma LessThan_induct: "[| \<forall>m \<in> nat. F:(A \<inter> f-``{m}) \<longmapsto>w ((A \<inter> f-``m) \<union> B);
      A<=f-``nat; F \<in> program |] ==> F \<in> A \<longmapsto>w B"
apply (rule_tac A1 = nat and f1 = "%x. x" in wf_measure [THEN LeadsTo_wf_induct])
apply (simp_all add: nat_measure_field)
apply (simp add: ltI Image_inverse_lessThan vimage_def [symmetric])
done

(******
 To be ported ??? I am not sure.

  integ_0_le_induct
  LessThan_bounded_induct
  GreaterThan_bounded_induct

*****)

(*** Completion \<in> Binary and General Finite versions ***)

lemma Completion: "[| F \<in> A \<longmapsto>w (A' \<union> C);  F \<in> A' Co (A' \<union> C);
         F \<in> B \<longmapsto>w (B' \<union> C);  F \<in> B' Co (B' \<union> C) |]
      ==> F \<in> (A \<inter> B) \<longmapsto>w ((A' \<inter> B') \<union> C)"
apply (simp (no_asm_use) add: LeadsTo_def Constrains_eq_constrains Int_Un_distrib)
apply (blast intro: completion leadsTo_weaken)
done

lemma Finite_completion_aux:
     "[| I \<in> Fin(X);F \<in> program |]
      ==> (\<forall>i \<in> I. F \<in> (A(i)) \<longmapsto>w (A'(i) \<union> C)) \<longrightarrow>
          (\<forall>i \<in> I. F \<in> (A'(i)) Co (A'(i) \<union> C)) \<longrightarrow>
          F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto>w ((\<Inter>i \<in> I. A'(i)) \<union> C)"
apply (erule Fin_induct)
apply (auto simp del: INT_simps simp add: Inter_0)
apply (rule Completion, auto)
apply (simp del: INT_simps add: INT_extend_simps)
apply (blast intro: Constrains_INT)
done

lemma Finite_completion:
     "[| I \<in> Fin(X); !!i. i \<in> I ==> F \<in> A(i) \<longmapsto>w (A'(i) \<union> C);
         !!i. i \<in> I ==> F \<in> A'(i) Co (A'(i) \<union> C);
         F \<in> program |]
      ==> F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto>w ((\<Inter>i \<in> I. A'(i)) \<union> C)"
by (blast intro: Finite_completion_aux [THEN mp, THEN mp])

lemma Stable_completion:
     "[| F \<in> A \<longmapsto>w A';  F \<in> Stable(A');
         F \<in> B \<longmapsto>w B';  F \<in> Stable(B') |]
    ==> F \<in> (A \<inter> B) \<longmapsto>w (A' \<inter> B')"
apply (unfold Stable_def)
apply (rule_tac C1 = 0 in Completion [THEN LeadsTo_weaken_R])
    prefer 5
    apply blast
apply auto
done

lemma Finite_stable_completion:
     "[| I \<in> Fin(X);
         (!!i. i \<in> I ==> F \<in> A(i) \<longmapsto>w A'(i));
         (!!i. i \<in> I ==>F \<in> Stable(A'(i)));   F \<in> program  |]
      ==> F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto>w (\<Inter>i \<in> I. A'(i))"
apply (unfold Stable_def)
apply (rule_tac C1 = 0 in Finite_completion [THEN LeadsTo_weaken_R], simp_all)
apply (rule_tac [3] subset_refl, auto)
done

ML \<open>
(*proves "ensures/leadsTo" properties when the program is specified*)
fun ensures_tac ctxt sact =
  SELECT_GOAL
    (EVERY [REPEAT (Always_Int_tac ctxt 1),
            eresolve_tac ctxt @{thms Always_LeadsTo_Basis} 1
                ORELSE   (*subgoal may involve LeadsTo, leadsTo or ensures*)
                REPEAT (ares_tac ctxt [@{thm LeadsTo_Basis}, @{thm leadsTo_Basis},
                                  @{thm EnsuresI}, @{thm ensuresI}] 1),
            (*now there are two subgoals: co & transient*)
            simp_tac (ctxt addsimps (Named_Theorems.get ctxt \<^named_theorems>\<open>program\<close>)) 2,
            Rule_Insts.res_inst_tac ctxt
              [((("act", 0), Position.none), sact)] [] @{thm transientI} 2,
               (*simplify the command's domain*)
            simp_tac (ctxt addsimps [@{thm domain_def}]) 3,
            (* proving the domain part *)
           clarify_tac ctxt 3,
           dresolve_tac ctxt @{thms swap} 3, force_tac ctxt 4,
           resolve_tac ctxt @{thms ReplaceI} 3, force_tac ctxt 3, force_tac ctxt 4,
           asm_full_simp_tac ctxt 3, resolve_tac ctxt @{thms conjI} 3, simp_tac ctxt 4,
           REPEAT (resolve_tac ctxt @{thms state_update_type} 3),
           constrains_tac ctxt 1,
           ALLGOALS (clarify_tac ctxt),
           ALLGOALS (asm_full_simp_tac (ctxt addsimps [@{thm st_set_def}])),
                      ALLGOALS (clarify_tac ctxt),
          ALLGOALS (asm_lr_simp_tac ctxt)]);
\<close>

method_setup ensures = \<open>
    Args.goal_spec -- Scan.lift Args.embedded_inner_syntax >>
    (fn (quant, s) => fn ctxt => SIMPLE_METHOD'' quant (ensures_tac ctxt s))
\<close> "for proving progress properties"

end


theory Channel
  imports
    "../Fused_Resource"
begin

section \<open>Channel specification\<close>

locale ideal_channel =
  fixes
  (*TODO: decide to either include or exlude this fixation,
    - if it is not included, then the types must be manually stated whenever channel locale is imported (c.f. OTP and DH)
    - also, the WT_intro rules for channel will have an unspecified valid_messages*)
  (*  valid_messages :: "'msg set" and*)
    leak :: "'msg \<Rightarrow> 'leak" and
    editable :: bool
begin

subsection \<open>Data-types for Parties, State, Events, Input, and Output\<close>

datatype party = Alice | Bob

type_synonym s_shell = "party set"
datatype 'msg' s_kernel =  State_Void | State_Store 'msg' | State_Collect 'msg' | State_Collected
type_synonym 'msg' state = "'msg' s_kernel \<times> s_shell"

datatype event = Event_Shell party

datatype iadv_drop = Inp_Drop
datatype iadv_look = Inp_Look
datatype 'msg' iadv_fedit = Inp_Fedit 'msg'
type_synonym 'msg' iadv = "iadv_drop + iadv_look + 'msg' iadv_fedit"

datatype 'msg' iusr_alice = Inp_Send 'msg'
datatype iusr_bob = Inp_Recv
type_synonym 'msg' iusr = "'msg' iusr_alice + iusr_bob"

datatype oadv_drop = Out_Drop
datatype 'leak' oadv_look = Out_Look 'leak'
datatype oadv_fedit = Out_Fedit
type_synonym 'leak' oadv = "oadv_drop + 'leak' oadv_look + oadv_fedit"

datatype ousr_alice = Out_Send
datatype 'msg' ousr_bob = Out_Recv 'msg'
type_synonym 'msg' ousr = "ousr_alice + 'msg' ousr_bob"

subsubsection \<open>Basic lemmas for automated handling of party sets (i.e. @{text s_shell})\<close>

lemma Alice_neq_iff [simp]: "Alice \<noteq> x \<longleftrightarrow> x = Bob"
  by(cases x) simp_all

lemma neq_Alice_iff [simp]: "x \<noteq> Alice \<longleftrightarrow> x = Bob"
  by(cases x) simp_all

lemma Bob_neq_iff [simp]: "Bob \<noteq> x \<longleftrightarrow> x = Alice"
  by(cases x) simp_all

lemma neq_Bob_iff [simp]: "x \<noteq> Bob \<longleftrightarrow> x = Alice"
  by(cases x) simp_all

lemma Alice_in_iff_nonempty: "Alice \<in> A \<longleftrightarrow> A \<noteq> {}" if "Bob \<notin> A"
  using that by(auto)(metis (full_types) party.exhaust)

lemma Bob_in_iff_nonempty: "Bob \<in> A \<longleftrightarrow> A \<noteq> {}" if "Alice \<notin> A"
  using that by(auto)(metis (full_types) party.exhaust)

subsection \<open>Defining the event handler\<close>

fun poke :: "('msg state, event) handler"
  where
    "poke (s_kernel, parties) (Event_Shell party) =
      (if party \<in> parties then
        return_pmf None
      else
        return_spmf (s_kernel, insert party parties))"

lemma poke_alt_def:
  "poke = (\<lambda>(s, ps) e. map_spmf (Pair s) (case e of Event_Shell party \<Rightarrow> if party \<in> ps then return_pmf None else return_spmf (insert party ps)))"
  by(simp add: fun_eq_iff split: event.split)

subsection \<open>Defining the adversary interfaces\<close>

fun iface_drop :: "('msg state, iadv_drop, oadv_drop) oracle'"
  where
    "iface_drop _ _ = return_pmf None"

fun iface_look :: "('msg state, iadv_look, 'leak oadv_look) oracle'"
  where
    "iface_look (State_Store msg, parties) _ =
      return_spmf (Out_Look (leak msg), State_Store msg, parties)"
  | "iface_look _ _ = return_pmf None"

fun iface_fedit :: "('msg state, 'msg iadv_fedit, oadv_fedit) oracle'"
  where
    "iface_fedit (State_Store msg, parties) (Inp_Fedit msg') =
      (if editable then
        return_spmf (Out_Fedit, State_Collect msg', parties)
      else
        return_spmf (Out_Fedit, State_Collect msg, parties))"
  | "iface_fedit _ _ = return_pmf None"

abbreviation iface_adv :: "('msg state, 'msg iadv, 'leak oadv) oracle'"
  where
    "iface_adv \<equiv> plus_oracle iface_drop (plus_oracle iface_look iface_fedit)"

lemma in_set_spmf_iface_drop: "ys' \<in> set_spmf (iface_drop s x) \<longleftrightarrow> False"
  by simp

lemma in_set_spmf_iface_look: "ys' \<in> set_spmf (iface_look s x) \<longleftrightarrow>
  (\<exists>msg parties. s = (State_Store msg, parties) \<and> ys' = (Out_Look (leak msg), State_Store msg, parties))"
  by(cases "(s, x)" rule: iface_look.cases) simp_all

lemma in_set_spmf_iface_fedit: "ys' \<in> set_spmf (iface_fedit s x) \<longleftrightarrow>
  (\<exists>msg parties msg'. s = (State_Store msg, parties) \<and> x = (Inp_Fedit msg') \<and>
      ys' = (if editable then (Out_Fedit, State_Collect msg', parties) else (Out_Fedit, State_Collect msg, parties)))"
  by(cases "(s, x)" rule: iface_fedit.cases) simp_all

subsection \<open>Defining the user interfaces\<close>

fun iface_alice :: "('msg state, 'msg iusr_alice, ousr_alice) oracle'"
  where
    "iface_alice (State_Void, parties) (Inp_Send msg) =
      (if Alice \<in> parties then
        return_spmf (Out_Send, State_Store msg, parties)
      else
        return_pmf None)"
  | "iface_alice _ _ = return_pmf None"

fun iface_bob :: "('msg state, iusr_bob, 'msg ousr_bob) oracle'"
  where
    "iface_bob (State_Collect msg, parties) _ =
      (if Bob \<in> parties then
        return_spmf (Out_Recv msg, State_Collected, parties)
      else
        return_pmf None)"
  | "iface_bob _ _ = return_pmf None"

abbreviation iface_usr :: "('msg state, 'msg iusr, 'msg ousr) oracle'"
  where
    "iface_usr \<equiv> plus_oracle iface_alice iface_bob"

lemma in_set_spmf_iface_alice: "ys' \<in> set_spmf (iface_alice s x) \<longleftrightarrow>
  (\<exists>parties msg. s = (State_Void, parties) \<and> x = Inp_Send msg \<and> Alice \<in> parties \<and> ys' = (Out_Send, State_Store msg, parties))"
  by(cases "(s, x)" rule: iface_alice.cases) simp_all

lemma in_set_spmf_iface_bob: "ys' \<in> set_spmf (iface_bob s x) \<longleftrightarrow>
  (\<exists>msg parties. s = (State_Collect msg, parties) \<and> Bob \<in> parties \<and> ys' = (Out_Recv msg, State_Collected, parties))"
  by(cases "(s, x)" rule: iface_bob.cases) simp_all

subsection \<open>Defining the Fused Resource\<close>

primcorec core :: "('msg state, event, 'msg iadv, 'msg iusr, 'leak oadv, 'msg ousr) core"
  where
    "cpoke core = poke"
  | "cfunc_adv core = iface_adv"
  | "cfunc_usr core = iface_usr"

sublocale fused_resource core "(State_Void, {})" .

subsubsection \<open>Lemma showing that the resulting resource is well-typed\<close>

lemma WT_core [WT_intro]:
  "WT_core (\<I>_full \<oplus>\<^sub>\<I> (\<I>_full \<oplus>\<^sub>\<I> \<I>_uniform (Inp_Fedit ` valid_messages) UNIV)) (\<I>_uniform (Inp_Send ` valid_messages) UNIV \<oplus>\<^sub>\<I> (\<I>_uniform UNIV (Out_Recv ` valid_messages)))
     (pred_prod (pred_s_kernel (\<lambda>msg. msg \<in> valid_messages)) (\<lambda>_. True)) core"
  apply(rule WT_core.intros)
  subgoal for s e s' by(cases "(s, e)" rule: poke.cases)(auto split: if_split_asm)
  subgoal for s x y s' by(cases "(s, projl (projr x))" rule: iface_look.cases)(auto split: if_split_asm)
  subgoal for s x y s' by(cases "(s, projl x)" rule: iface_alice.cases)(auto split: if_split_asm)
  done

lemma WT_fuse [WT_intro]:
  assumes [WT_intro]: "WT_rest \<I>_adv_rest \<I>_usr_rest I_rest rest"
    shows  "((\<I>_full \<oplus>\<^sub>\<I> (\<I>_full \<oplus>\<^sub>\<I> \<I>_uniform (Inp_Fedit ` valid_messages) UNIV)) \<oplus>\<^sub>\<I> \<I>_adv_rest) \<oplus>\<^sub>\<I>
      ((\<I>_uniform (Inp_Send ` valid_messages) UNIV \<oplus>\<^sub>\<I> \<I>_uniform UNIV (Out_Recv ` valid_messages)) \<oplus>\<^sub>\<I> \<I>_usr_rest) \<turnstile>res resource rest \<surd>"
  by(rule WT_intro)+ simp

end

end


theory Common_Primitive_Matcher
imports Common_Primitive_Matcher_Generic
begin

subsection\<open>Primitive Matchers: IP Port Iface Matcher\<close>

(*IPv4 matcher*)
fun common_matcher :: "('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac" where
  "common_matcher (IIface i) p = bool_to_ternary (match_iface i (p_iiface p))" |
  "common_matcher (OIface i) p = bool_to_ternary (match_iface i (p_oiface p))" |

  "common_matcher (Src ip) p = bool_to_ternary (p_src p \<in> ipt_iprange_to_set ip)" |
  "common_matcher (Dst ip) p = bool_to_ternary (p_dst p \<in> ipt_iprange_to_set ip)" |

  "common_matcher (Prot proto) p = bool_to_ternary (match_proto proto (p_proto p))" |

  "common_matcher (Src_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p \<and> p_sport p \<in> ports_to_set ps)" |
  "common_matcher (Dst_Ports (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p \<and> p_dport p \<in> ports_to_set ps)" |

  "common_matcher (MultiportPorts (L4Ports proto ps)) p = bool_to_ternary (proto = p_proto p \<and> (p_sport p \<in> ports_to_set ps \<or> p_dport p \<in> ports_to_set ps))" |

  "common_matcher (L4_Flags flags) p = bool_to_ternary (match_tcp_flags flags (p_tcp_flags p))" |

  "common_matcher (CT_State S) p = bool_to_ternary (match_ctstate S (p_tag_ctstate p))" |

  "common_matcher (Extra _) p = TernaryUnknown"

lemma packet_independent_\<beta>_unknown_common_matcher: "packet_independent_\<beta>_unknown common_matcher"
  apply(simp add: packet_independent_\<beta>_unknown_def)
  apply(clarify)
  apply(rename_tac a p1 p2)
  apply(case_tac a)
             apply(simp_all add: bool_to_ternary_Unknown)
     apply(rename_tac l4ports, case_tac l4ports; simp add: bool_to_ternary_Unknown; fail)+
  done

lemma primitive_matcher_generic_common_matcher: "primitive_matcher_generic common_matcher"
  by unfold_locales  simp_all

  (* What if we specify a port range where the start port is greater than the end port?
    For example, mathematically, {3 .. 2} = {}. Does iptables have the same behavior?
    For example, --source-port 1:0 raises an error on my system. For normal port specification, -m tcp, and -m multiport.
    There is also a manpage which states "if the first port is greater than the second one they will be swapped."
    I also saw a system where such an empty port range (--source-port 1:0) was really this impossible range and caused a rule that could never match.
    Because \<nexists> port. port \<in> {}.
    The behaviour if the end of the port range is smaller than the start is not 100% consistent among iptables versions and different modules.
    In general, it would be best to raise an error if such a range occurs.
    *)

  text\<open>Warning: beware of the sloppy term `empty' portrange\<close>
  text\<open>An `empty' port range means it can never match! Basically, @{term "MatchNot (Match (Src_Ports (L4Ports proto [(0,65535)])))"} is False\<close>
  lemma "\<not> matches (common_matcher, \<alpha>) (MatchNot (Match (Src_Ports (L4Ports TCP [(0,65535)])))) a
          \<lparr>p_iiface = ''eth0'', p_oiface = ''eth1'',
           p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
           p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
           p_payload = '''', p_tag_ctstate = CT_New\<rparr>"
       by(simp add: primitive_matcher_generic_common_matcher primitive_matcher_generic.Ports_single_not)
  text\<open>An `empty' port range means it always matches! Basically, @{term "(MatchNot (Match (Src_Ports (L4Ports any []))))"} is True.
        This corresponds to firewall behavior, but usually you cannot specify an empty portrange in firewalls, but omission of portrange means no-port-restrictions,
        i.e. every port matches.\<close>
  lemma "matches (common_matcher, \<alpha>) (MatchNot (Match (Src_Ports (L4Ports any [])))) a
          \<lparr>p_iiface = ''eth0'', p_oiface = ''eth1'',
           p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
           p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
           p_payload = '''', p_tag_ctstate = CT_New\<rparr>"
       by(simp add: primitive_matcher_generic_common_matcher primitive_matcher_generic.Ports_single_not)
  text\<open>If not a corner case, portrange matching is straight forward.\<close>
  lemma "matches (common_matcher, \<alpha>) (Match (Src_Ports (L4Ports TCP [(1024,4096), (9999, 65535)]))) a
          \<lparr>p_iiface = ''eth0'', p_oiface = ''eth1'',
           p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
           p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
           p_payload = '''', p_tag_ctstate = CT_New\<rparr>"
        "\<not> matches (common_matcher, \<alpha>) (Match (Src_Ports (L4Ports TCP [(1024,4096), (9999, 65535)]))) a
          \<lparr>p_iiface = ''eth0'', p_oiface = ''eth1'',
           p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
           p_proto=TCP, p_sport=5000, p_dport=80, p_tcp_flags = {},
           p_payload = '''', p_tag_ctstate = CT_New\<rparr>"
        "\<not>matches (common_matcher, \<alpha>) (MatchNot (Match (Src_Ports (L4Ports TCP [(1024,4096), (9999, 65535)])))) a
          \<lparr>p_iiface = ''eth0'', p_oiface = ''eth1'',
           p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
           p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {},
           p_payload = '''', p_tag_ctstate = CT_New\<rparr>"
       by(simp_all add: primitive_matcher_generic_common_matcher primitive_matcher_generic.Ports_single_not primitive_matcher_generic.Ports_single)

text\<open>Lemmas when matching on @{term Src} or @{term Dst}\<close>
lemma common_matcher_SrcDst_defined:
  "common_matcher (Src m) p \<noteq> TernaryUnknown"
  "common_matcher (Dst m) p \<noteq> TernaryUnknown"
  "common_matcher (Src_Ports ps) p \<noteq> TernaryUnknown"
  "common_matcher (Dst_Ports ps) p \<noteq> TernaryUnknown"
  "common_matcher (MultiportPorts ps) p \<noteq> TernaryUnknown"
  apply(case_tac [!] m, case_tac [!] ps)
  apply(simp_all add: bool_to_ternary_Unknown)
  done
lemma common_matcher_SrcDst_defined_simp:
  "common_matcher (Src x) p \<noteq> TernaryFalse \<longleftrightarrow> common_matcher (Src x) p = TernaryTrue"
  "common_matcher (Dst x) p \<noteq> TernaryFalse \<longleftrightarrow> common_matcher (Dst x) p = TernaryTrue"
apply (metis eval_ternary_Not.cases common_matcher_SrcDst_defined(1) ternaryvalue.distinct(1))
apply (metis eval_ternary_Not.cases common_matcher_SrcDst_defined(2) ternaryvalue.distinct(1))
done

(*The primitive_matcher_generic does not know anything about IP addresses*)
lemma match_simplematcher_SrcDst:
  "matches (common_matcher, \<alpha>) (Match (Src X)) a p \<longleftrightarrow> p_src  p \<in> ipt_iprange_to_set X"
  "matches (common_matcher, \<alpha>) (Match (Dst X)) a p \<longleftrightarrow> p_dst  p \<in> ipt_iprange_to_set X"
   by(simp_all add: match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split)
lemma match_simplematcher_SrcDst_not:
  "matches (common_matcher, \<alpha>) (MatchNot (Match (Src X))) a p \<longleftrightarrow> p_src  p \<notin> ipt_iprange_to_set X"
  "matches (common_matcher, \<alpha>) (MatchNot (Match (Dst X))) a p \<longleftrightarrow> p_dst  p \<notin> ipt_iprange_to_set X"
   apply(simp_all add: matches_case_ternaryvalue_tuple split: ternaryvalue.split)
   apply(case_tac [!] X)
   apply(simp_all add: bool_to_ternary_simps)
   done
lemma common_matcher_SrcDst_Inter:
  "(\<forall>m\<in>set X. matches (common_matcher, \<alpha>) (Match (Src m)) a p) \<longleftrightarrow> p_src p \<in> (\<Inter>x\<in>set X. ipt_iprange_to_set x)"
  "(\<forall>m\<in>set X. matches (common_matcher, \<alpha>) (Match (Dst m)) a p) \<longleftrightarrow> p_dst p \<in> (\<Inter>x\<in>set X. ipt_iprange_to_set x)"
  by(simp_all add: match_raw_ternary bool_to_ternary_simps split: ternaryvalue.split)

subsection\<open>Basic optimisations\<close>
  text\<open>Perform very basic optimization. Remove matches to primitives which are essentially @{const MatchAny}\<close>
  fun optimize_primitive_univ :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
    "optimize_primitive_univ (Match (Src (IpAddrNetmask _ 0))) = MatchAny" |
    "optimize_primitive_univ (Match (Dst (IpAddrNetmask _ 0))) = MatchAny" |
    (*missing: the other IPs ...*)
    "optimize_primitive_univ (Match (IIface iface)) = (if iface = ifaceAny then MatchAny else (Match (IIface iface)))" |
    "optimize_primitive_univ (Match (OIface iface)) = (if iface = ifaceAny then MatchAny else (Match (OIface iface)))" |
    (*missing: L4Ports. But this introduces a new match, which causes problems.
    "optimize_primitive_univ (Match (Src_Ports (L4Ports proto [(s, e)]))) = (if s = 0 \<and> e = 0xFFFF then (Match (Prot (Proto proto))) else (Match (Src_Ports (L4Ports proto [(s, e)]))))" |
    "optimize_primitive_univ (Match (Dst_Ports (L4Ports proto [(s, e)]))) = (if s = 0 \<and> e = 0xFFFF then (Match (Prot (Proto proto))) else (Match (Dst_Ports (L4Ports proto [(s, e)]))))" |*)
    "optimize_primitive_univ (Match (Prot ProtoAny)) = MatchAny" |
    "optimize_primitive_univ (Match (L4_Flags (TCP_Flags m c))) = (if m = {} \<and> c = {} then MatchAny else (Match (L4_Flags (TCP_Flags m c))))" |
    "optimize_primitive_univ (Match (CT_State ctstate)) = (if ctstate_is_UNIV ctstate then MatchAny else Match (CT_State ctstate))" |
    "optimize_primitive_univ (Match m) = Match m" |
    (*"optimize_primitive_univ (MatchNot (MatchNot m)) = (optimize_primitive_univ m)" | --"needed to preserve normalized condition"*)
    "optimize_primitive_univ (MatchNot m) = (MatchNot (optimize_primitive_univ m))" |
    (*"optimize_primitive_univ (MatchAnd (Match (Extra e1)) (Match (Extra e2))) = optimize_primitive_univ (Match (Extra (e1@'' ''@e2)))" |
      -- "can be done but normalization does not work afterwards"*)
    "optimize_primitive_univ (MatchAnd m1 m2) = MatchAnd (optimize_primitive_univ m1) (optimize_primitive_univ m2)" |
    "optimize_primitive_univ MatchAny = MatchAny"

    lemma optimize_primitive_univ_unchanged_primitives:
    "optimize_primitive_univ (Match a) = (Match a) \<or> optimize_primitive_univ (Match a) = MatchAny"
      by (induction "(Match a)" rule: optimize_primitive_univ.induct)
         (auto split: if_split_asm)

  lemma optimize_primitive_univ_correct_matchexpr: fixes m::"'i::len common_primitive match_expr"
    shows "matches (common_matcher, \<alpha>) m = matches (common_matcher, \<alpha>) (optimize_primitive_univ m)"
    proof(simp add: fun_eq_iff, clarify, rename_tac a p)
      fix a and p :: "('i::len, 'a) tagged_packet_scheme"
      have "(max_word::16 word) =  65535" by(simp add: max_word_def)
      hence port_range: "\<And>s e port. s = 0 \<and> e = 0xFFFF \<longrightarrow> (port::16 word) \<le> 0xFFFF" by simp
      have "ternary_ternary_eval (map_match_tac common_matcher p m) = ternary_ternary_eval (map_match_tac common_matcher p (optimize_primitive_univ m))"
        apply(induction m rule: optimize_primitive_univ.induct)
                               by(simp_all add: port_range match_ifaceAny ipset_from_cidr_0 ctstate_is_UNIV)
         (*by(fastforce intro: arg_cong[where f=bool_to_ternary])+ if we add pots again*)
      thus "matches (common_matcher, \<alpha>) m a p = matches (common_matcher, \<alpha>) (optimize_primitive_univ m) a p"
        by(rule matches_iff_apply_f)
      qed

  corollary optimize_primitive_univ_correct: "approximating_bigstep_fun (common_matcher, \<alpha>) p (optimize_matches optimize_primitive_univ rs) s =
                                              approximating_bigstep_fun (common_matcher, \<alpha>) p rs s"
  using optimize_matches optimize_primitive_univ_correct_matchexpr by metis

subsection\<open>Abstracting over unknowns\<close>
  text\<open>remove @{const Extra} (i.e. @{const TernaryUnknown}) match expressions\<close>
  fun upper_closure_matchexpr :: "action \<Rightarrow> 'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
    "upper_closure_matchexpr _ MatchAny = MatchAny" |
    "upper_closure_matchexpr Accept (Match (Extra _)) = MatchAny" |
    "upper_closure_matchexpr Reject (Match (Extra _)) = MatchNot MatchAny" |
    "upper_closure_matchexpr Drop (Match (Extra _)) = MatchNot MatchAny" |
    "upper_closure_matchexpr _ (Match m) = Match m" |
    "upper_closure_matchexpr Accept (MatchNot (Match (Extra _))) = MatchAny" |
    "upper_closure_matchexpr Drop (MatchNot (Match (Extra _))) = MatchNot MatchAny" |
    "upper_closure_matchexpr Reject (MatchNot (Match (Extra _))) = MatchNot MatchAny" |
    "upper_closure_matchexpr a (MatchNot (MatchNot m)) = upper_closure_matchexpr a m" |
    "upper_closure_matchexpr a (MatchNot (MatchAnd m1 m2)) =
      (let m1' = upper_closure_matchexpr a (MatchNot m1); m2' = upper_closure_matchexpr a (MatchNot m2) in
      (if m1' = MatchAny \<or> m2' = MatchAny
       then MatchAny
       else
          if m1' = MatchNot MatchAny then m2' else
          if m2' = MatchNot MatchAny then m1'
       else
          MatchNot (MatchAnd (MatchNot m1') (MatchNot m2')))
         )" |
    "upper_closure_matchexpr _ (MatchNot m) = MatchNot m" |
    "upper_closure_matchexpr a (MatchAnd m1 m2) = MatchAnd (upper_closure_matchexpr a m1) (upper_closure_matchexpr a m2)"

  lemma upper_closure_matchexpr_generic:
    "a = Accept \<or> a = Drop \<Longrightarrow> remove_unknowns_generic (common_matcher, in_doubt_allow) a m = upper_closure_matchexpr a m"
    by(induction a m rule: upper_closure_matchexpr.induct)
      (simp_all add: remove_unknowns_generic_simps2 bool_to_ternary_Unknown common_matcher_SrcDst_defined)

  fun lower_closure_matchexpr :: "action \<Rightarrow> 'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
    "lower_closure_matchexpr _ MatchAny = MatchAny" |
    "lower_closure_matchexpr Accept (Match (Extra _)) = MatchNot MatchAny" |
    "lower_closure_matchexpr Reject (Match (Extra _)) = MatchAny" |
    "lower_closure_matchexpr Drop (Match (Extra _)) = MatchAny" |
    "lower_closure_matchexpr _ (Match m) = Match m" |
    "lower_closure_matchexpr Accept (MatchNot (Match (Extra _))) = MatchNot MatchAny" |
    "lower_closure_matchexpr Drop (MatchNot (Match (Extra _))) = MatchAny" |
    "lower_closure_matchexpr Reject (MatchNot (Match (Extra _))) = MatchAny" |
    "lower_closure_matchexpr a (MatchNot (MatchNot m)) = lower_closure_matchexpr a m" |
    "lower_closure_matchexpr a (MatchNot (MatchAnd m1 m2)) =
      (let m1' = lower_closure_matchexpr a (MatchNot m1); m2' = lower_closure_matchexpr a (MatchNot m2) in
      (if m1' = MatchAny \<or> m2' = MatchAny
       then MatchAny
       else
          if m1' = MatchNot MatchAny then m2' else
          if m2' = MatchNot MatchAny then m1'
       else
          MatchNot (MatchAnd (MatchNot m1') (MatchNot m2')))
         )" |
    "lower_closure_matchexpr _ (MatchNot m) = MatchNot m" |
    "lower_closure_matchexpr a (MatchAnd m1 m2) = MatchAnd (lower_closure_matchexpr a m1) (lower_closure_matchexpr a m2)"

  lemma lower_closure_matchexpr_generic:
    "a = Accept \<or> a = Drop \<Longrightarrow> remove_unknowns_generic (common_matcher, in_doubt_deny) a m = lower_closure_matchexpr a m"
    by(induction a m rule: lower_closure_matchexpr.induct)
    (simp_all add: remove_unknowns_generic_simps2 bool_to_ternary_Unknown common_matcher_SrcDst_defined)

end


subsection \<open>CISK (Controlled Interruptible Separation Kernel)\<close>

theory CISK
  imports ISK
begin

text \<open>
  This section presents a generic model of a Controlled Interruptible Separation Kernel (CISK).
  It formulates security, i.e., intransitive noninterference.
  For a presentation of this model, see Section 2 of~\<^cite>\<open>"Verbeek2013"\<close>.
\<close>

text \<open>
  First, a locale is defined that defines all generic functions and all proof obligations (see Section 2.3 of ~\<^cite>\<open>"Verbeek2013"\<close>).
\<close>
locale Controllable_Interruptible_Separation_Kernel = \<comment> \<open>CISK\<close>
fixes kstep :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> 'state_t" \<comment> \<open>Executes one atomic kernel action\<close>
  and output_f :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> 'output_t" \<comment> \<open>Returns the observable behavior\<close>
  and s0 :: "'state_t" \<comment> \<open>The initial state\<close>
  and current :: "'state_t => 'dom_t" \<comment> \<open>Returns the currently active domain\<close>
  and cswitch :: "time_t \<Rightarrow> 'state_t \<Rightarrow> 'state_t" \<comment> \<open>Performs a context switch\<close>
  and interrupt :: "time_t \<Rightarrow> bool" \<comment> \<open>Returns t iff an interrupt occurs in the given state at the given time\<close>
  and kinvolved :: "'action_t \<Rightarrow> 'dom_t set" \<comment> \<open>Returns the set of domains that are involved in the given action\<close>
  and ifp :: "'dom_t \<Rightarrow> 'dom_t \<Rightarrow> bool" \<comment> \<open>The security policy.\<close>
  and vpeq :: "'dom_t \<Rightarrow> 'state_t \<Rightarrow> 'state_t \<Rightarrow> bool" \<comment> \<open>View partitioning equivalence\<close>
  and AS_set :: "('action_t list) set" \<comment> \<open>Returns a set of valid action sequences, i.e., the attack surface\<close>
  and invariant :: "'state_t \<Rightarrow> bool" \<comment> \<open>Returns an inductive state-invariant\<close>
  and AS_precondition :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool" \<comment> \<open>Returns the preconditions under which the given action can be executed.\<close>
  and aborting :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool" \<comment> \<open>Returns true iff the action is aborted.\<close>
  and waiting :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool" \<comment> \<open>Returns true iff execution of the given action is delayed.\<close>
  and set_error_code :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> 'state_t" \<comment> \<open>Sets an error code when actions are aborted.\<close>
assumes vpeq_transitive: " \<forall> a b c u. (vpeq u a b \<and> vpeq u b c) \<longrightarrow> vpeq u a c"
    and vpeq_symmetric: "\<forall> a b u. vpeq u a b \<longrightarrow> vpeq u b a"
    and vpeq_reflexive: "\<forall> a u. vpeq u a a"
    and ifp_reflexive: "\<forall> u . ifp u u"
    and weakly_step_consistent: "\<forall> s t u a. vpeq u s t \<and> vpeq (current s) s t \<and> invariant s \<and> AS_precondition s (current s) a \<and> invariant t \<and> AS_precondition t (current t) a \<and> current s = current t  \<longrightarrow> vpeq u (kstep s a) (kstep t a)"
    and locally_respects: "\<forall> a s u. \<not>ifp (current s) u  \<and> invariant s \<and> AS_precondition s (current s) a \<longrightarrow> vpeq u s (kstep s a)"
    and output_consistent: "\<forall> a s t. vpeq (current s) s t \<and> current s = current t \<longrightarrow> (output_f s a) = (output_f t a)"
    and step_atomicity: "\<forall> s a . current (kstep s a) = current s"
    and cswitch_independent_of_state: "\<forall> n s t . current s = current t \<longrightarrow> current (cswitch n s) = current (cswitch n t)"
    and cswitch_consistency: "\<forall> u s t n . vpeq u s t \<longrightarrow> vpeq u (cswitch n s) (cswitch n t)"
    and empty_in_AS_set: "[] \<in> AS_set"
    and invariant_s0: "invariant s0"
    and invariant_after_cswitch: "\<forall> s n . invariant s \<longrightarrow> invariant (cswitch n s)"
    and precondition_after_cswitch: "\<forall> s d n a. AS_precondition s d a \<longrightarrow> AS_precondition (cswitch n s) d a"
    and AS_prec_first_action: "\<forall> s d aseq . invariant s \<and> aseq \<in> AS_set \<and> aseq \<noteq> [] \<longrightarrow> AS_precondition s d (hd aseq)"
    and AS_prec_after_step: "\<forall> s a a' . (\<exists> aseq \<in> AS_set . is_sub_seq a a' aseq) \<and> invariant s \<and> AS_precondition s (current s) a \<and> \<not>aborting s (current s) a \<and> \<not> waiting s (current s) a\<longrightarrow> AS_precondition (kstep s a) (current s) a'"
    and AS_prec_dom_independent: "\<forall> s d a a' . current s \<noteq> d \<and> AS_precondition s d a \<longrightarrow> AS_precondition (kstep s a') d a"
    and spec_of_invariant: "\<forall> s a . invariant s \<longrightarrow> invariant (kstep s a)"
    and aborting_switch_independent: "\<forall> n s . aborting (cswitch n s) = aborting s"
    and aborting_error_update: "\<forall> s d a' a . current s \<noteq> d \<and> aborting s d a \<longrightarrow> aborting (set_error_code s a') d a"
    and aborting_after_step: "\<forall> s a d . current s \<noteq> d \<longrightarrow> aborting (kstep s a) d = aborting s d" (* TODO: I think this PO can be removed *)
    and aborting_consistent: "\<forall> s t u . vpeq u s t \<longrightarrow> aborting s u = aborting t u"
    and waiting_switch_independent: "\<forall> n s . waiting (cswitch n s) = waiting s"
    and waiting_error_update: "\<forall> s d a' a . current s \<noteq> d \<and> waiting s d a \<longrightarrow> waiting (set_error_code s a') d a"
    and waiting_consistent: "\<forall>s t u a . vpeq (current s) s t \<and> (\<forall> d \<in> kinvolved a . vpeq d s t) \<and> vpeq u s t \<longrightarrow> waiting s u a = waiting t u a"
    and spec_of_waiting: "\<forall> s a . waiting s (current s) a \<longrightarrow> kstep s a = s"
    and set_error_consistent: "\<forall> s t u a . vpeq u s t \<longrightarrow> vpeq u (set_error_code s a) (set_error_code t a)"
    and set_error_locally_respects: "\<forall> s u a . \<not>ifp (current s) u \<longrightarrow> vpeq u s (set_error_code s a)"
    and current_set_error_code: "\<forall> s a . current (set_error_code s a) = current s"
    and precondition_after_set_error_code: "\<forall> s d a a'. AS_precondition s d a \<and> aborting s (current s) a' \<longrightarrow> AS_precondition (set_error_code s a') d a"
    and invariant_after_set_error_code: "\<forall> s a . invariant s \<longrightarrow> invariant (set_error_code s a)"
    and involved_ifp: "\<forall> s a . \<forall> d \<in> (kinvolved a) . AS_precondition s (current s) a \<longrightarrow> ifp d (current s)"
begin

subsubsection\<open>Execution semantics\<close>

text\<open>
  Control is based on generic functions \emph{aborting}, \emph{waiting} and \emph{set\_error\_code}.
  Function \emph{aborting} decides whether a certain action is aborting, given its domain and the state.
  If so, then function set\_error\_code will be used to update the state, possibly communicating to other domains that an action has been aborted.
  Function \emph{waiting} can delay the execution of an action.
  This behavior is implemented in function CISK\_control.
\<close>
function CISK_control :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t execution \<Rightarrow> ('action_t option \<times> 'action_t execution \<times> 'state_t)"
where "CISK_control s d []                = (None,[],s)" \<comment> \<open>The thread is empty\<close>
    | "CISK_control s d ([]#[])           = (None,[],s)" \<comment> \<open>The current action sequence has been finished and the thread has no next action sequences to execute\<close>
    | "CISK_control s d ([]#(as'#execs')) = (None,as'#execs',s)" \<comment> \<open>The current action sequence has been finished. Skip to the next sequence\<close>
    | "CISK_control s d ((a#as)#execs')   = (if aborting s d a then
                                                  (None, execs',set_error_code s a)
                                               else if waiting s d a then
                                                  (Some a, (a#as)#execs',s)
                                               else
                                                  (Some a, as#execs',s))" \<comment> \<open>Executing an action sequence\<close>
by pat_completeness auto
termination by lexicographic_order

text\<open>
  Function \emph{run} defines the execution semantics.
  This function is presented in ~\<^cite>\<open>"Verbeek2013"\<close> by pseudo code (see Algorithm 1).
  Before defining the run function, we define accessor functions for the control mechanism.
  Functions next\_action, next\_execs and next\_state correspond to ``control.a'', ``control.x'' and ``control.s'' in ~\<^cite>\<open>"Verbeek2013"\<close>.
\<close>
abbreviation next_action::"'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> 'action_t option"
where "next_action \<equiv> Kernel.next_action current CISK_control"
abbreviation next_execs::"'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution)"
where "next_execs  \<equiv> Kernel.next_execs current CISK_control"
abbreviation next_state::"'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> 'state_t"
where "next_state  \<equiv> Kernel.next_state current CISK_control"
text \<open>
\<close>
text \<open>
  A thread is empty iff either it has no further action sequences to execute, or when the current action sequence is finished and there are no further action sequences to execute.
\<close>
abbreviation thread_empty::"'action_t execution \<Rightarrow> bool"
where "thread_empty exec \<equiv> exec = [] \<or> exec = [[]]"

text\<open>
  The following function defines the execution semantics of CISK, using function CISK\_control.
\<close>
function run :: "time_t \<Rightarrow> 'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> 'state_t"
where "run 0 s execs = s"
| "interrupt (Suc n) \<Longrightarrow> run (Suc n) s execs = run n (cswitch (Suc n) s) execs"
| "\<not>interrupt (Suc n) \<Longrightarrow> thread_empty(execs (current s)) \<Longrightarrow> run (Suc n) s execs = run n s execs"
| "\<not>interrupt (Suc n) \<Longrightarrow> \<not>thread_empty(execs (current s)) \<Longrightarrow>
      run (Suc n) s execs = (let control_a = next_action s execs;
                                 control_s = next_state s execs;
                                 control_x = next_execs s execs in
                             case control_a of None \<Rightarrow> run n control_s control_x
                                         | (Some a) \<Rightarrow> run n (kstep control_s a) control_x)"
using not0_implies_Suc by (metis prod_cases3,auto)
termination by lexicographic_order

subsubsection \<open>Formulations of security\<close>

text\<open>
  The definitions of security as presented in Section 2.2 of~\<^cite>\<open>"Verbeek2013"\<close>.
\<close>

abbreviation kprecondition
  where "kprecondition s a \<equiv> invariant s \<and> AS_precondition s (current s) a"
definition realistic_execution
where "realistic_execution aseq \<equiv> set aseq \<subseteq> AS_set"
definition realistic_executions :: "('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> bool"
where "realistic_executions execs \<equiv> \<forall>d. realistic_execution (execs d)"
abbreviation involved where "involved \<equiv> Kernel.involved kinvolved"
abbreviation step where "step \<equiv> Kernel.step kstep"
abbreviation purge where "purge \<equiv> Separation_Kernel.purge realistic_execution ifp"
abbreviation ipurge_l where "ipurge_l \<equiv> Separation_Kernel.ipurge_l kinvolved ifp"
abbreviation ipurge_r where "ipurge_r \<equiv> Separation_Kernel.ipurge_r realistic_execution kinvolved ifp"

definition NI_unrelated::bool
where "NI_unrelated
  \<equiv> \<forall> execs a n . realistic_executions execs \<longrightarrow>
                      (let s_f = run n s0 execs in
                         output_f s_f a = output_f (run n s0 (purge execs (current s_f))) a)"
definition NI_indirect_sources::bool
where "NI_indirect_sources
  \<equiv> \<forall> execs a n. realistic_executions execs \<longrightarrow>
                    (let s_f = run n s0 execs in
                      output_f (run n s0 (ipurge_l execs (current s_f))) a =
                      output_f (run n s0 (ipurge_r execs (current s_f))) a)"
definition isecure::bool
where "isecure \<equiv> NI_unrelated \<and> NI_indirect_sources"

subsubsection \<open>Proofs\<close>
text\<open>
  The final theorem is unwinding\_implies\_isecure\_CISK.
  This theorem shows that any interpretation of locale CISK is secure.

  To prove this theorem, the refinement framework is used.
  CISK is a refinement of ISK, as the only idfference is the control function.
  In ISK, this function is a generic function called \emph{control}, in CISK it is interpreted in function \emph{CISK\_control}.
  It is proven that function \emph{CISK\_control} satisfies all the proof obligations concerning generic function \emph{control}.
  In other words, \emph{CISK\_control} is proven to be an interpretation of control.
  Therefore, all theorems on run\_total apply to the run function of CISK as well.
\<close>

lemma next_action_consistent:
shows "\<forall> s t execs . vpeq (current s) s t \<and> (\<forall> d \<in>  involved (next_action s execs) . vpeq d s t) \<and> current s = current t  \<longrightarrow> next_action s execs = next_action t execs"
proof-
{
  fix s t execs
  assume vpeq: "vpeq (current s) s t"
  assume vpeq_involved: "\<forall> d \<in>  involved (next_action s execs) . vpeq d s t"
  assume current_s_t: "current s = current t"
  from aborting_consistent current_s_t vpeq
   have "aborting t (current s) = aborting s (current s)" by auto
  from current_s_t this waiting_consistent vpeq_involved
    have "next_action s execs = next_action t execs"
    unfolding Kernel.next_action_def
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_execs_consistent:
shows "\<forall> s t execs . vpeq (current s) s t \<and> (\<forall> d \<in> involved (next_action s execs) . vpeq d s t) \<and> current s = current t \<longrightarrow> fst (snd (CISK_control s (current s) (execs (current s)))) = fst (snd (CISK_control t (current s) (execs (current s))))"
proof-
{
  fix s t execs
  assume vpeq: "vpeq (current s) s t"
  assume vpeq_involved: "\<forall> d \<in> involved (next_action s execs) . vpeq d s t"
  assume current_s_t: "current s = current t"
  from aborting_consistent current_s_t vpeq
     have 1: "aborting t (current s) = aborting s (current s)" by auto
  from 1 vpeq current_s_t vpeq_involved waiting_consistent[THEN spec,THEN spec,THEN spec,THEN spec,where x3=s and x2=t and x1="current s" and x="the (next_action s execs)"]
    have "fst (snd (CISK_control s (current s) (execs (current s)))) = fst (snd (CISK_control t (current s) (execs (current s))))"
    unfolding Kernel.next_action_def Kernel.involved_def
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto split: if_split_asm)
}
thus ?thesis by auto
qed

lemma next_state_consistent:
shows "\<forall> s t u execs . vpeq (current s) s t \<and> vpeq u s t \<and> current s = current t \<longrightarrow> vpeq u (next_state s execs) (next_state t execs)"
proof-
{
  fix s t u execs
  assume vpeq_s_t: "vpeq (current s) s t \<and> vpeq u s t"
  assume current_s_t: "current s = current t"
  from vpeq_s_t current_s_t
    have "vpeq u (next_state s execs) (next_state t execs)"
    unfolding Kernel.next_state_def
    using aborting_consistent set_error_consistent
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma current_next_state:
shows "\<forall> s execs . current (next_state s execs) = current s"
proof-
{
  fix s execs
  have "current (next_state s execs) = current s"
    unfolding Kernel.next_state_def
    using current_set_error_code
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma locally_respects_next_state:
shows "\<forall> s u execs. \<not>ifp (current s) u \<longrightarrow> vpeq u s (next_state s execs)"
proof-
{
  fix s u execs
  assume "\<not>ifp (current s) u"
  hence "vpeq u s (next_state s execs)"
    unfolding Kernel.next_state_def
    using vpeq_reflexive set_error_locally_respects
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma CISK_control_spec:
shows "\<forall>s d aseqs.
       case CISK_control s d aseqs of
       (a, aseqs', s') \<Rightarrow>
         thread_empty aseqs \<and> (a, aseqs') = (None, []) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> \<not> aborting s' d (the a) \<and> \<not> waiting s' d (the a) \<and> (a, aseqs') = (Some (hd (hd aseqs)), tl (hd aseqs) # tl aseqs) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> waiting s' d (the a) \<and> (a, aseqs', s') = (Some (hd (hd aseqs)), aseqs, s) \<or> (a, aseqs') = (None, tl aseqs)"
proof-
{
  fix s d aseqs
  have "case CISK_control s d aseqs of
       (a, aseqs', s') \<Rightarrow>
         thread_empty aseqs \<and> (a, aseqs') = (None, []) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> \<not> aborting s' d (the a) \<and> \<not> waiting s' d (the a) \<and> (a, aseqs') = (Some (hd (hd aseqs)), tl (hd aseqs) # tl aseqs) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> waiting s' d (the a) \<and> (a, aseqs', s') = (Some (hd (hd aseqs)), aseqs, s) \<or> (a, aseqs') = (None, tl aseqs)"
  by(cases "(s,d,aseqs)" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_action_after_cswitch:
shows "\<forall> s n d aseqs . fst (CISK_control (cswitch n s) d aseqs) = fst (CISK_control s d aseqs)"
proof-
{
  fix s n d aseqs
  have "fst (CISK_control (cswitch n s) d aseqs) = fst (CISK_control s d aseqs)"
  using aborting_switch_independent waiting_switch_independent
  by(cases "(s,d,aseqs)" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_action_after_next_state:
shows "\<forall> s execs d . current s \<noteq> d \<longrightarrow> fst (CISK_control (next_state s execs) d (execs d)) = None \<or> fst (CISK_control (next_state s execs) d (execs d)) = fst (CISK_control s d (execs d))"
proof-
{
  fix s execs d aseqs
  assume 1: "current s \<noteq> d"
  have "fst (CISK_control (next_state s execs) d aseqs) = None \<or> fst (CISK_control (next_state s execs) d aseqs) = fst (CISK_control s d aseqs)"
    proof(cases "(s,d,aseqs)" rule: CISK_control.cases,simp,simp,simp)
    case (4 sa da a as execs')
      thus ?thesis
          unfolding Kernel.next_state_def
          using aborting_error_update waiting_error_update 1
          by(cases "(sa,current sa,execs (current sa))" rule: CISK_control.cases,auto split: if_split_asm)
    qed
}
thus ?thesis by auto
qed

lemma next_action_after_step:
shows "\<forall> s a d aseqs . current s \<noteq> d \<longrightarrow> fst (CISK_control (step s a) d aseqs) = fst (CISK_control s d aseqs)"
proof-
{
  fix s a d aseqs
  assume 1: "current s \<noteq> d"
  from this aborting_after_step
    have  "fst (CISK_control (step s a) d aseqs) = fst (CISK_control s d aseqs)"
    unfolding Kernel.step_def
    by(cases "(s,d,aseqs)" rule: CISK_control.cases,simp,simp,simp,cases a,auto)
}
thus ?thesis by auto
qed

lemma next_state_precondition:
shows "\<forall>s d a execs. AS_precondition s d a \<longrightarrow> AS_precondition (next_state s execs) d a"
proof-
{
  fix s a d execs
  assume "AS_precondition s d a"
  hence "AS_precondition (next_state s execs) d a"
    unfolding Kernel.next_state_def
    using precondition_after_set_error_code
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_state_invariant:
shows "\<forall>s execs. invariant s \<longrightarrow> invariant (next_state s execs)"
proof-
{
  fix s execs
  assume "invariant s"
  hence "invariant (next_state s execs)"
    unfolding Kernel.next_state_def
    using invariant_after_set_error_code
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_action_from_execs:
shows "\<forall> s execs . next_action s execs \<rightharpoonup> (\<lambda> a . a \<in> actions_in_execution (execs (current s)))"
proof-
{
  fix s execs
  {
    fix a
    assume 1: "next_action s execs = Some a"
    from 1 have "a \<in> actions_in_execution (execs (current s))"
      unfolding Kernel.next_action_def actions_in_execution_def
      by (cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto split: if_split_asm)
  }
  hence "next_action s execs \<rightharpoonup> (\<lambda> a . a \<in> actions_in_execution (execs (current s)))"
    unfolding B_def
    by (cases "next_action s execs",auto)
}
thus ?thesis unfolding B_def by (auto)
qed

lemma next_execs_subset:
shows "\<forall>s execs u . actions_in_execution (next_execs s execs u) \<subseteq> actions_in_execution (execs u)"
proof-
{
  fix s execs u
  have "actions_in_execution (next_execs s execs u) \<subseteq> actions_in_execution (execs u)"
    unfolding Kernel.next_execs_def actions_in_execution_def
    by (cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto split: if_split_asm)
}
thus ?thesis by auto
qed

theorem unwinding_implies_isecure_CISK:
shows isecure
proof-
  interpret int: Interruptible_Separation_Kernel kstep output_f s0 current cswitch interrupt kprecondition realistic_execution CISK_control kinvolved ifp vpeq AS_set invariant AS_precondition aborting waiting
    proof (unfold_locales)
      show "\<forall>a b c u. vpeq u a b \<and> vpeq u b c \<longrightarrow> vpeq u a c"
        using vpeq_transitive by blast
      show "\<forall>a b u. vpeq u a b \<longrightarrow> vpeq u b a"
        using vpeq_symmetric by blast
      show "\<forall>a u. vpeq u a a"
        using vpeq_reflexive by blast
      show "\<forall>u. ifp u u"
        using ifp_reflexive by blast
      show "\<forall> s t u a. vpeq u s t \<and> vpeq (current s) s t \<and> kprecondition s a \<and> kprecondition t a \<and> current s = current t  \<longrightarrow> vpeq u (kstep s a) (kstep t a)"
        using weakly_step_consistent by blast
      show "\<forall> a s u. \<not>ifp (current s) u  \<and> kprecondition s a \<longrightarrow> vpeq u s (kstep s a)"
        using locally_respects by blast
      show "\<forall> a s t. vpeq (current s) s t \<and> current s = current t \<longrightarrow> (output_f s a) = (output_f t a)"
        using output_consistent by blast
      show "\<forall> s a . current (kstep s a) = current s"
        using step_atomicity by blast
      show "\<forall> n s t . current s = current t \<longrightarrow> current (cswitch n s) = current (cswitch n t)"
        using cswitch_independent_of_state by blast
      show "\<forall> u s t n . vpeq u s t \<longrightarrow> vpeq u (cswitch n s) (cswitch n t)"
        using cswitch_consistency by blast
      show "\<forall>s t execs. vpeq (current s) s t \<and> (\<forall> d \<in> involved (next_action s execs) . vpeq d s t) \<and> current s = current t \<longrightarrow> next_action s execs = next_action t execs"
        using next_action_consistent by blast
      show "\<forall>s t execs.
        vpeq (current s) s t \<and> (\<forall> d \<in> involved (next_action s execs) . vpeq d s t) \<and> current s = current t \<longrightarrow>
        fst (snd (CISK_control s (current s) (execs (current s)))) = fst (snd (CISK_control t (current s) (execs (current s))))"
        using next_execs_consistent by blast
      show " \<forall>s t u execs. vpeq (current s) s t \<and> vpeq u s t \<and> current s = current t \<longrightarrow> vpeq u (next_state s execs) (next_state t execs)"
        using next_state_consistent by auto
      show " \<forall>s execs. current (next_state s execs) = current s"
        using current_next_state by auto
      show "\<forall>s u execs. \<not> ifp (current s) u \<longrightarrow> vpeq u s (next_state s execs)"
        using locally_respects_next_state by auto
      show "[] \<in> AS_set"
        using empty_in_AS_set by blast
      show "\<forall> s n . invariant s \<longrightarrow> invariant (cswitch n s)"
        using invariant_after_cswitch by blast
      show "\<forall> s d n a. AS_precondition s d a \<longrightarrow> AS_precondition (cswitch n s) d a"
        using precondition_after_cswitch by blast
      show "invariant s0"
        using invariant_s0 by blast
      show "\<forall> s d aseq . invariant s \<and> aseq \<in> AS_set \<and> aseq \<noteq> [] \<longrightarrow> AS_precondition s d (hd aseq)"
        using AS_prec_first_action by blast
      show "\<forall>s a a'. (\<exists>aseq\<in>AS_set. is_sub_seq a a' aseq) \<and> invariant s \<and> AS_precondition s (current s) a \<and> \<not> aborting s (current s) a \<and> \<not> waiting s (current s) a \<longrightarrow>
             AS_precondition (kstep s a) (current s) a'"
        using AS_prec_after_step by blast
      show "\<forall> s d a a' . current s \<noteq> d \<and> AS_precondition s d a \<longrightarrow> AS_precondition (kstep s a') d a"
        using AS_prec_dom_independent by blast
      show "\<forall> s a . invariant s \<longrightarrow> invariant (kstep s a)"
        using spec_of_invariant by blast
      show "\<And>s a. kprecondition s a \<equiv> kprecondition s a"
        by auto
      show "\<And>aseq. realistic_execution aseq \<equiv> set aseq \<subseteq> AS_set"
        unfolding realistic_execution_def
        by auto
      show "\<forall>s a. \<forall> d \<in> involved a. kprecondition s (the a) \<longrightarrow> ifp d (current s)"
        using involved_ifp unfolding Kernel.involved_def by (auto split: option.splits)
      show "\<forall>s execs. next_action s execs \<rightharpoonup> (\<lambda>a. a \<in> actions_in_execution (execs (current s)))"
        using next_action_from_execs by blast
      show "\<forall>s execs u. actions_in_execution (next_execs s execs u) \<subseteq> actions_in_execution (execs u)"
        using next_execs_subset by blast
      show "\<forall>s d aseqs.
       case CISK_control s d aseqs of
       (a, aseqs', s') \<Rightarrow>
         thread_empty aseqs \<and> (a, aseqs') = (None, []) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> \<not> aborting s' d (the a) \<and> \<not> waiting s' d (the a) \<and> (a, aseqs') = (Some (hd (hd aseqs)), tl (hd aseqs) # tl aseqs) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> waiting s' d (the a) \<and> (a, aseqs', s') = (Some (hd (hd aseqs)), aseqs, s) \<or> (a, aseqs') = (None, tl aseqs)"
        using CISK_control_spec by blast
      show "\<forall>s n d aseqs. fst (CISK_control (cswitch n s) d aseqs) = fst (CISK_control s d aseqs)"
        using next_action_after_cswitch by auto
      show "\<forall>s execs d.
       current s \<noteq> d \<longrightarrow>
       fst (CISK_control (next_state s execs) d (execs d)) = None \<or> fst (CISK_control (next_state s execs) d (execs d)) = fst (CISK_control s d (execs d))"
        using next_action_after_next_state by auto
      show "\<forall>s a d aseqs. current s \<noteq> d \<longrightarrow> fst (CISK_control (step s a) d aseqs) = fst (CISK_control s d aseqs)"
        using next_action_after_step by auto
      show "\<forall>s d a execs. AS_precondition s d a \<longrightarrow> AS_precondition (next_state s execs) d a"
        using next_state_precondition by auto
      show "\<forall>s execs. invariant s \<longrightarrow> invariant (next_state s execs)"
        using next_state_invariant by auto
      show "\<forall>s a. waiting s (current s) a \<longrightarrow> kstep s a = s"
        using spec_of_waiting by blast
  qed

  note interpreted = int.Interruptible_Separation_Kernel_axioms
  note run_total_induct = Interruptible_Separation_Kernel.run_total.induct[of kstep output_f s0 current cswitch kprecondition realistic_execution
                                                                             CISK_control kinvolved ifp vpeq AS_set invariant AS_precondition aborting waiting _ interrupt]
  have run_equals_run_total:
     "\<And> n s execs . run n s execs \<equiv> Interruptible_Separation_Kernel.run_total kstep current cswitch interrupt CISK_control n s execs"
     proof-
        fix n s execs
        show "run n s execs \<equiv> Interruptible_Separation_Kernel.run_total kstep current cswitch interrupt CISK_control n s execs"
          using interpreted int.step_def
          by(induct n s execs rule: run_total_induct,auto split: option.splits)
     qed
  from interpreted
    have 0: "Interruptible_Separation_Kernel.isecure_total kstep output_f s0 current cswitch interrupt realistic_execution CISK_control kinvolved ifp"
    by (metis int.unwinding_implies_isecure_total)
  from 0 run_equals_run_total
    have 1: "NI_unrelated"
    by (metis realistic_executions_def int.isecure_total_def int.realistic_executions_def int.NI_unrelated_total_def NI_unrelated_def)
  from 0 run_equals_run_total
    have 2: "NI_indirect_sources"
    by (metis realistic_executions_def int.NI_indirect_sources_total_def int.isecure_total_def int.realistic_executions_def NI_indirect_sources_def)
  from 1 2 show ?thesis unfolding isecure_def by auto
qed

end
end


(*  Title:      HOL/Auth/n_germanish_lemma_inv__1_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_germanish Protocol Case Study*}

theory n_germanish_lemma_inv__1_on_rules imports n_germanish_lemma_on_inv__1
begin
section{*All lemmas on causal relation between inv__1*}
lemma lemma_inv__1_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__1  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_t1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_t2  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_t3  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_t4  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_t5  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_t6 N i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_t1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_t1Vsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_t2  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_t2Vsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_t3  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_t3Vsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_t4  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_t4Vsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_t5  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_t5Vsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_t6 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_t6Vsinv__1) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end