theory TopoS_Composition_Theory_impl
imports TopoS_Interface_impl TopoS_Composition_Theory
begin

section{*Composition Theory -- List Implementation*}

text{*Several invariants may apply to one policy. *}

(*the packed network model record from the list implementation*)
term "X::('v::vertex, 'a, 'b) TopoS_packed"

subsection{*Generating instantiated (configured) network security invariants*}

  --"a configured network security invariant in list implementaion"
  (*very minimal version, no eval, ...*)
  record ('v) SecurityInvariant =
    implc_sinvar::"('v) list_graph \<Rightarrow> bool"
    implc_offending_flows::"('v) list_graph \<Rightarrow> ('v \<times> 'v) list list"
    implc_isIFS::"bool"

  text{* Test if this definition is compliant with the formal definition on sets. *}
  definition SecurityInvariant_complies_formal_def ::
    "('v) SecurityInvariant \<Rightarrow> 'v TopoS_Composition_Theory.SecurityInvariant_configured \<Rightarrow> bool" where
    "SecurityInvariant_complies_formal_def impl spec \<equiv>
      (\<forall> G. valid_list_graph G \<longrightarrow> implc_sinvar impl G = c_sinvar spec (list_graph_to_graph G)) \<and>
      (\<forall> G. valid_list_graph G \<longrightarrow> set`set (implc_offending_flows impl G) = c_offending_flows spec (list_graph_to_graph G)) \<and>
      (implc_isIFS impl = c_isIFS spec)"

  fun new_configured_list_SecurityInvariant ::
    "('v::vertex, 'a, 'b) TopoS_packed \<Rightarrow> ('v::vertex, 'a, 'b) TopoS_Params \<Rightarrow>
        ('v SecurityInvariant)" where
      "new_configured_list_SecurityInvariant m C =
        (let nP = nm_node_props m C in
         \<lparr>
            implc_sinvar = (\<lambda>G. (nm_sinvar m) G nP),
            implc_offending_flows = (\<lambda>G. (nm_offending_flows m) G nP),
            implc_isIFS = nm_receiver_violation m
          \<rparr>)"

  text{* the @{term TopoS_Composition_Theory.new_configured_SecurityInvariant} must give a result if we have the SecurityInvariant modelLibrary*}
  lemma TopoS_modelLibrary_yields_new_configured_SecurityInvariant:
    assumes NetModelLib: "TopoS_modelLibrary m sinvar_spec verify_gloabls_spec"
    and     nPdef:       "nP = nm_node_props m C"
    and formalSpec:      "Spec = \<lparr>
                              c_sinvar = (\<lambda>G. sinvar_spec G nP),
                              c_offending_flows = (\<lambda>G. SecurityInvariant_withOffendingFlows.set_offending_flows sinvar_spec G nP),
                              c_isIFS = nm_receiver_violation m
                            \<rparr>"
    shows "new_configured_SecurityInvariant (sinvar_spec, nm_default m, nm_receiver_violation m, nP) = Some Spec"
    proof -
      from NetModelLib have NetModel: "SecurityInvariant sinvar_spec (nm_default m) (nm_receiver_violation m)"
        by(simp add: TopoS_modelLibrary_def TopoS_List_Impl_def)

      have Spec: "\<lparr>c_sinvar = \<lambda>G. sinvar_spec G nP,
             c_offending_flows = \<lambda>G. SecurityInvariant_withOffendingFlows.set_offending_flows sinvar_spec G nP,
             c_isIFS = nm_receiver_violation m\<rparr> = Spec"
      by(simp add: formalSpec)
      show ?thesis
        unfolding new_configured_SecurityInvariant.simps
        by(simp add: NetModel Spec)
    qed
    thm TopoS_modelLibrary_yields_new_configured_SecurityInvariant[simplified] (*todo fold in Spec*)

  (* The new_* functions comply, i.e. we can instance network security models that are executable. *)
  lemma new_configured_list_SecurityInvariant_complies:
    assumes NetModelLib: "TopoS_modelLibrary m sinvar_spec verify_gloabls_spec"
    and     nPdef:       "nP = nm_node_props m C"
    and formalSpec:      "Spec = new_configured_SecurityInvariant (sinvar_spec, nm_default m, nm_receiver_violation m, nP)"
    and implSpec:        "Impl = new_configured_list_SecurityInvariant m C"
    shows "SecurityInvariant_complies_formal_def Impl (the Spec)"
    proof -
      from TopoS_modelLibrary_yields_new_configured_SecurityInvariant[OF NetModelLib nPdef]
      have SpecUnfolded: "new_configured_SecurityInvariant (sinvar_spec, nm_default m, nm_receiver_violation m, nP) =
        Some \<lparr>c_sinvar = \<lambda>G. sinvar_spec G nP,
             c_offending_flows = \<lambda>G. SecurityInvariant_withOffendingFlows.set_offending_flows sinvar_spec G nP,
             c_isIFS = nm_receiver_violation m\<rparr>" by simp

      from NetModelLib show ?thesis
        apply(simp add: SpecUnfolded formalSpec implSpec Let_def)
        apply(simp add: SecurityInvariant_complies_formal_def_def)
        apply(simp add: TopoS_modelLibrary_def TopoS_List_Impl_def)
        apply(simp add: nPdef)
        done
    qed

  corollary new_configured_list_SecurityInvariant_complies':
    "\<lbrakk> TopoS_modelLibrary m sinvar_spec verify_gloabls_spec \<rbrakk> \<Longrightarrow>
    SecurityInvariant_complies_formal_def (new_configured_list_SecurityInvariant m C) (the (new_configured_SecurityInvariant (sinvar_spec, nm_default m, nm_receiver_violation m,  nm_node_props m C)))"
    apply(drule new_configured_list_SecurityInvariant_complies)
    by(simp_all)

  --"From"
  thm new_configured_SecurityInvariant_sound
  --"we get that @{const new_configured_list_SecurityInvariant} has all the necessary properties (modulo @{const SecurityInvariant_complies_formal_def})"

subsection{*About security invariants*}

   text{*specification and implementation comply. *}
   type_synonym 'v security_models_spec_impl="('v SecurityInvariant \<times> 'v TopoS_Composition_Theory.SecurityInvariant_configured) list"

   definition get_spec :: "'v security_models_spec_impl \<Rightarrow> ('v TopoS_Composition_Theory.SecurityInvariant_configured) list" where
    "get_spec M \<equiv> [snd m. m \<leftarrow> M]"
   definition get_impl :: "'v security_models_spec_impl \<Rightarrow> ('v SecurityInvariant) list" where
    "get_impl M \<equiv> [fst m. m \<leftarrow> M]"

subsection{*Calculating offending flows*}
  fun implc_get_offending_flows :: "('v) SecurityInvariant list \<Rightarrow> 'v list_graph \<Rightarrow> (('v \<times> 'v) list list)" where
    "implc_get_offending_flows [] G = []"  |
    "implc_get_offending_flows (m#Ms) G = (implc_offending_flows m G)@(implc_get_offending_flows Ms G)"

  lemma implc_get_offending_flows_fold:
    "implc_get_offending_flows M G = fold (\<lambda>m accu. accu@(implc_offending_flows m G)) M []"
    proof-
    { fix accu
      have "accu@(implc_get_offending_flows M G) = fold (\<lambda>m accu. accu@(implc_offending_flows m G)) M accu"
      apply(induction M arbitrary: accu)
       apply(simp_all)
      by(metis append_eq_appendI) }
    from this[where accu2="[]"] show ?thesis by simp
  qed

  lemma implc_get_offending_flows_Un: "set`set (implc_get_offending_flows M G) = (\<Union>m\<in>set M. set`set (implc_offending_flows m G))"
    apply(induction M)
     apply(simp_all)
    by (metis image_Un)

  lemma implc_get_offending_flows_map_concat: "(implc_get_offending_flows M G) = concat [implc_offending_flows m G. m \<leftarrow> M]"
    apply(induction M)
     by(simp_all)

  theorem implc_get_offending_flows_complies:
    assumes a1: "\<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec"
    and     a2: "valid_list_graph G"
    shows   "set`set (implc_get_offending_flows (get_impl M) G) = (get_offending_flows (get_spec M) (list_graph_to_graph G))"
    proof -
      from a1 have "\<forall> (m_impl, m_spec) \<in> set M. set ` set (implc_offending_flows m_impl G) = c_offending_flows m_spec (list_graph_to_graph G)"
        apply(simp add: SecurityInvariant_complies_formal_def_def)
        using a2 by blast
      hence "\<forall> m \<in> set M. set ` set (implc_offending_flows (fst m) G) = c_offending_flows (snd m) (list_graph_to_graph G)" by fastforce
      thus ?thesis
        by(simp add: get_impl_def get_spec_def implc_get_offending_flows_Un get_offending_flows_def)
   qed

subsection{*Accessors*}
  definition get_IFS :: "'v SecurityInvariant list \<Rightarrow> 'v SecurityInvariant list" where
    "get_IFS M \<equiv> [m \<leftarrow> M. implc_isIFS m]"
  definition get_ACS :: "'v SecurityInvariant list \<Rightarrow> 'v SecurityInvariant list" where
    "get_ACS M \<equiv> [m \<leftarrow> M. \<not> implc_isIFS m]"

  lemma get_IFS_get_ACS_complies:
  assumes a: "\<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec"
    shows "\<forall> (m_impl, m_spec) \<in> set (zip (get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M))).
      SecurityInvariant_complies_formal_def m_impl m_spec"
    and "\<forall> (m_impl, m_spec) \<in> set (zip (get_ACS (get_impl M)) (TopoS_Composition_Theory.get_ACS (get_spec M))).
      SecurityInvariant_complies_formal_def m_impl m_spec"
    proof -
      from a have "\<forall> (m_impl, m_spec) \<in> set M. implc_isIFS m_impl = c_isIFS m_spec"
        apply(simp add: SecurityInvariant_complies_formal_def_def) by fastforce
      hence set_zip_IFS: "set (zip (filter implc_isIFS (get_impl M)) (filter c_isIFS (get_spec M))) \<subseteq> set M"
        apply(simp add: get_impl_def get_spec_def)
        apply(induction M)
         apply(simp_all)
        by force
      from set_zip_IFS a show "\<forall> (m_impl, m_spec) \<in> set (zip (get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M))).
          SecurityInvariant_complies_formal_def m_impl m_spec"
        apply(simp add: get_IFS_def get_ACS_def
          TopoS_Composition_Theory.get_IFS_def TopoS_Composition_Theory.get_ACS_def) by blast
      next
      from a have "\<forall> (m_impl, m_spec) \<in> set M. implc_isIFS m_impl = c_isIFS m_spec"
        apply(simp add: SecurityInvariant_complies_formal_def_def) by fastforce
      hence set_zip_ACS: "set (zip [m\<leftarrow>get_impl M . \<not> implc_isIFS m] [m\<leftarrow>get_spec M . \<not> c_isIFS m]) \<subseteq> set M"
        apply(simp add: get_impl_def get_spec_def)
        apply(induction M)
         apply(simp_all)
        by force
      from this a show "\<forall> (m_impl, m_spec) \<in> set (zip (get_ACS (get_impl M)) (TopoS_Composition_Theory.get_ACS (get_spec M))).
        SecurityInvariant_complies_formal_def m_impl m_spec"
        apply(simp add: get_IFS_def get_ACS_def
          TopoS_Composition_Theory.get_IFS_def TopoS_Composition_Theory.get_ACS_def) by fast
     qed

   lemma get_IFS_get_ACS_select_simps:
    assumes a1: "\<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec"
    shows "\<forall> (m_impl, m_spec) \<in> set (zip (get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M))). SecurityInvariant_complies_formal_def m_impl m_spec" (is "\<forall> (m_impl, m_spec) \<in> set ?zippedIFS. SecurityInvariant_complies_formal_def m_impl m_spec")
    and   "(get_impl (zip (TopoS_Composition_Theory_impl.get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M)))) = TopoS_Composition_Theory_impl.get_IFS (get_impl M)"
    and   "(get_spec (zip (TopoS_Composition_Theory_impl.get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M)))) = TopoS_Composition_Theory.get_IFS (get_spec M)"
    and   "\<forall> (m_impl, m_spec) \<in> set (zip (get_ACS (get_impl M)) (TopoS_Composition_Theory.get_ACS (get_spec M))). SecurityInvariant_complies_formal_def m_impl m_spec" (is "\<forall> (m_impl, m_spec) \<in> set ?zippedACS. SecurityInvariant_complies_formal_def m_impl m_spec")
    and   "(get_impl (zip (TopoS_Composition_Theory_impl.get_ACS (get_impl M)) (TopoS_Composition_Theory.get_ACS (get_spec M)))) = TopoS_Composition_Theory_impl.get_ACS (get_impl M)"
    and   "(get_spec (zip (TopoS_Composition_Theory_impl.get_ACS (get_impl M)) (TopoS_Composition_Theory.get_ACS (get_spec M)))) = TopoS_Composition_Theory.get_ACS (get_spec M)"
    proof -
        from get_IFS_get_ACS_complies(1)[OF a1]
        show "\<forall> (m_impl, m_spec) \<in> set (?zippedIFS). SecurityInvariant_complies_formal_def m_impl m_spec" by simp
      next
        from a1 show "(get_impl ?zippedIFS) = TopoS_Composition_Theory_impl.get_IFS (get_impl M)"
          apply(simp add: TopoS_Composition_Theory_impl.get_IFS_def get_spec_def get_impl_def TopoS_Composition_Theory.get_IFS_def)
          apply(induction M)
           apply(simp)
          apply(simp)
          apply(rule conjI)
           apply(clarify)
           using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          apply(clarify)
          using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          done
      next
        from a1 show "(get_spec ?zippedIFS) = TopoS_Composition_Theory.get_IFS (get_spec M)"
          apply(simp add: TopoS_Composition_Theory_impl.get_IFS_def get_spec_def get_impl_def TopoS_Composition_Theory.get_IFS_def)
          apply(induction M)
           apply(simp)
          apply(simp)
          apply(rule conjI)
           apply(clarify)
           using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          apply(clarify)
          using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          done
      next
        from get_IFS_get_ACS_complies(2)[OF a1]
        show "\<forall> (m_impl, m_spec) \<in> set (?zippedACS). SecurityInvariant_complies_formal_def m_impl m_spec" by simp
      next
        from a1 show "(get_impl ?zippedACS) = TopoS_Composition_Theory_impl.get_ACS (get_impl M)"
          apply(simp add: TopoS_Composition_Theory_impl.get_ACS_def get_spec_def get_impl_def TopoS_Composition_Theory.get_ACS_def)
          apply(induction M)
           apply(simp)
          apply(simp)
          apply(rule conjI)
           apply(clarify)
           using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          apply(clarify)
          using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          done
      next
        from a1 show "(get_spec ?zippedACS) = TopoS_Composition_Theory.get_ACS (get_spec M)"
          apply(simp add: TopoS_Composition_Theory_impl.get_ACS_def get_spec_def get_impl_def TopoS_Composition_Theory.get_ACS_def)
          apply(induction M)
           apply(simp)
          apply(simp)
          apply(rule conjI)
           apply(clarify)
           using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          apply(clarify)
          using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          done
      qed

   thm get_IFS_get_ACS_select_simps

subsection{*All security requirements fulfilled*}
   definition all_security_requirements_fulfilled :: "'v SecurityInvariant list \<Rightarrow> 'v list_graph \<Rightarrow> bool" where
      "all_security_requirements_fulfilled M G \<equiv> \<forall>m \<in> set M. (implc_sinvar m) G"

  lemma all_security_requirements_fulfilled_complies:
    "\<lbrakk> \<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec;
       valid_list_graph (G::('v::vertex) list_graph) \<rbrakk> \<Longrightarrow>
    all_security_requirements_fulfilled (get_impl M) G <-> TopoS_Composition_Theory.all_security_requirements_fulfilled (get_spec M) (list_graph_to_graph G)"
    apply(simp add: all_security_requirements_fulfilled_def TopoS_Composition_Theory.all_security_requirements_fulfilled_def)
    apply(simp add: get_impl_def get_spec_def)
    using SecurityInvariant_complies_formal_def_def by fastforce

subsection{*generate valid topology*}
  value "concat [[1::int,2,3], [4,6,5]]"

  fun generate_valid_topology :: "('v) SecurityInvariant list \<Rightarrow> 'v list_graph \<Rightarrow> ('v list_graph)" where
    "generate_valid_topology M G = delete_edges G (concat (implc_get_offending_flows M G))"

  lemma generate_valid_topology_complies:
    "\<lbrakk> \<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec;
       valid_list_graph (G::('v::vertex) list_graph) \<rbrakk> \<Longrightarrow>
       list_graph_to_graph (generate_valid_topology (get_impl M) G) =
       TopoS_Composition_Theory.generate_valid_topology (get_spec M) (list_graph_to_graph G)"
    apply(subst generate_valid_topology_def_alt)
    apply(drule(1) implc_get_offending_flows_complies)
    apply(simp)
    apply(simp add: delete_edges_correct[symmetric])
    apply(simp add: list_graph_to_graph_def FiniteGraph.delete_edges_simp2)
    apply(simp)
    by blast

end


theory OS_kernel_inv
  imports OS_kernel_sys
begin

section \<open> invariant verification \<close>

theorem "invariant_presv_pares \<Gamma> inv (paresys_spec Memory_manage_system_Spec) {s0} sys_rely"
  apply(rule invariant_theorem[where G="sys_guar" and pst = UNIV])
  using mem_sys_sat apply fast
    apply(simp add:sys_rely_def stable_def)
    apply(simp add:sys_guar_def)
   apply(rule stable_un_R)
    apply(rule stable_un_R)
     apply (simp add: sched_guar_stb_inv stable_def)
    apply (simp add: Tick_guar_stb_inv stable_def)
  apply (simp add: OSMemGet_guar_stb_inv OSMem_eq_guar stable_un_S)
  using s0_inv apply simp
  done

end


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

(*
 * Tactic for solving monadic equalities, such as:
 *
 * (liftE (return 3) = returnOk 3
 *
 * Theorems of the form:
 *
 *   ((a, s') \<in> fst (A s)) = P a s s'
 *
 * and
 *
 *   snd (A s) = P s
 *
 * are added to the "monad_eq" set.
 *)
theory MonadEq
imports "Monad_WP/NonDetMonadVCG"
begin

(* Setup "monad_eq" attributes. *)
ML {*
structure MonadEqThms = Named_Thms (
    val name = Binding.name "monad_eq"
    val description = "monad equality-prover theorems"
    )
*}
attribute_setup monad_eq = {*
  Attrib.add_del
    (Thm.declaration_attribute MonadEqThms.add_thm)
    (Thm.declaration_attribute MonadEqThms.del_thm) *}
  "Monad equality-prover theorems"

(* Setup tactic. *)

ML {*
fun monad_eq_tac ctxt =
let
  (* Set a simpset as being hidden, so warnings are not printed from it. *)
  val ctxt' = Context_Position.set_visible false ctxt
in
  CHANGED (clarsimp_tac (ctxt' addsimps (MonadEqThms.get ctxt')) 1)
end
*}

method_setup monad_eq = {*
    Method.sections Clasimp.clasimp_modifiers >> (K (SIMPLE_METHOD o monad_eq_tac)) *}
  "prove equality on monads"

lemma monad_eq_simp_state [monad_eq]:
  "((A :: ('s, 'a) nondet_monad) s = B s') =
      ((\<forall>r t. (r, t) \<in> fst (A s) \<longrightarrow> (r, t) \<in> fst (B s'))
         \<and> (\<forall>r t. (r, t) \<in> fst (B s') \<longrightarrow> (r, t) \<in> fst (A s))
         \<and> (snd (A s) = snd (B s')))"
  apply (auto intro!: set_eqI prod_eqI)
  done

lemma monad_eq_simp [monad_eq]:
  "((A :: ('s, 'a) nondet_monad) = B) =
      ((\<forall>r t s. (r, t) \<in> fst (A s) \<longrightarrow> (r, t) \<in> fst (B s))
         \<and> (\<forall>r t s. (r, t) \<in> fst (B s) \<longrightarrow> (r, t) \<in> fst (A s))
         \<and> (\<forall>x. snd (A x) = snd (B x)))"
  apply (auto intro!: set_eqI prod_eqI)
  done

declare in_monad [monad_eq]
declare in_bindE [monad_eq]

(* Test *)
lemma "returnOk 3 = liftE (return 3)"
  apply monad_eq
  oops

end


section \<open>Stack by Array\<close>
theory Impl_Array_Stack
imports
  Automatic_Refinement.Automatic_Refinement
  "../../Lib/Diff_Array"
begin

type_synonym 'a array_stack = "'a array \<times> nat"

term Diff_Array.array_length

definition "as_raw_\<alpha> s \<equiv> take (snd s) (list_of_array (fst s))"
definition "as_raw_invar s \<equiv> snd s \<le> array_length (fst s)"

definition as_rel_def_internal: "as_rel R \<equiv> br as_raw_\<alpha> as_raw_invar O \<langle>R\<rangle>list_rel"
lemma as_rel_def: "\<langle>R\<rangle>as_rel \<equiv> br as_raw_\<alpha> as_raw_invar O \<langle>R\<rangle>list_rel"
  unfolding as_rel_def_internal[abs_def] by (simp add: relAPP_def)

lemma [relator_props]: "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>as_rel)"
  unfolding as_rel_def
  by tagged_solver

lemmas [autoref_rel_intf] = REL_INTFI[of as_rel i_list]

definition "as_empty (_::unit) \<equiv> (array_of_list [],0)"

lemma as_empty_refine[autoref_rules]: "(as_empty (),[]) \<in> \<langle>R\<rangle>as_rel"
  unfolding as_rel_def as_empty_def br_def
  unfolding as_raw_\<alpha>_def as_raw_invar_def
  by auto

definition "as_push s x \<equiv> let
    (a,n)=s;
    a = if n = array_length a then
        array_grow a (max 4 (2*n)) x
      else a;
    a = array_set a n x
  in
    (a,n+1)"

lemma as_push_refine[autoref_rules]:
  "(as_push,op_list_append_elem) \<in> \<langle>R\<rangle>as_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (simp add: as_push_def op_list_append_elem_def as_rel_def br_def
    as_raw_\<alpha>_def as_raw_invar_def)
  apply clarsimp
  apply safe
  apply (rule)
  apply auto []
  apply (clarsimp simp: array_length_list) []
  apply parametricity

  apply rule
  apply auto []
  apply (auto simp: take_Suc_conv_app_nth array_length_list list_update_append) []
  apply parametricity
  done

term array_shrink

definition "as_shrink s \<equiv> let
    (a,n) = s;
    a = if 128*n \<le> array_length a \<and> n>4 then
        array_shrink a n
      else a
  in
    (a,n)"

lemma as_shrink_id_refine: "(as_shrink,id) \<in> \<langle>R\<rangle>as_rel \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (simp add: as_shrink_def as_rel_def br_def
    as_raw_\<alpha>_def as_raw_invar_def Let_def)
  apply clarsimp
  apply safe

  apply (rule)
  apply (auto simp: array_length_list)
  done

lemma as_shrinkI:
  assumes [param]: "(s,a)\<in>\<langle>R\<rangle>as_rel"
  shows "(as_shrink s,a)\<in>\<langle>R\<rangle>as_rel"
  apply (subst id_apply[of a,symmetric])
  apply (parametricity add: as_shrink_id_refine)
  done

definition "as_pop s \<equiv> let (a,n)=s in as_shrink (a,n - 1)"

lemma as_pop_refine[autoref_rules]: "(as_pop,butlast) \<in> \<langle>R\<rangle>as_rel \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (clarsimp simp add: as_pop_def split: prod.split)
  apply (rule as_shrinkI)

  apply (simp add: as_pop_def as_rel_def br_def
    as_raw_\<alpha>_def as_raw_invar_def Let_def)
  apply clarsimp

  apply rule
  apply (auto simp: array_length_list) []
  apply (clarsimp simp: array_length_list take_minus_one_conv_butlast) []
  apply parametricity
  done

definition "as_get s i \<equiv> let (a,_::nat)=s in array_get a i"

lemma as_get_refine:
  assumes 1: "i'<length l"
  assumes 2: "(a,l)\<in>\<langle>R\<rangle>as_rel"
  assumes 3[param]: "(i,i')\<in>nat_rel"
  shows "(as_get a i,l!i')\<in>R"
  using 2
  apply (clarsimp
    simp add: as_get_def as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def
    split: prod.split)
  apply (rename_tac aa bb)
  apply (case_tac aa, simp)
proof -
  fix n cl
  assume TKR[param]: "(take n cl, l) \<in> \<langle>R\<rangle>list_rel"

  have "(take n cl!i, l!i')\<in>R"
    by parametricity (rule 1)
  also have "take n cl!i = cl!i"
    using 1 3 list_rel_imp_same_length[OF TKR]
    by simp
  finally show "(cl!i,l!i')\<in>R" .
qed

context begin interpretation autoref_syn .
lemma as_get_autoref[autoref_rules]:
  assumes "(l,l')\<in>\<langle>R\<rangle>as_rel"
  assumes "(i,i')\<in>Id"
  assumes "SIDE_PRECOND (i' < length l')"
  shows "(as_get l i,(OP nth ::: \<langle>R\<rangle>as_rel \<rightarrow> nat_rel \<rightarrow> R)$l'$i')\<in>R"
  using assms by (simp add: as_get_refine)

definition "as_set s i x \<equiv> let (a,n::nat)=s in (array_set a i x,n)"

lemma as_set_refine[autoref_rules]:
  "(as_set,list_update)\<in>\<langle>R\<rangle>as_rel \<rightarrow> nat_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (clarsimp
    simp: as_set_def as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def
    split: prod.split)
  apply rule
  apply auto []
  apply parametricity
  by simp

definition as_length :: "'a array_stack \<Rightarrow> nat" where
  "as_length = snd"

lemma as_length_refine[autoref_rules]:
  "(as_length,length) \<in> \<langle>R\<rangle>as_rel \<rightarrow> nat_rel"
  by (auto
    simp: as_length_def as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def
      array_length_list
    dest!: list_rel_imp_same_length
  )

definition "as_top s \<equiv> as_get s (as_length s - 1)"

lemma as_top_code[code]: "as_top s = (let (a,n)=s in array_get a (n - 1))"
  unfolding as_top_def as_get_def as_length_def
  by (auto split: prod.split)

lemma as_top_refine: "\<lbrakk>l\<noteq>[]; (s,l)\<in>\<langle>R\<rangle>as_rel\<rbrakk> \<Longrightarrow> (as_top s,last l)\<in>R"
  unfolding as_top_def
  apply (simp add: last_conv_nth)
  apply (rule as_get_refine)
  apply (auto simp: as_length_def as_rel_def br_def as_raw_\<alpha>_def
    as_raw_invar_def array_length_list
    dest!: list_rel_imp_same_length)
  done

lemma as_top_autoref[autoref_rules]:
  assumes "(l,l')\<in>\<langle>R\<rangle>as_rel"
  assumes "SIDE_PRECOND (l' \<noteq> [])"
  shows "(as_top l,(OP last ::: \<langle>R\<rangle>as_rel \<rightarrow> R)$l')\<in>R"
  using assms by (simp add: as_top_refine)

definition "as_is_empty s \<equiv> as_length s = 0"
lemma as_is_empty_code[code]: "as_is_empty s = (snd s = 0)"
  unfolding as_is_empty_def as_length_def by simp

lemma as_is_empty_refine[autoref_rules]:
  "(as_is_empty,is_Nil) \<in> \<langle>R\<rangle>as_rel \<rightarrow> bool_rel"
proof
  fix s l
  assume [param]: "(s,l)\<in>\<langle>R\<rangle>as_rel"
  have "(as_is_empty s,length l = 0) \<in> bool_rel"
    unfolding as_is_empty_def
    by (parametricity add: as_length_refine)
  also have "length l = 0 \<longleftrightarrow> is_Nil l"
    by (cases l) auto
  finally show "(as_is_empty s, is_Nil l) \<in> bool_rel" .
qed

definition "as_take m s \<equiv> let (a,n) = s in
  if m<n then
    as_shrink (a,m)
  else (a,n)"

lemma as_take_refine[autoref_rules]:
  "(as_take,take)\<in>nat_rel \<rightarrow> \<langle>R\<rangle>as_rel \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (clarsimp simp add: as_take_def, safe)

  apply (rule as_shrinkI)
  apply (simp add: as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def)
  apply rule
  apply auto []
  apply clarsimp
  apply (subgoal_tac "take a' (list_of_array a) = take a' (take ba (list_of_array a))")
  apply (simp only: )
  apply (parametricity, rule IdI)
  apply simp

  apply (simp add: as_rel_def br_def as_raw_\<alpha>_def as_raw_invar_def)
  apply rule
  apply auto []
  apply clarsimp
  apply (frule list_rel_imp_same_length)
  apply simp
  done

definition "as_singleton x \<equiv> (array_of_list [x],1)"
lemma as_singleton_refine[autoref_rules]:
  "(as_singleton,op_list_singleton)\<in>R \<rightarrow> \<langle>R\<rangle>as_rel"
  apply (intro fun_relI)
  apply (simp add: as_singleton_def as_rel_def br_def as_raw_\<alpha>_def
    as_raw_invar_def)
  apply rule
  apply (auto simp: array_length_list) []
  apply simp
  done

end

end


theory Impl_List_Playground_statefulpolicycompliance
imports "../TopoS_Impl"
    Impl_List_Playground_ChairNetwork
begin

thm ChairNetwork_def
thm ChairSecurityRequirements_def

definition "ChairNetwork_stateful_IFS = \<lparr> hostsL = nodesL ChairNetwork, flows_fixL = edgesL ChairNetwork, flows_stateL = filter_IFS_no_violations ChairNetwork ChairSecurityRequirements \<rparr>"
value "edgesL ChairNetwork"
value "filter_IFS_no_violations ChairNetwork ChairSecurityRequirements"
value "ChairNetwork_stateful_IFS"
lemma "set (flows_stateL ChairNetwork_stateful_IFS) \<subseteq> (set (flows_fixL ChairNetwork_stateful_IFS))" by eval (*must always hold*)
value "(set (flows_fixL ChairNetwork_stateful_IFS)) - set (flows_stateL ChairNetwork_stateful_IFS)"
(*only problems: printers!!!*)
value "stateful_list_policy_to_list_graph ChairNetwork_stateful_IFS"

definition "ChairNetwork_stateful_ACS = \<lparr> hostsL = nodesL ChairNetwork, flows_fixL = edgesL ChairNetwork, flows_stateL = filter_compliant_stateful_ACS ChairNetwork ChairSecurityRequirements \<rparr>"
value "edgesL ChairNetwork"
value "filter_compliant_stateful_ACS ChairNetwork ChairSecurityRequirements"
value "ChairNetwork_stateful_ACS"
lemma "set (flows_stateL ChairNetwork_stateful_ACS) \<subseteq> (set (flows_fixL ChairNetwork_stateful_ACS))" by eval (*must always hold*)
value "(set (flows_fixL ChairNetwork_stateful_ACS)) - set (flows_stateL ChairNetwork_stateful_ACS)"

(*flows that are already allowed in both directions are not marked as stateful*)
value "((set (flows_fixL ChairNetwork_stateful_ACS)) - set (flows_stateL ChairNetwork_stateful_ACS)) - set (backlinks (flows_fixL ChairNetwork_stateful_ACS))"

(*the new backflows*)
value "set (edgesL (stateful_list_policy_to_list_graph ChairNetwork_stateful_ACS)) - (set (edgesL ChairNetwork))"

(*the resulting ACS graph*)
value "stateful_list_policy_to_list_graph ChairNetwork_stateful_ACS"

value "generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements"
value "generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements"
lemma "set (flows_fixL (generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements)) = set (flows_fixL (generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements))" by eval
lemma "set (flows_stateL (generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements)) = set (flows_stateL (generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements))" by eval

definition "ChairNetwork_stateful = generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements"

ML_val{*
visualize_edges @{context} @{term "flows_fixL ChairNetwork_stateful"}
  [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "flows_stateL ChairNetwork_stateful"})];
*}

end