header {*
  \subsection{ISK (Interruptible Separation Kernel)}
*}

theory ISK
  imports SK
begin

text {*

At this point, the precondition linking action to state is generic and highly unconstrained.
We refine the previous locale by given generic functions ``precondition'' and ``realistic\_trace'' a definiton.
This yields a total run function, instead of the partial one of locale Separation\_Kernel.

This definition is based on a set of valid action sequences AS\_set.
Consider for example the following action sequence:
\[\gamma = [COPY\_INIT,COPY\_CHECK,COPY\_COPY]\]
If action sequence $\gamma$ is a member of AS\_set, this means that the attack surface contains an action COPY, which consists of three consecutive atomic kernel actions.
Interrupts can occur anywhere between these atomic actions.

Given a set of valid action sequences such as $\gamma$, generic function precondition can be defined.
It now consists of 1.) a generic invariant and 2.) more refined preconditions for the current action.

These preconditions need to be proven inductive only according to action sequences.
Assume, e.g., that $\gamma \in \mbox{AS\_set}$ and that $d$ is the currently active domain in state $s$.
The following constraints are assumed and must therefore be proven for the instantiation:
     \begin{itemize}
       \item ``AS\_precondition s d COPY\_INIT''\\ since COPY\_INIT is the start of an action sequence.
      \item ``AS\_precondition (step s COPY\_INIT) d COPY\_CHECK''\\ since (COPY\_INIT, COPY\_CHECK) is a sub sequence.
      \item ``AS\_precondition (step s COPY\_CHECK) d COPY\_COPY''\\ since (COPY\_CHECK, COPY\_COPY) is a sub sequence.
     \end{itemize}
    Additionally, the precondition for domain $d$ must be consistent when a context switch occurs, or when ever some other domain $d'$ performs an action.

    Locale Interruptible\_Separation\_Kernel refines locale Separation\_Kernel in two ways.
    First, there is a definition of realistic executions.
    A realistic trace consists of action sequences from AS\_set.

    Secondly, the generic @{term control} function has been refined by additional assumptions.
    It is now assumed that control conforms to one of four possibilities:
    \begin{enumerate}
    \item The execution of the currently active domain is empty and the control function returns no action.
    \item The currently active domain is executing the action sequence at the head of the execution. It returns the next kernel action of this sequence and updates the execution accordingly.
    \item The action sequence is delayed.
    \item The action sequence that is at the head of the execution is skipped and the execution is updated accordingly.
    \end{enumerate}
    As for the state update, this is still completely unconstrained and generic as long as it respects the generic invariant and the precondition.
*}

locale Interruptible_Separation_Kernel = Separation_Kernel kstep output_f s0 current cswitch interrupt kprecondition realistic_execution control kinvolved ifp vpeq
  for kstep :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> 'state_t"
  and output_f :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> 'output_t"
  and s0 :: 'state_t
  and current :: "'state_t => 'dom_t" -- "Returns the currently active domain"
  and cswitch :: "time_t \<Rightarrow> 'state_t \<Rightarrow> 'state_t" -- "Switches the current domain"
  and interrupt :: "time_t \<Rightarrow> bool" -- "Returns t iff an interrupt occurs in the given state at the given time"
  and kprecondition :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> bool" -- "Returns t if an precondition holds that relates the current action to the state"
  and realistic_execution :: "'action_t execution \<Rightarrow> bool" -- "In this locale, this function is completely unconstrained."
  and control :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t execution \<Rightarrow> (('action_t option) \<times> 'action_t execution \<times> 'state_t)"
  and kinvolved :: "'action_t \<Rightarrow> 'dom_t set"
  and ifp :: "'dom_t \<Rightarrow> 'dom_t \<Rightarrow> bool"
  and vpeq :: "'dom_t \<Rightarrow> 'state_t \<Rightarrow> 'state_t \<Rightarrow> bool"
+
  fixes AS_set :: "('action_t list) set" -- "Returns a set of valid action sequences, i.e., the attack surface"
    and invariant :: "'state_t \<Rightarrow> bool"
    and AS_precondition :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool"
    and aborting :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool"
    and waiting :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool"
assumes 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)"
    (* The refinement: functions precondition and realistic trace now have a definition. Control has been refined to four cases. *)
    and kprecondition_def: "kprecondition s a \<equiv> invariant s \<and> AS_precondition s (current s) a"
    and realistic_execution_def: "realistic_execution aseq \<equiv> set aseq \<subseteq> AS_set"
    and control_spec: "\<forall> s d aseqs . case control s d aseqs of (a,aseqs',s') \<Rightarrow>
                                 (thread_empty aseqs \<and> (a,aseqs') = (None,[])) \<or> (* Nothing happens *)
                                 (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> (* Execute the first action of the current action sequence *)
                                 (aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> waiting s' d (the a) \<and> (a,aseqs',s') = (Some (hd (hd aseqs)),aseqs,s)) \<or> (* Nothing happens, waiting to execute the next action *)
                                 (a,aseqs') = (None,tl aseqs)" (* The current action sequence is skipped *)
    and next_action_after_cswitch: "\<forall> s n d aseqs . fst (control (cswitch n s) d aseqs) = fst (control s d aseqs)"
    and next_action_after_next_state: "\<forall> s execs d  . current s \<noteq> d \<longrightarrow>  fst (control (next_state s execs) d (execs d)) = None \<or> fst (control (next_state s execs) d (execs d)) = fst (control s d (execs d))"
    and next_action_after_step: "\<forall> s a d aseqs . current s \<noteq> d \<longrightarrow> fst (control (step s a) d aseqs) = fst (control s d aseqs)"
    and next_state_precondition: "\<forall> s d a execs. AS_precondition s d a \<longrightarrow> AS_precondition (next_state s execs) d a"
    and next_state_invariant: "\<forall> s execs . invariant s \<longrightarrow> invariant (next_state s execs)"
    and spec_of_waiting: "\<forall> s a . waiting s (current s) a \<longrightarrow> kstep s a = s"
begin

text {*
  We can now formulate a total run function, since based on the new assumptions the case where the precondition does not hold, will never occur.
*}
function run_total :: "time_t \<Rightarrow> 'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> 'state_t"
where "run_total 0 s execs = s"
| "interrupt (Suc n) \<Longrightarrow> run_total (Suc n) s execs = run_total n (cswitch (Suc n) s) execs"
| "\<not>interrupt (Suc n) \<Longrightarrow> thread_empty(execs (current s)) \<Longrightarrow> run_total (Suc n) s execs = run_total n s execs"
| "\<not>interrupt (Suc n) \<Longrightarrow> \<not>thread_empty(execs (current s)) \<Longrightarrow>
      run_total (Suc n) s execs = run_total n (step (next_state s execs) (next_action s execs)) (next_execs s execs)"
using not0_implies_Suc by (metis prod_cases3,auto)
termination by lexicographic_order

text {*
  The major part of the proofs in this locale consist of proving that function run\_total is equivalent to function run, i.e., that the precondition does always hold.
  This assumes that the executions are \emph{realistic}.
  This means that the execution of each domain contains action sequences that are from AS\_set.
  This ensures, e.g, that a COPY\_CHECK is always preceded by a COPY\_INIT.
*}
definition realistic_executions :: "('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> bool"
where "realistic_executions execs \<equiv> \<forall> d . realistic_execution (execs d)"

text {*
  Lemma run\_total\_equals\_run is proven by doing induction.
  It is however not inductive and can therefore not be proven directly: a realistic execution is not necessarily realistic after performing one action.
  We generalize to do induction.
  Predicate realistic\_executions\_ind is the inductive version of realistic\_executions. All action sequences in the tail of the executions must be complete action sequences (i.e., they must be from AS\_set).
  The first action sequence, however, is being executed and is therefore not necessarily an action sequence from AS\_set, but it is \emph{the last part}
  of some action sequence from AS\_set.
*}
definition realistic_AS_partial :: "'action_t list \<Rightarrow> bool"
where "realistic_AS_partial aseq \<equiv> \<exists> n aseq' .  n \<le> length aseq' \<and> aseq' \<in> AS_set \<and> aseq = lastn n aseq'"
definition realistic_executions_ind :: "('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> bool"
where "realistic_executions_ind execs \<equiv> \<forall> d . (case execs d of [] \<Rightarrow> True | (aseq#aseqs) \<Rightarrow> realistic_AS_partial aseq \<and> set aseqs \<subseteq> AS_set)"
text {*
  We need to know that invariably, the precondition holds.
  As this precondition consists of 1.) a generic invariant and 2.) more refined preconditions for the current action, we have to know that these two are invariably true.
*}
definition precondition_ind :: "'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> bool"
where "precondition_ind s execs \<equiv> invariant s \<and> (\<forall> d . fst(control s d (execs d)) \<rightharpoonup> AS_precondition s d)"

text {*
  Proof that ``execution is realistic" is inductive, i.e.,
  assuming the current execution is realistic, the execution returned by the control mechanism is realistic.
*}
lemma next_execution_is_realistic_partial:
assumes na_def: "next_execs s execs d = aseq # aseqs"
    and d_is_curr: "d = current s"
    and realistic: "realistic_executions_ind execs"
    and thread_not_empty: "\<not>thread_empty(execs (current s))"
shows "realistic_AS_partial aseq \<and> set aseqs \<subseteq> AS_set"
proof-
let ?c = "control s (current s) (execs (current s))"
{
  assume c_empty: "let (a,aseqs',s') = ?c in
              (a,aseqs') = (None,[])"
 from na_def d_is_curr c_empty
   have ?thesis
   unfolding realistic_executions_ind_def next_execs_def by (auto)
}
moreover
{
  let ?ct= "execs (current s)"
  let ?execs' = "(tl (hd ?ct))#(tl ?ct)"
  let ?a' = "Some (hd (hd ?ct))"
  assume hd_thread_not_empty: "hd (execs (current s)) \<noteq> []"
  assume c_executing: "let (a,aseqs',s') = ?c in
                            (a,aseqs') = (?a', ?execs')"
  from na_def c_executing d_is_curr
    have as_defs: "aseq = tl (hd ?ct) \<and> aseqs = tl ?ct"
    unfolding next_execs_def by (auto)
  from realistic[unfolded realistic_executions_ind_def,THEN spec,where x=d] d_is_curr
    have subset: "set (tl ?execs') \<subseteq> AS_set"
    unfolding Let_def realistic_AS_partial_def
    by (cases "execs d",auto)
  from d_is_curr thread_not_empty hd_thread_not_empty realistic[unfolded realistic_executions_ind_def,THEN spec,where x=d]
    obtain n aseq' where n_aseq': "n \<le> length aseq' \<and> aseq' \<in> AS_set \<and> hd ?ct = lastn n aseq'"
    unfolding realistic_AS_partial_def
    by (cases "execs d",auto)
  from this hd_thread_not_empty have "n > 0" unfolding lastn_def by(cases n,auto)
  from this n_aseq' lastn_one_less[where n=n and x=aseq' and a="hd (hd ?ct)" and y="tl (hd ?ct)"] hd_thread_not_empty
    have "n - 1 \<le> length aseq' \<and> aseq' \<in> AS_set \<and> tl (hd ?ct) = lastn (n - 1) aseq'"
    by auto
  from this as_defs subset have ?thesis
    unfolding realistic_AS_partial_def
    by auto
}
moreover
{
  let ?ct= "execs (current s)"
  let ?execs' = "?ct"
  let ?a' = "Some (hd (hd ?ct))"
  assume c_waiting: "let (a,aseqs',s') = ?c in
                            (a,aseqs') = (?a', ?execs')"
  from na_def c_waiting d_is_curr
    have as_defs: "aseq = hd ?execs' \<and> aseqs = tl ?execs'"
    unfolding next_execs_def by (auto)
  from realistic[unfolded realistic_executions_ind_def,THEN spec,where x=d] d_is_curr set_tl_is_subset[where x="?execs'"]
    have subset: "set (tl ?execs') \<subseteq> AS_set"
    unfolding Let_def realistic_AS_partial_def
    by (cases "execs d",auto)
  from na_def c_waiting d_is_curr
    have "?execs' \<noteq> []" unfolding next_execs_def by auto
  from realistic[unfolded realistic_executions_ind_def,THEN spec,where x=d] d_is_curr thread_not_empty
    obtain n aseq' where witness: "n \<le> length aseq' \<and> aseq' \<in> AS_set \<and> hd(execs d) = lastn n aseq'"
    unfolding realistic_AS_partial_def by (cases "execs d",auto)
  from d_is_curr this subset as_defs have ?thesis
    unfolding realistic_AS_partial_def
    by auto
}
moreover
{
  let ?ct= "execs (current s)"
  let ?execs' = "tl ?ct"
  let ?a' = "None"
  assume c_aborting: "let (a,aseqs',s') = ?c in
                            (a,aseqs') = (?a', ?execs')"
  from na_def c_aborting d_is_curr
    have as_defs: "aseq = hd ?execs' \<and> aseqs = tl ?execs'"
    unfolding next_execs_def by (auto)
  from realistic[unfolded realistic_executions_ind_def,THEN spec,where x=d] d_is_curr set_tl_is_subset[where x="?execs'"]
    have subset: "set (tl ?execs') \<subseteq> AS_set"
    unfolding Let_def realistic_AS_partial_def
    by (cases "execs d",auto)
  from na_def c_aborting d_is_curr
    have "?execs' \<noteq> []" unfolding next_execs_def by auto
  from empty_in_AS_set this
    realistic[unfolded realistic_executions_ind_def,THEN spec,where x=d] d_is_curr
    have "length (hd ?execs') \<le> length (hd ?execs') \<and> (hd ?execs') \<in> AS_set \<and> hd ?execs' = lastn (length (hd ?execs')) (hd ?execs')"
    unfolding lastn_def
    by (cases "execs (current s)",auto)
  from this subset as_defs have ?thesis
    unfolding realistic_AS_partial_def
    by auto
}
ultimately
show ?thesis
  using control_spec[THEN spec,THEN spec,THEN spec,where x2=s and x1="current s" and x="execs (current s)"]
        d_is_curr thread_not_empty
  by (auto simp add: Let_def)
qed

text {*
  The lemma that proves that the total run function is equivalent to the partial run function, i.e., that in this refinement the case of the run function where the precondition is False will never occur.
*}
lemma run_total_equals_run:
  assumes realistic_exec: "realistic_executions execs"
      and invariant: "invariant s"
    shows "strict_equal (run n (Some s) execs) (run_total n s execs)"
proof-
{
  fix n ms s execs
  have "strict_equal ms s \<and> realistic_executions_ind execs \<and> precondition_ind s execs \<longrightarrow> strict_equal (run n ms execs) (run_total n s execs)"
  proof (induct n ms execs arbitrary: s rule: run.induct)
  case (1 s execs sa)
    show ?case by auto
  next
  case (2 n execs s)
    show ?case unfolding strict_equal_def by auto
  next
  case (3 n s execs sa)
    assume interrupt: "interrupt (Suc n)"
    assume IH: "(\<And>sa. strict_equal (Some (cswitch (Suc n) s)) sa \<and> realistic_executions_ind execs \<and> precondition_ind sa execs \<longrightarrow>
             strict_equal (run n (Some (cswitch (Suc n) s)) execs) (run_total n sa execs))"
    {
      assume equal_s_sa: "strict_equal (Some s) sa"
      assume realistic: "realistic_executions_ind execs"
      assume inv_sa: "precondition_ind sa execs"
      have inv_nsa: "precondition_ind (cswitch (Suc n) sa) execs"
      proof-
        {
          fix d
          have "fst (control (cswitch (Suc n) sa) d (execs d)) \<rightharpoonup> AS_precondition (cswitch (Suc n) sa) d"
            using next_action_after_cswitch inv_sa[unfolded precondition_ind_def,THEN conjunct2,THEN spec,where x=d]
                  precondition_after_cswitch
            unfolding Let_def B_def precondition_ind_def
            by(cases "fst (control (cswitch (Suc n) sa) d (execs d))",auto)
        }
        thus ?thesis using inv_sa invariant_after_cswitch unfolding precondition_ind_def by auto
      qed
      from equal_s_sa realistic inv_nsa inv_sa IH[where sa="cswitch (Suc n) sa"]
        have equal_ns_nt: "strict_equal (run n (Some (cswitch (Suc n) s)) execs) (run_total n (cswitch (Suc n) sa) execs)"
        unfolding strict_equal_def by(auto)
    }
    from this interrupt show ?case by auto
  next
  case (4 n execs s sa)
    assume not_interrupt: "\<not>interrupt (Suc n)"
    assume thread_empty: "thread_empty(execs (current s))"
    assume IH: "(\<And>sa. strict_equal (Some s) sa \<and> realistic_executions_ind execs \<and> precondition_ind sa execs \<longrightarrow> strict_equal (run n (Some s) execs) (run_total n sa execs))"
    have current_s_sa: "strict_equal (Some s) sa \<longrightarrow> current s = current sa" unfolding strict_equal_def by auto
    {
      assume equal_s_sa: "strict_equal (Some s) sa"
      assume realistic: "realistic_executions_ind execs"
      assume inv_sa: "precondition_ind sa execs"
      from equal_s_sa realistic inv_sa IH[where sa="sa"]
        have equal_ns_nt: "strict_equal (run n (Some s) execs) (run_total n sa execs)"
        unfolding strict_equal_def by(auto)
    }
    from this current_s_sa thread_empty not_interrupt show ?case by auto
  next
  case (5 n execs s sa)
    assume not_interrupt: "\<not>interrupt (Suc n)"
    assume thread_not_empty: "\<not>thread_empty(execs (current s))"
    assume not_prec: "\<not> precondition (next_state s execs) (next_action s execs)"
    -- "In locale ISK, the precondition can be proven to hold at all times. This case cannot happen, and we can prove False."
    {
      assume equal_s_sa: "strict_equal (Some s) sa"
      assume realistic: "realistic_executions_ind execs"
      assume inv_sa: "precondition_ind sa execs"
      from equal_s_sa have s_sa: "s = sa" unfolding strict_equal_def by auto
      from inv_sa have
        "next_action sa execs \<rightharpoonup> AS_precondition sa (current sa)"
        unfolding precondition_ind_def B_def next_action_def
        by (cases "next_action sa execs",auto)
      from this next_state_precondition
        have "next_action sa execs \<rightharpoonup> AS_precondition (next_state sa execs) (current sa)"
        unfolding precondition_ind_def B_def
        by (cases "next_action sa execs",auto)
      from inv_sa this s_sa next_state_invariant current_next_state
        have prec_s: "precondition (next_state s execs) (next_action s execs)"
        unfolding precondition_ind_def kprecondition_def precondition_def B_def
        by (cases "next_action sa execs",auto)
      from this not_prec have False by auto
    }
    thus ?case by auto
  next
  case (6 n execs s sa)
    assume not_interrupt: "\<not>interrupt (Suc n)"
    assume thread_not_empty: "\<not>thread_empty(execs (current s))"
    assume prec: "precondition (next_state s execs) (next_action s execs)"
    assume IH: "(\<And>sa. strict_equal (Some (step (next_state s execs) (next_action s execs))) sa \<and>
             realistic_executions_ind (next_execs s execs) \<and> precondition_ind sa (next_execs s execs) \<longrightarrow>
             strict_equal (run n (Some (step (next_state s execs) (next_action s execs))) (next_execs s execs)) (run_total n sa (next_execs s execs)))"
    have current_s_sa: "strict_equal (Some s) sa \<longrightarrow> current s = current sa" unfolding strict_equal_def by auto
    {
      assume equal_s_sa: "strict_equal (Some s) sa"
      assume realistic: "realistic_executions_ind execs"
      assume inv_sa: "precondition_ind sa execs"

      from equal_s_sa have s_sa: "s = sa" unfolding strict_equal_def by auto

      let ?a = "next_action s execs"
      let ?ns = "step (next_state s execs) ?a"
      let ?na = "next_execs s execs"
      let ?c = "control s (current s) (execs (current s))"

      have equal_ns_nsa: "strict_equal (Some ?ns) ?ns" unfolding strict_equal_def by auto
      from inv_sa equal_s_sa have inv_s: "invariant s" unfolding strict_equal_def precondition_ind_def by auto

      -- "Two things are proven inductive. First, the assumptions that the execution is realistic (statement realistic-na). This proof uses lemma next-execution-is-realistic-partial.
          Secondly, the precondition: if the precondition holds for the current action, then it holds for the next action (statement invariant-na)."
      have realistic_na: "realistic_executions_ind ?na"
      proof-
        {
          fix d
          have "case ?na d of [] \<Rightarrow> True | aseq # aseqs \<Rightarrow> realistic_AS_partial aseq \<and> set aseqs \<subseteq> AS_set"
          proof(cases "?na d",simp,rename_tac aseq aseqs,simp,cases "d = current s")
          case False
            fix aseq aseqs
            assume "next_execs s execs d = aseq # aseqs"
            from False this realistic[unfolded realistic_executions_ind_def,THEN spec,where x=d]
              show "realistic_AS_partial aseq \<and> set aseqs \<subseteq> AS_set"
              unfolding next_execs_def by simp
          next
          case True
            fix aseq aseqs
            assume na_def: "next_execs s execs d = aseq # aseqs"
            from next_execution_is_realistic_partial na_def True realistic thread_not_empty
              show "realistic_AS_partial aseq \<and> set aseqs \<subseteq> AS_set" by blast
          qed
        }
        thus ?thesis unfolding realistic_executions_ind_def by auto
      qed
      have invariant_na: "precondition_ind ?ns ?na"
      proof-
        from spec_of_invariant inv_sa next_state_invariant s_sa have inv_ns: "invariant ?ns"
          unfolding precondition_ind_def step_def
          by (cases "next_action sa execs",auto)
        have "\<forall>d. fst (control ?ns d (?na d)) \<rightharpoonup> AS_precondition ?ns d"
        proof-
        {
          fix d
          {
          let ?a' = "fst (control ?ns d (?na d))"
          assume snd_action_not_none: "?a' \<noteq> None"
          have "AS_precondition ?ns d (the ?a')"
          proof (cases "d = current s")
          case True
            {
              have ?thesis
              proof (cases "?a")
              case (Some a)
                -- "Assuming that the current domain executes some action a, and assuming that the action a' after that is not None (statement snd-action-not-none),
                    we prove that the precondition is inductive, i.e., it will hold for a'.
                    Two cases arise: either action a is delayed (case waiting) or not (case executing)."
                show ?thesis
                proof(cases "?na d = execs (current s)" rule :case_split[case_names waiting executing])
                case executing -- "The kernel is executing two consecutive actions a and a'. We show that [a,a'] is a subsequence in some action in AS-set.
                                   The PO's ensure that the precondition is inductive."
                  from executing True Some control_spec[THEN spec,THEN spec,THEN spec,where x2=s and x1=d and x="execs d"]
                    have a_def: "a = hd (hd (execs (current s))) \<and> ?na d = (tl (hd (execs (current s))))#(tl (execs (current s)))"
                    unfolding next_action_def next_execs_def Let_def
                    by(auto)
                  from a_def True snd_action_not_none control_spec[THEN spec,THEN spec,THEN spec,where x2="?ns" and x1=d and x="?na d"]
                    second_elt_is_hd_tl[where x=" hd (execs (current s))" and a="hd(tl(hd (execs (current s))))" and x'="tl (tl(hd (execs (current s))))"]
                    have na_def: "the ?a' = (hd (execs (current s)))!1"
                    unfolding next_execs_def
                    by(auto)
                  from Some realistic[unfolded realistic_executions_ind_def,THEN spec,where x=d] True thread_not_empty
                    obtain n aseq' where witness: "n \<le> length aseq' \<and> aseq' \<in> AS_set \<and> hd(execs d) = lastn n aseq'"
                    unfolding realistic_AS_partial_def by (cases "execs d",auto)
                  from True executing length_lt_2_implies_tl_empty[where x="hd (execs (current s))"]
                    Some control_spec[THEN spec,THEN spec,THEN spec,where x2=s and x1=d and x="execs d"]
                    snd_action_not_none control_spec[THEN spec,THEN spec,THEN spec,where x2="?ns" and x1=d and x="?na d"]
                    have in_action_sequence: "length (hd (execs (current s))) \<ge> 2"
                    unfolding next_action_def next_execs_def
                    by auto
                  from this witness consecutive_is_sub_seq[where a=a and b="the ?a'" and n=n and y=aseq' and x="tl (tl (hd (execs (current s))))"]
                    a_def na_def True in_action_sequence
                    x_is_hd_snd_tl[where x="hd (execs (current s))"]
                    have 1: "\<exists> aseq' \<in> AS_set . is_sub_seq a (the ?a') aseq'"
                    by(auto)
                  from True Some inv_sa[unfolded precondition_ind_def,THEN conjunct2,THEN spec,where x="current s"] s_sa
                    have 2: "AS_precondition s (current s) a"
                    unfolding strict_equal_def next_action_def B_def by auto
                  from executing True Some control_spec[THEN spec,THEN spec,THEN spec,where x2=s and x1=d and x="execs d"]
                    have not_aborting: "\<not>aborting (next_state s execs) (current s) (the ?a)"
                    unfolding next_action_def next_state_def next_execs_def
                    by auto
                  from executing True Some control_spec[THEN spec,THEN spec,THEN spec,where x2=s and x1=d and x="execs d"]
                    have not_waiting: "\<not>waiting (next_state s execs) (current s) (the ?a)"
                    unfolding next_action_def next_state_def next_execs_def
                    by auto
                  from True this
                    1 2 inv_s
                    sub_seq_in_prefixes[where X=AS_set] Some next_state_invariant
                    current_next_state[THEN spec,THEN spec,where x1=s and x=execs]
                    AS_prec_after_step[THEN spec,THEN spec,THEN spec,where x2="next_state s execs" and x1="a" and x="the ?a'"]
                    next_state_precondition not_aborting not_waiting
                    show ?thesis
                    unfolding step_def
                    by auto
                  next
                  case waiting -- "The kernel is delaying action a. Thus the action after a, which is a', is equal to a."
                    from tl_hd_x_not_tl_x[where x="execs d"] True waiting control_spec[THEN spec,THEN spec,THEN spec,where x2=s and x1=d and x="execs d"] Some
                      have a_def: "?na d = execs (current s) \<and> next_state s execs = s \<and> waiting s d (the ?a)"
                      unfolding next_action_def next_execs_def next_state_def
                      by(auto)
                    from Some waiting a_def True snd_action_not_none control_spec[THEN spec,THEN spec,THEN spec,where x2="?ns" and x1=d and x="?na d"]
                      have na_def: "the ?a' = hd (hd (execs (current s)))"
                      unfolding next_action_def next_execs_def
                      by(auto)
                    from spec_of_waiting a_def True
                      have no_step: "step s ?a = s" unfolding step_def by (cases "next_action s execs",auto)
                    from no_step Some True a_def
                          inv_sa[unfolded precondition_ind_def,THEN conjunct2,THEN spec,where x="current s"] s_sa
                      have 2: "AS_precondition s (current s) (the ?a')"
                      unfolding next_action_def B_def
                      by(auto)
                    from a_def na_def this True Some no_step
                      show ?thesis
                      unfolding step_def
                      by(auto)
                  qed
              next
              case None
                -- "Assuming that the current domain does not execute an action, and assuming that the action a' after that is not None (statement snd-action-not-none),
                    we prove that the precondition is inductive, i.e., it will hold for a'.
                    This holds, since the control mechanism will ensure that action a' is the start of a new action sequence in AS-set."
                from None True snd_action_not_none control_spec[THEN spec,THEN spec,THEN spec,where x2="?ns" and x1=d and x="?na d"]
                     control_spec[THEN spec,THEN spec,THEN spec,where x2=s and x1=d and x="execs d"]
                  have na_def: "the ?a' = hd (hd (tl (execs (current s)))) \<and> ?na d = tl (execs (current s))"
                  unfolding next_action_def next_execs_def
                  by(auto)
                from True None snd_action_not_none control_spec[THEN spec,THEN spec,THEN spec,where x2="?ns" and x1=d and x="?na d"]
                     this
                  have 1: "tl (execs (current s)) \<noteq> [] \<and> hd (tl (execs (current s))) \<noteq> []"
                  by auto
                from this realistic[unfolded realistic_executions_ind_def,THEN spec,where x=d] True thread_not_empty
                  have "hd (tl (execs (current s))) \<in> AS_set"
                  by (cases "execs d",auto)
                from True snd_action_not_none this
                  inv_ns this na_def 1
                  AS_prec_first_action[THEN spec,THEN spec,THEN spec,where x2="?ns" and x="hd (tl (execs (current s)))" and x1=d]
                  show ?thesis by auto
              qed
            }
            thus ?thesis
              using control_spec[THEN spec,THEN spec,THEN spec,where x2="?ns" and x1="current s" and x="?na (current s)"]
                    thread_not_empty True snd_action_not_none
              by (auto simp add: Let_def)
          next
          case False
            from False have equal_na_a: "?na d = execs d"
              unfolding next_execs_def by auto
            from this False current_next_state next_action_after_step
              have "?a' = fst (control (next_state s execs) d (next_execs s execs d))"
              unfolding next_action_def by auto
            from inv_sa[unfolded precondition_ind_def,THEN conjunct2,THEN spec,where x=d] s_sa equal_na_a  this
                 next_action_after_next_state[THEN spec,THEN spec,THEN spec,where x=d and x2=s and x1=execs]
                 snd_action_not_none False
              have "AS_precondition s d (the ?a')"
              unfolding precondition_ind_def next_action_def B_def by (cases "fst (control sa d (execs d))",auto)
            from equal_na_a False this next_state_precondition current_next_state
              AS_prec_dom_independent[THEN spec,THEN spec,THEN spec,THEN spec,where x3="next_state s execs" and x2=d and x="the ?a" and x1="the ?a'"]
              show ?thesis
              unfolding step_def
              by (cases "next_action s execs",auto)
          qed
          }
          hence "fst (control ?ns d (?na d)) \<rightharpoonup> AS_precondition ?ns d" unfolding B_def
            by (cases "fst (control ?ns d (?na d))",auto)
        }
        thus ?thesis by auto
      qed
      from this inv_ns show ?thesis
        unfolding precondition_ind_def B_def Let_def
        by (auto)
      qed
      from equal_ns_nsa realistic_na invariant_na s_sa IH[where sa="?ns"]
        have equal_ns_nt: "strict_equal (run n (Some ?ns) ?na) (run_total n (step (next_state sa execs) (next_action sa execs)) (next_execs sa execs))"
        by(auto)
    }
    from this current_s_sa thread_not_empty not_interrupt prec show ?case by auto
  qed
}
hence thm_inductive: "\<forall> m s execs n . strict_equal m s \<and> realistic_executions_ind execs \<and> precondition_ind s execs \<longrightarrow> strict_equal (run n m execs) (run_total n s execs)" by blast
have 1: "strict_equal (Some s) s" unfolding strict_equal_def by simp
have 2: "realistic_executions_ind execs"
  proof-
  {
    fix d
    have "case execs d of [] \<Rightarrow> True | aseq # aseqs \<Rightarrow> realistic_AS_partial aseq \<and> set aseqs \<subseteq> AS_set"
    proof(cases "execs d",simp)
    case (Cons aseq aseqs)
      from Cons realistic_exec[unfolded realistic_executions_def,THEN spec,where x=d]
        have 0: "length aseq \<le> length aseq \<and> aseq \<in> AS_set \<and> aseq = lastn (length aseq) aseq"
        unfolding lastn_def realistic_execution_def by auto
      hence 1: "realistic_AS_partial aseq" unfolding realistic_AS_partial_def by auto
      from Cons realistic_exec[unfolded realistic_executions_def,THEN spec,where x=d]
        have 2: "set aseqs \<subseteq> AS_set"
        unfolding realistic_execution_def by auto
      from Cons 1 2 show ?thesis by auto
    qed
  }
  thus ?thesis unfolding realistic_executions_ind_def by auto
  qed
have 3: "precondition_ind s execs"
  proof-
    {
      fix d
      {
      assume not_empty: "fst (control s d (execs d)) \<noteq> None"
      from not_empty realistic_exec[unfolded realistic_executions_def,THEN spec,where x=d]
        have current_aseq_is_realistic: "hd (execs d) \<in> AS_set"
        using control_spec[THEN spec,THEN spec,THEN spec,where x="execs d" and x1=d and x2=s]
        unfolding realistic_execution_def by(cases "execs d",auto)
      from not_empty current_aseq_is_realistic invariant AS_prec_first_action[THEN spec,THEN spec,THEN spec, where x2=s and x1=d and x="hd (execs d)"]
        have "AS_precondition s d (the (fst (control s d (execs d))))"
        using control_spec[THEN spec,THEN spec,THEN spec,where x="execs d" and x1=d and x2=s]
        by auto
      }
      hence "fst (control s d (execs d)) \<rightharpoonup> AS_precondition s d"
        unfolding B_def
        by (cases " fst (control s d (execs d))",auto)
    }
    from this invariant show ?thesis unfolding precondition_ind_def by auto
  qed
from thm_inductive 1 2 3 show ?thesis by auto
qed

text {*
  Theorem unwinding\_implies\_isecure gives security for all realistic executions.
  For unrealistic executions, it holds vacuously and therefore does not tell us anything.
  In order to prove security for this refinement (i.e., for function run\_total), we have to prove that purging yields realistic runs.
*}

lemma realistic_purge:
  shows "\<forall> execs d . realistic_executions execs \<longrightarrow> realistic_executions (purge execs d)"
proof-
{
  fix execs d
  assume "realistic_executions execs"
  hence "realistic_executions (purge execs d)"
    using someI[where P=realistic_execution and x="execs d"]
    unfolding realistic_executions_def purge_def by(simp)
}
thus ?thesis by auto
qed

lemma remove_gateway_comm_subset:
shows "set (remove_gateway_communications d exec) \<subseteq> set exec \<union> {[]}"
by(induct exec,auto)

lemma realistic_ipurge_l:
  shows "\<forall> execs d . realistic_executions execs \<longrightarrow> realistic_executions (ipurge_l execs d)"
proof-
{
  fix execs d
  assume 1: "realistic_executions execs"
  from empty_in_AS_set remove_gateway_comm_subset[where d=d and exec="execs d"] 1 have "realistic_executions (ipurge_l execs d)"
    unfolding realistic_execution_def realistic_executions_def ipurge_l_def by(auto)
}
thus ?thesis by auto
qed

lemma realistic_ipurge_r:
  shows "\<forall> execs d . realistic_executions execs \<longrightarrow> realistic_executions (ipurge_r execs d)"
proof-
{
  fix execs d
  assume 1: "realistic_executions execs"
  from empty_in_AS_set remove_gateway_comm_subset[where d=d and exec="execs d"] 1 have "realistic_executions (ipurge_r execs d)"
    using someI[where P="\<lambda> x . realistic_execution x" and x="execs d"]
    unfolding realistic_execution_def realistic_executions_def ipurge_r_def by(auto)
}
thus ?thesis by auto
qed

text {*
  We now have sufficient lemma's to prove security for run\_total.
  The definition of security is similar to that in Section~\ref{sec:sep_kernel}.
  It now assumes that the executions are realistic and concerns function run\_total instead of function run.
*}

definition NI_unrelated_total::bool
where "NI_unrelated_total
  \<equiv> \<forall> execs a n . realistic_executions execs \<longrightarrow>
                     (let s_f = run_total n s0 execs in
                       output_f s_f a = output_f (run_total n s0 (purge execs (current s_f))) a
                        \<and> current s_f = current (run_total n s0 (purge execs (current s_f))))"

definition NI_indirect_sources_total::bool
where "NI_indirect_sources_total
  \<equiv> \<forall> execs a n. realistic_executions execs \<longrightarrow>
                    (let s_f = run_total n s0 execs in
                      output_f (run_total n s0 (ipurge_l execs (current s_f))) a =
                      output_f (run_total n s0 (ipurge_r execs (current s_f))) a)"

definition isecure_total::bool
where "isecure_total \<equiv> NI_unrelated_total \<and> NI_indirect_sources_total"

theorem unwinding_implies_isecure_total:
shows isecure_total
proof-
  from assms unwinding_implies_isecure have secure_partial: "NI_unrelated" unfolding isecure_def by blast
  from assms unwinding_implies_isecure have isecure1_partial: "NI_indirect_sources" unfolding isecure_def by blast

  have NI_unrelated_total: NI_unrelated_total
  proof-
    {
    fix execs a n
    assume realistic: "realistic_executions execs"
    from assms invariant_s0 realistic run_total_equals_run[where n=n and s=s0 and execs=execs]
      have 1: "strict_equal (run n (Some s0) execs) (run_total n s0 execs)" by auto

    have "let s_f = run_total n s0 execs in output_f s_f a = output_f (run_total n s0 (purge execs (current s_f))) a \<and> current s_f = current (run_total n s0 (purge execs (current s_f)))"
    proof (cases "run n (Some s0) execs")
    case None
      thus ?thesis using 1 unfolding NI_unrelated_total_def strict_equal_def by auto
    next
    case (Some s_f)
      from realistic_purge assms invariant_s0 realistic run_total_equals_run[where n=n and s=s0 and execs="purge execs (current s_f)"]
        have 2: "strict_equal (run n (Some s0) (purge execs (current s_f))) (run_total n s0 (purge execs (current s_f)))"
        by auto
      show ?thesis proof(cases "run n (Some s0) (purge execs (current s_f))")
      case None
        from 2 None show ?thesis using 2 unfolding NI_unrelated_total_def strict_equal_def by auto
      next
      case (Some s_f2)
        from `run n (Some s0) execs = Some s_f` Some 1 2  secure_partial[unfolded NI_unrelated_def,THEN spec,THEN spec,THEN spec,where x=n and x2=execs]
          show ?thesis
          unfolding strict_equal_def NI_unrelated_def
          by(simp add: Let_def B_def B2_def)
      qed
    qed
    }
    thus ?thesis unfolding NI_unrelated_total_def by auto
  qed
  have NI_indirect_sources_total: NI_indirect_sources_total
  proof-
    {
    fix execs a n
    assume realistic: "realistic_executions execs"
    from assms invariant_s0 realistic run_total_equals_run[where n=n and s=s0 and execs=execs]
      have 1: "strict_equal (run n (Some s0) execs) (run_total n s0 execs)" by auto

    have "let s_f = run_total n s0 execs in output_f (run_total n s0 (ipurge_l execs (current s_f))) a = output_f (run_total n s0 (ipurge_r execs (current s_f))) a"
    proof (cases "run n (Some s0) execs")
    case None
      thus ?thesis using 1 unfolding NI_unrelated_total_def strict_equal_def by auto
    next
    case (Some s_f)
      from realistic_ipurge_l assms invariant_s0 realistic run_total_equals_run[where n=n and s=s0 and execs="ipurge_l execs (current s_f)"]
        have 2: "strict_equal (run n (Some s0) (ipurge_l execs (current s_f))) (run_total n s0 (ipurge_l execs (current s_f)))"
        by auto
      from realistic_ipurge_r assms invariant_s0 realistic run_total_equals_run[where n=n and s=s0 and execs="ipurge_r execs (current s_f)"]
        have 3: "strict_equal (run n (Some s0) (ipurge_r execs (current s_f))) (run_total n s0 (ipurge_r execs (current s_f)))"
        by auto

      show ?thesis proof(cases "run n (Some s0) (ipurge_l execs (current s_f))")
      case None
        from 2 None show ?thesis using 2 unfolding NI_unrelated_total_def strict_equal_def by auto
      next
      case (Some s_ipurge_l)
        show ?thesis
        proof(cases "run n (Some s0) (ipurge_r execs (current s_f))")
        case None
          from 3 None show ?thesis using 2 unfolding NI_unrelated_total_def strict_equal_def by auto
          next
          case (Some s_ipurge_r)
            from `run n (Some s0) execs = Some s_f` `run n (Some s0) (ipurge_l execs (current s_f)) = Some s_ipurge_l`
                  Some 1 2 3 isecure1_partial[unfolded NI_indirect_sources_def,THEN spec,THEN spec,THEN spec,where x=n and x2=execs]
            show ?thesis
              unfolding strict_equal_def NI_unrelated_def
              by(simp add: Let_def B_def B2_def)
        qed
      qed
    qed
    }
    thus ?thesis unfolding NI_indirect_sources_total_def by auto
  qed
  from NI_unrelated_total NI_indirect_sources_total show ?thesis unfolding isecure_total_def by auto
qed

end
end


(*  Title:      HOL/NanoJava/State.thy
    Author:     David von Oheimb
    Copyright   2001 Technische Universitaet Muenchen
*)

section "Program State"

theory State imports TypeRel begin

definition body :: "cname \<times> mname => stmt" where
 "body \<equiv> \<lambda>(C,m). bdy (the (method C m))"

text \<open>Locations, i.e.\ abstract references to objects\<close>
typedecl loc

datatype val
  = Null        \<comment>\<open>null reference\<close>
  | Addr loc    \<comment>\<open>address, i.e. location of object\<close>

type_synonym fields
        = "(fname \<rightharpoonup> val)"

type_synonym
        obj = "cname \<times> fields"

translations
  (type) "fields" \<leftharpoondown> (type) "fname => val option"
  (type) "obj"    \<leftharpoondown> (type) "cname \<times> fields"

definition init_vars :: "('a \<rightharpoonup> 'b) => ('a \<rightharpoonup> val)" where
 "init_vars m == map_option (\<lambda>T. Null) o m"

text \<open>private:\<close>
type_synonym heap = "loc   \<rightharpoonup> obj"
type_synonym locals = "vname \<rightharpoonup> val"

text \<open>private:\<close>
record  state
        = heap   :: heap
          locals :: locals

translations
  (type) "heap" \<leftharpoondown> (type) "loc => obj option"
  (type) "locals" \<leftharpoondown> (type) "vname => val option"
  (type) "state" \<leftharpoondown> (type) "(|heap :: heap, locals :: locals|)"

definition del_locs :: "state => state" where
 "del_locs s \<equiv> s (| locals := empty |)"

definition init_locs     :: "cname => mname => state => state" where
 "init_locs C m s \<equiv> s (| locals := locals s ++
                         init_vars (map_of (lcl (the (method C m)))) |)"

text \<open>The first parameter of @{term set_locs} is of type @{typ state}
        rather than @{typ locals} in order to keep @{typ locals} private.\<close>
definition set_locs :: "state => state => state" where
 "set_locs s s' \<equiv> s' (| locals := locals s |)"

definition get_local     :: "state => vname => val" ("_<_>" [99,0] 99) where
 "get_local s x  \<equiv> the (locals s x)"

\<comment>\<open>local function:\<close>
definition get_obj       :: "state => loc => obj" where
 "get_obj s a \<equiv> the (heap s a)"

definition obj_class     :: "state => loc => cname" where
 "obj_class s a \<equiv> fst (get_obj s a)"

definition get_field     :: "state => loc => fname => val" where
 "get_field s a f \<equiv> the (snd (get_obj s a) f)"

\<comment>\<open>local function:\<close>
definition hupd       :: "loc => obj => state => state"   ("hupd'(_\<mapsto>_')" [10,10] 1000) where
 "hupd a obj s \<equiv> s (| heap   := ((heap   s)(a\<mapsto>obj))|)"

definition lupd       :: "vname => val => state => state" ("lupd'(_\<mapsto>_')" [10,10] 1000) where
 "lupd x v s   \<equiv> s (| locals := ((locals s)(x\<mapsto>v  ))|)"

definition new_obj :: "loc => cname => state => state" where
 "new_obj a C   \<equiv> hupd(a\<mapsto>(C,init_vars (field C)))"

definition upd_obj    :: "loc => fname => val => state => state" where
 "upd_obj a f v s \<equiv> let (C,fs) = the (heap s a) in hupd(a\<mapsto>(C,fs(f\<mapsto>v))) s"

definition new_Addr      :: "state => val" where
 "new_Addr s == SOME v. (\<exists>a. v = Addr a \<and> (heap s) a = None) | v = Null"

subsection "Properties not used in the meta theory"

lemma locals_upd_id [simp]: "s\<lparr>locals := locals s\<rparr> = s"
by simp

lemma lupd_get_local_same [simp]: "lupd(x\<mapsto>v) s<x> = v"
by (simp add: lupd_def get_local_def)

lemma lupd_get_local_other [simp]: "x \<noteq> y \<Longrightarrow> lupd(x\<mapsto>v) s<y> = s<y>"
apply (drule not_sym)
by (simp add: lupd_def get_local_def)

lemma get_field_lupd [simp]:
  "get_field (lupd(x\<mapsto>y) s) a f = get_field s a f"
by (simp add: lupd_def get_field_def get_obj_def)

lemma get_field_set_locs [simp]:
  "get_field (set_locs l s) a f = get_field s a f"
by (simp add: lupd_def get_field_def set_locs_def get_obj_def)

lemma get_field_del_locs [simp]:
  "get_field (del_locs s) a f = get_field s a f"
by (simp add: lupd_def get_field_def del_locs_def get_obj_def)

lemma new_obj_get_local [simp]: "new_obj a C s <x> = s<x>"
by (simp add: new_obj_def hupd_def get_local_def)

lemma heap_lupd [simp]: "heap (lupd(x\<mapsto>y) s) = heap s"
by (simp add: lupd_def)

lemma heap_hupd_same [simp]: "heap (hupd(a\<mapsto>obj) s) a = Some obj"
by (simp add: hupd_def)

lemma heap_hupd_other [simp]: "aa \<noteq> a  \<Longrightarrow> heap (hupd(aa\<mapsto>obj) s) a = heap s a"
apply (drule not_sym)
by (simp add: hupd_def)

lemma hupd_hupd [simp]: "hupd(a\<mapsto>obj) (hupd(a\<mapsto>obj') s) = hupd(a\<mapsto>obj) s"
by (simp add: hupd_def)

lemma heap_del_locs [simp]: "heap (del_locs s) = heap s"
by (simp add: del_locs_def)

lemma heap_set_locs [simp]: "heap (set_locs l s) = heap s"
by (simp add: set_locs_def)

lemma hupd_lupd [simp]:
  "hupd(a\<mapsto>obj) (lupd(x\<mapsto>y) s) = lupd(x\<mapsto>y) (hupd(a\<mapsto>obj) s)"
by (simp add: hupd_def lupd_def)

lemma hupd_del_locs [simp]:
  "hupd(a\<mapsto>obj) (del_locs s) = del_locs (hupd(a\<mapsto>obj) s)"
by (simp add: hupd_def del_locs_def)

lemma new_obj_lupd [simp]:
  "new_obj a C (lupd(x\<mapsto>y) s) = lupd(x\<mapsto>y) (new_obj a C s)"
by (simp add: new_obj_def)

lemma new_obj_del_locs [simp]:
  "new_obj a C (del_locs s) = del_locs (new_obj a C s)"
by (simp add: new_obj_def)

lemma upd_obj_lupd [simp]:
  "upd_obj a f v (lupd(x\<mapsto>y) s) = lupd(x\<mapsto>y) (upd_obj a f v s)"
by (simp add: upd_obj_def Let_def split_beta)

lemma upd_obj_del_locs [simp]:
  "upd_obj a f v (del_locs s) = del_locs (upd_obj a f v s)"
by (simp add: upd_obj_def Let_def split_beta)

lemma get_field_hupd_same [simp]:
 "get_field (hupd(a\<mapsto>(C, fs)) s) a = the \<circ> fs"
apply (rule ext)
by (simp add: get_field_def get_obj_def)

lemma get_field_hupd_other [simp]:
 "aa \<noteq> a  \<Longrightarrow> get_field (hupd(aa\<mapsto>obj) s) a = get_field s a"
apply (rule ext)
by (simp add: get_field_def get_obj_def)

lemma new_AddrD:
"new_Addr s = v \<Longrightarrow> (\<exists>a. v = Addr a \<and> heap s a = None) | v = Null"
apply (unfold new_Addr_def)
apply (erule subst)
apply (rule someI)
apply (rule disjI2)
apply (rule HOL.refl)
done

end


theory TopoS_Impl
imports TopoS_Library TopoS_Composition_Theory_impl
    (*Mehr Meta wagen!*)
    "Security_Invariants/METASINVAR_SystemBoundary"
    (*stuff*)
    "Lib/ML_GraphViz"
    TopoS_Stateful_Policy_impl
begin

section {* ML Visualization Interface *}

definition print_offending_flows_debug ::
  "'v  SecurityInvariant list \<Rightarrow> 'v list_graph \<Rightarrow> (string \<times> ('v \<times> 'v) list list) list" where
  "print_offending_flows_debug M G = map
    (\<lambda>m.
         (implc_description m @ '' ('' @ implc_type m @ '')''
         , implc_offending_flows m G)
    ) M"

(*TODO: move and tune*)
ML{*
fun pretty_assoclist ctxt header t = let
    val ls : (term * term) list = t |> HOLogic.dest_list |> map HOLogic.dest_prod;
    val pretty = fn t => Pretty.string_of (Syntax.pretty_term ctxt t);
    in ls
       |> map (fn (x, y) => "  "^pretty x^": "^pretty y)
       |> space_implode "\n"
       |> (fn s => header^s)
       |> writeln end
*}

subsection{*Utility Functions*}

  fun rembiflowdups :: "('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list" where
    "rembiflowdups [] = []" |
    "rembiflowdups ((s,r)#as) = (if (s,r) \<in> set as \<or> (r,s) \<in> set as then rembiflowdups as else (s,r)#rembiflowdups as)"

  lemma rembiflowdups_complete: "\<lbrakk> \<forall>(s,r) \<in> set x. (r,s) \<in> set x \<rbrakk> \<Longrightarrow> set (rembiflowdups x) \<union> set (backlinks (rembiflowdups x)) = set x"
    proof
      assume a: "\<forall>(s,r) \<in> set x. (r,s) \<in> set x"
      have subset1: "set (rembiflowdups x) \<subseteq> set x"
        apply(induction x)
         apply(simp)
        apply(clarsimp)
        apply(simp split: if_split_asm)
         by(blast)+
      have set_backlinks_simp: "\<And> x. \<forall>(s,r) \<in> set x. (r,s) \<in> set x \<Longrightarrow> set (backlinks x) = set x"
        apply(simp add: backlinks_set)
        apply(rule)
         by fast+
      have subset2: "set (backlinks (rembiflowdups x)) \<subseteq> set x"
        apply(subst set_backlinks_simp[OF a, symmetric])
        by(simp add: backlinks_subset subset1)

      from subset1 subset2
      show "set (rembiflowdups x) \<union> set (backlinks (rembiflowdups x)) \<subseteq> set x" by blast
    next
      show "set x \<subseteq> set (rembiflowdups x) \<union> set (backlinks (rembiflowdups x))"
        apply(rule)
        apply(induction x)
         apply(simp)
        apply(rename_tac a as e)
        apply(simp)
        apply(erule disjE)
         apply(simp)
         defer
         apply fastforce
        apply(case_tac a)
        apply(rename_tac s r)
        apply(case_tac "(s,r) \<notin> set as \<and> (r,s) \<notin> set as")
         apply(simp)
        apply(simp add: backlinks_set)
        by blast
      qed

  text{*only for prettyprinting*}
  definition filter_for_biflows:: "('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list" where
    "filter_for_biflows E \<equiv> [e \<leftarrow> E. (snd e, fst e) \<in> set E]"

  definition filter_for_uniflows:: "('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list" where
    "filter_for_uniflows E \<equiv> [e \<leftarrow> E. (snd e, fst e) \<notin> set E]"

  lemma filter_for_biflows_correct: "\<forall>(s,r) \<in> set (filter_for_biflows E). (r,s) \<in> set (filter_for_biflows E)"
    unfolding filter_for_biflows_def
    by(induction E, auto)

  lemma filter_for_biflows_un_filter_for_uniflows: "set (filter_for_biflows E) \<union> set (filter_for_uniflows E) = set E"
    apply(simp add: filter_for_biflows_def filter_for_uniflows_def) by blast

  definition partition_by_biflows :: "('a \<times> 'a) list \<Rightarrow> (('a \<times> 'a) list \<times> ('a \<times> 'a) list)" where
    "partition_by_biflows E \<equiv> (rembiflowdups (filter_for_biflows E), remdups (filter_for_uniflows E))"

  lemma partition_by_biflows_correct: "case partition_by_biflows E of (biflows, uniflows) \<Rightarrow> set biflows \<union> set (backlinks (biflows)) \<union> set uniflows = set E"
    apply(simp add: partition_by_biflows_def)
    by(simp add: filter_for_biflows_un_filter_for_uniflows filter_for_biflows_correct rembiflowdups_complete)

  lemma "partition_by_biflows [(1::int, 1::int), (1,2), (2, 1), (1,3)] = ([(1, 1), (2, 1)], [(1, 3)])" by eval

ML{*
(*apply args to f. f ist best supplied using @{const_name "name_of_function"} *)
fun apply_function (ctxt: Proof.context) (f: string) (args: term list) : term =
  let
    val _ = writeln ("applying "^f^" to " ^ (fold (fn t => fn acc => acc^(Pretty.string_of (Syntax.pretty_term (Config.put show_types true ctxt) t))^" ") args ""));
    (*val t_eval = Code_Evaluation.dynamic_value_strict thy t;*)
    (* $ associates to the left, give f its arguments*)
    val applied_untyped_uneval: term = list_comb (Const (f, dummyT), args);
    val applied_uneval: term = Syntax.check_term ctxt applied_untyped_uneval;
  in
    applied_uneval |> Code_Evaluation.dynamic_value_strict ctxt
  end;

(*ctxt -> edges -> (biflows, uniflows)*)
fun partition_by_biflows ctxt (t: term) : (term * term) =
  apply_function ctxt @{const_name "partition_by_biflows"} [t] |> HOLogic.dest_prod

local
  fun get_tune_node_format (edges: term) : term -> string -> string =
    if (fastype_of edges) = @{typ "(string \<times> string) list"}
    then
      tune_string_vertex_format
    else
      Graphviz.default_tune_node_format;

  fun evalutae_term ctxt (edges: term) : term =
    case Code_Evaluation.dynamic_value ctxt edges
      of SOME x => x
      | NONE => raise TERM ("could not evaluate", []);
in
  fun visualize_edges ctxt (edges: term) (coloredges: (string * term) list) (graphviz_header: string) =
    let
      val _ = writeln("visualize_edges");
      val (biflows, uniflows) = partition_by_biflows ctxt edges;
    in
      Graphviz.visualize_graph_pretty ctxt (get_tune_node_format edges) ([
      ("", uniflows),
      ("edge [dir=\"none\", color=\"#000000\"]", biflows)] @ coloredges) (*dir=none, dir=both*)
       graphviz_header
    end

  (*iterate over the edges in ML, useful for printing them in certain formats*)
  fun iterate_edges_ML ctxt (edges: term) (all: (string*string) -> unit) (bi: (string*string) -> unit) (uni: (string*string) -> unit): unit =
    let
      val _ = writeln("iterate_edges_ML");
      val tune_node_format = (get_tune_node_format edges);
      val node_to_string = Graphviz.node_to_string ctxt tune_node_format;
      val evaluated_edges : term = evalutae_term ctxt edges;
      val (biflows, uniflows) = partition_by_biflows ctxt evaluated_edges;
    in
      let
        fun edge_to_list (es: term) : (term * term) list = es |> HOLogic.dest_list |> map HOLogic.dest_prod;
        fun edge_to_string (es: (term * term) list) : (string * string) list =
          map (fn (v1, v2) => (node_to_string v1, node_to_string v2)) es
      in
        edge_to_list evaluated_edges |> edge_to_string |> map all;
        edge_to_list biflows |> edge_to_string |> map bi;
        edge_to_list uniflows |> edge_to_string |> map uni;
        ()
      end
      handle Subscript => writeln ("Subscript Exception in iterate_edges_ML")
    end;

end
*}

ML_val{*
local
  val (biflows, uniflows) = partition_by_biflows @{context} @{term "[(1::int, 1::int), (1,2), (2, 1), (1,3)]"};
in
  val _ = Pretty.writeln (Syntax.pretty_term (Config.put show_types true @{context}) biflows);
  val _ = Pretty.writeln (Syntax.pretty_term (Config.put show_types true @{context}) uniflows);
end;

val t = fastype_of @{term "[(''x'', 2::nat)]"};

*}
ML_val{*(*
visualize_edges @{context}  @{term "[(1::int, 1::int), (1,2), (2, 1), (1,3)]"} []; *)
*}

definition internal_get_invariant_types_list:: "'a SecurityInvariant list \<Rightarrow> string list" where
  "internal_get_invariant_types_list M \<equiv> map implc_type M"

definition internal_node_configs :: "'a list_graph \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times>'b) list" where
  "internal_node_configs G config \<equiv> zip (nodesL G) (map config (nodesL G))"

ML {*
local
  fun get_graphivz_node_desc ctxt (node_config: term): string =
   let
     val (node, config) = HOLogic.dest_prod node_config;
     (*TODO: tune node format? There must be a better way ...*)
     val tune_node_format = if (fastype_of node) = @{typ "string"}
      then
        tune_string_vertex_format
      else
        Graphviz.default_tune_node_format;
     val node_str = Graphviz.node_to_string ctxt tune_node_format node;
     val config_str = Graphviz.term_to_string_html ctxt config;
   in
     node_str^"[label=<

"^node_str^"

"^config_str^"

>]\n"
   end;
in
  fun generate_graphviz_header ctxt (G: term) (configs: term): string =
    let
      val configlist: term list = apply_function ctxt @{const_name "internal_node_configs"} [G, configs] |> HOLogic.dest_list;
    in
      fold (fn c => fn acc => acc^get_graphivz_node_desc ctxt c) configlist ""
    end;
end;

(* Convenience function. Use whenever possible!
  M: security requirements, list
  G: list_graph*)
fun visualize_graph_header ctxt (M: term) (G: term) (Config: term): unit =
  let
    val wf_list_graph = apply_function ctxt @{const_name "wf_list_graph"} [G];
    val all_fulfilled = apply_function ctxt @{const_name "all_security_requirements_fulfilled"} [M, G];
    val edges = apply_function ctxt @{const_name "edgesL"} [G];
    val invariants = apply_function ctxt @{const_name "internal_get_invariant_types_list"} [M];
    val _ = writeln("Invariants:" ^ Pretty.string_of (Syntax.pretty_term ctxt invariants));
    val header = if Config = @{term "[]"} then "#header" else generate_graphviz_header ctxt G Config;
  in
    if wf_list_graph = @{term "False"} then
      error ("The supplied graph is syntactically invalid. Check wf_list_graph.")
    else if all_fulfilled = @{term "False"} then
      (let
        val offending = apply_function ctxt @{const_name "implc_get_offending_flows"} [M, G];
        val offending_flat = apply_function ctxt @{const_name "List.remdups"} [apply_function ctxt @{const_name "List.concat"} [offending]];
        val offending_debug = apply_function ctxt @{const_name print_offending_flows_debug} [M, G];
      in
       writeln("offending flows:");
       Pretty.writeln (Syntax.pretty_term ctxt offending);
       pretty_assoclist ctxt "Offending flows per invariant:\n" offending_debug;
       visualize_edges ctxt edges [("edge [dir=\"arrow\", style=dashed, color=\"#FF0000\", constraint=false]", offending_flat)] header;
      () end)
    else if all_fulfilled <> @{term "True"} then raise ERROR "all_fulfilled neither False nor True" else (
       writeln("All valid:");
       visualize_edges ctxt edges [] header;
      ())
  end;

fun visualize_graph ctxt (M: term) (G: term): unit = visualize_graph_header ctxt M G @{term "[]"};
*}

end