theory Globalenvs
  imports Main
    Maps AST
    Integers Floats Values Memory
begin

(** Global environments are a component of the dynamic semantics of
  all languages involved in the compiler.  A global environment
  maps symbol names (names of functions and of global variables)
  to the corresponding memory addresses.  It also maps memory addresses
  of functions to the corresponding function descriptions.

  Global environments, along with the initial memory state at the beginning
  of program execution, are built from the program of interest, as follows:
- A distinct memory address is assigned to each function of the program.
  These function addresses use negative numbers to distinguish them from
  addresses of memory blocks.  The associations of function name to function
  address and function address to function description are recorded in
  the global environment.
- For each global variable, a memory block is allocated and associated to
  the name of the variable.

  These operations reflect (at a high level of abstraction) what takes
  place during program linking and program loading in a real operating
  system. *)

(** Auxiliary function for initialization of global variables. *)

fun store_zeros :: "mem \<Rightarrow> block \<Rightarrow> Z \<Rightarrow> Z \<Rightarrow> (mem option)" where
  "store_zeros m b p n =
  (if n \<le> 0 then Some m else
    (case Mem.store Mint8unsigned m b p (Vint 0) of
      Some m' \<Rightarrow> store_zeros m' b (p + 1) (n - 1)
    | None \<Rightarrow> None
    ))"

section \<open>Symbol environments\<close>

(** Symbol environments are a restricted view of global environments,
  focusing on symbol names and their associated blocks.  They do not
  contain mappings from blocks to function or variable definitions. *)

record Senv_t =
  senv_find_symbol :: "ident \<Rightarrow> block option"
  senv_public_symbol :: "ident \<Rightarrow> bool"
  senv_invert_symbol :: "block \<Rightarrow> ident option"
  senv_block_is_volatile :: "block \<Rightarrow> bool"
  senv_nextblock :: block

locale Senv'
begin

(** Operations *)
abbreviation "find_symbol \<equiv> senv_find_symbol"
abbreviation "public_symbol \<equiv> senv_public_symbol"
abbreviation "invert_symbol \<equiv> senv_invert_symbol"
abbreviation "block_is_volatile \<equiv> senv_block_is_volatile"
abbreviation "nextblock \<equiv> senv_nextblock"

(** Properties *)

named_theorems inv_defs'

definition [inv_defs']: "find_symbol_injective se \<equiv>
  \<forall>id1 id2 b. find_symbol se id1 = Some b \<longrightarrow> find_symbol se id2 = Some b \<longrightarrow> id1 = id2"

definition [inv_defs']: "invert_find_symbol se \<equiv>
  \<forall>id b. invert_symbol se b = Some id \<longrightarrow> find_symbol se id = Some b"

definition [inv_defs']: "find_invert_symbol se \<equiv>
  \<forall>id b. find_symbol se id = Some b \<longrightarrow> invert_symbol se b = Some id"

definition [inv_defs']: "public_symbol_exists se \<equiv>
  \<forall>id. public_symbol se id \<longrightarrow> (\<exists> b. find_symbol se id = Some b)"

definition [inv_defs']: "find_symbol_below se \<equiv>
  \<forall>id b. find_symbol se id = Some b \<longrightarrow> b < nextblock se"

definition [inv_defs']: "block_is_volatile_below se \<equiv>
  \<forall>b. block_is_volatile se b \<longrightarrow> b < nextblock se"

inductive invariants where
  "\<lbrakk> find_symbol_injective se;
     invert_find_symbol se;
     find_invert_symbol se;
     public_symbol_exists se;
     find_symbol_below se;
     block_is_volatile_below se \<rbrakk> \<Longrightarrow>
  invariants se"

lemmas inv_def = inv_defs' invariants.simps[simplified]

definition equiv :: "Senv_t \<Rightarrow> Senv_t \<Rightarrow> bool" where
  "equiv se1 se2 =
     ((\<forall> ident. find_symbol se2 ident = find_symbol se1 ident)
  \<and> (\<forall> ident. public_symbol se2 ident = public_symbol se1 ident)
  \<and> (\<forall> b. block_is_volatile se2 b = block_is_volatile se1 b))"
end

interpretation Senv: Senv' .

section \<open>Global Environments\<close>

record ('f, 'v) Genv_t =
  genv_public :: "ident list" (* which symbol names are public *)
  genv_symb :: "block ITree" (* mapping symbol -> block *)
  genv_defs :: "(('f, 'v) globdef) PTree" (* mapping block -> definition *)
  genv_next :: block (* next symbol pointer *)

locale Genv' =
  fixes ft :: "'f itself"
  fixes vt :: "'v itself"
begin

named_theorems inv_defs'

definition [inv_defs']: "genv_symb_range ge \<equiv>
  \<forall>id b. ITree.get id (genv_symb ge) = Some b \<longrightarrow> b < (genv_next ge)"

definition [inv_defs']: "genv_defs_range ge \<equiv>
  \<forall>b g. PTree.get b (genv_defs ge) = Some g \<longrightarrow> b < (genv_next ge)"

definition [inv_defs']: "genv_vars_inj ge \<equiv>
  \<forall>id1 id2 b.
  ITree.get id1 (genv_symb ge) = Some b \<longrightarrow> ITree.get id2 (genv_symb ge) = Some b \<longrightarrow> id1 = id2"

inductive invariants where
  "\<lbrakk>genv_symb_range ge;
    genv_defs_range ge;
    genv_vars_inj ge\<rbrakk> \<Longrightarrow>
  invariants ge"

lemmas inv_def = inv_defs' invariants.simps[simplified]

subsection \<open>Lookup functions\<close>

context
  fixes ge :: "('f, 'v) Genv_t"
begin

(** [find_symbol ge id] returns the block associated with the given name, if any *)

fun find_symbol :: "ident \<Rightarrow> (block option)" where
  "find_symbol ident = ITree.get ident (genv_symb ge)"

(** [symbol_address ge id ofs] returns a pointer into the block associated
  with [id], at byte offset [ofs].  [Vundef] is returned if no block is associated
  to [id]. *)

fun symbol_address :: "ident \<Rightarrow> m_ptrofs \<Rightarrow> val" where
  "symbol_address ident ofs =
  (case find_symbol ident of
    Some b \<Rightarrow> Vptr b ofs
  | None \<Rightarrow> Vundef
  )"

(** [public_symbol ge id] says whether the name [id] is public and defined. *)

fun public_symbol :: "ident \<Rightarrow> bool" where
  "public_symbol ident =
  (case find_symbol ident of
    None \<Rightarrow> False
  | Some _ \<Rightarrow> ident \<in> set (genv_public ge)
  )"

(** [find_def ge b] returns the global definition associated with the given address. *)

fun find_def :: "block \<Rightarrow> (('f, 'v) globdef) option" where
  "find_def b = PTree.get b (genv_defs ge)"

(** [find_funct_ptr ge b] returns the function description associated with
    the given address. *)

fun find_funct_ptr :: "block \<Rightarrow> ('f option)" where
  "find_funct_ptr b = (case find_def b of Some (Gfun f) \<Rightarrow> Some f | _ \<Rightarrow> None )"

(** [find_funct] is similar to [find_funct_ptr], but the function address
    is given as a value, which must be a pointer with offset 0. *)

fun find_funct :: "val \<Rightarrow> ('f option)" where
  "find_funct v =
  (case v of
    Vptr b ofs \<Rightarrow> if ofs = 0 then find_funct_ptr b else None
  | _ \<Rightarrow> None
  )"

(** [invert_symbol ge b] returns the name associated with the given block, if any *)

(* CompCert uses 'PTree.fold' here, which we can't because our tree doesn't have a structure *)
fun invert_symbol :: "block \<Rightarrow> (ident option)" where
  "invert_symbol b =
    (if \<exists>id. (genv_symb ge) id = Some b
      then Some (THE id. (genv_symb ge) id = Some b)
      else None)"

(** [find_var_info ge b] returns the information attached to the variable
   at address [b]. *)

fun find_var_info :: "block \<Rightarrow> (('v globvar) option)" where
  "find_var_info b =
  (case find_def b of Some (Gvar v) \<Rightarrow> Some v | _ \<Rightarrow> None )"

(** [block_is_volatile ge b] returns [true] if [b] points to a global variable
  of volatile type, [false] otherwise. *)

fun block_is_volatile :: "block \<Rightarrow> bool" where
  "block_is_volatile b =
  (case find_var_info b of
    None \<Rightarrow> False
  | Some gv \<Rightarrow> (gvar_volatile gv)
  )"

subsection \<open>Constructing the global environment\<close>

fun add_global :: "(ident * ('f, 'v) globdef) \<Rightarrow> ('f, 'v) Genv_t" where
  "add_global (ident, gdef) =
  Genv_t.make
    (genv_public ge)
    (ITree.set ident (genv_next ge) (genv_symb ge))
    (PTree.set (genv_next ge) gdef (genv_defs ge))
    ((genv_next ge) + 1)"

end

fun add_globals :: "('f, 'v) Genv_t \<Rightarrow> ((ident * ('f, 'v) globdef) list) \<Rightarrow> ('f, 'v) Genv_t" where
  "add_globals ge gl = List.foldl add_global ge gl"

fun empty_genv :: "ident list \<Rightarrow> ('f, 'v) Genv_t" where
  "empty_genv pub = Genv_t.make pub ITree.empty PTree.empty 1"

fun globalenv :: "('f, 'v) program \<Rightarrow> ('f, 'v) Genv_t" where
  "globalenv p = add_globals (empty_genv (prog_public p)) (prog_defs p)"

subsection \<open>Coercing a global environment into a symbol environment\<close>

fun to_senv :: "('f, 'v) Genv_t \<Rightarrow> Senv_t" where
  "to_senv ge =
    Senv_t.make
    (Genv'.find_symbol ge)
    (Genv'.public_symbol ge)
    (Genv'.invert_symbol ge)
    (Genv'.block_is_volatile ge)
    (genv_next ge)"

lemma to_senv_invars:
  assumes "Genv'.invariants ge"
  shows "Senv.invariants (to_senv ge)"
  using assms
  unfolding Genv'.inv_def Senv.inv_def
  by (auto simp add: Senv_t.defs the_equality split: option.split)

section \<open>Construction of the initial memory state\<close>

context
  fixes ge :: "('f, 'v) Genv_t"
begin

fun store_init_data :: "mem \<Rightarrow> block \<Rightarrow> Z \<Rightarrow> init_data \<Rightarrow> (mem option)" where
  "store_init_data m b p ident =
  (case ident of
    Init_int8 n \<Rightarrow> Mem.store Mint8unsigned m b p (Vint n)
  | Init_int16 n \<Rightarrow> Mem.store Mint16unsigned m b p (Vint n)
  | Init_int32 n \<Rightarrow> Mem.store Mint32 m b p (Vint n)
  | Init_int64 n \<Rightarrow> Mem.store Mint64 m b p (Vlong n)
  | Init_float32 n \<Rightarrow> Mem.store Mfloat32 m b p (Vsingle n)
  | Init_float64 n \<Rightarrow> Mem.store Mfloat64 m b p (Vfloat n)
  | Init_addrof symb ofs \<Rightarrow>
      (case Genv'.find_symbol ge symb of
        None \<Rightarrow> None
      | Some b' \<Rightarrow> Mem.store Mptr m b p (Vptr b' ofs)
      )
  | Init_space n \<Rightarrow> Some m
  )"

fun store_init_data_list :: "mem \<Rightarrow> block \<Rightarrow> Z \<Rightarrow> (init_data list) \<Rightarrow> (mem option)" where
  "store_init_data_list m b p idl =
  (case idl of
    [] \<Rightarrow> Some m
  | ident # idl' \<Rightarrow>
      (case store_init_data m b p ident of
        None \<Rightarrow> None
      | Some m' \<Rightarrow> store_init_data_list m' b (p + init_data_size ident) idl'
      )
  )"

fun perm_globvar :: "('v globvar) \<Rightarrow> permission" where
  "perm_globvar gv =
  (if (gvar_volatile gv) then Nonempty
  else if (gvar_readonly gv) then Readable
  else Writable)"

fun alloc_global :: "mem \<Rightarrow> (ident * ('f, 'v) globdef) \<Rightarrow> (mem option)" where
  "alloc_global m idg =
  (case idg of
    (ident, Gfun f) \<Rightarrow>
      let (m1, b) = Mem.alloc m 0 1 in
      Mem.drop_perm m1 b 0 1 Nonempty
  | (ident, Gvar v) \<Rightarrow>
      let init = (gvar_init v) in
      let sz = init_data_list_size init in
      let (m1, b) = Mem.alloc m 0 sz in
      (case store_zeros m1 b 0 sz of
        None \<Rightarrow> None
      | Some m2 \<Rightarrow>
          (case store_init_data_list m2 b 0 init of
            None \<Rightarrow> None
          | Some m3 \<Rightarrow> Mem.drop_perm m3 b 0 sz (perm_globvar v)
          )
      )
  )"

fun alloc_globals :: "mem \<Rightarrow> ((ident * ('f, 'v) globdef) list) \<Rightarrow> (mem option)" where
  "alloc_globals m gl =
  (case gl of
    [] \<Rightarrow> Some m
  | g # gl' \<Rightarrow>
      (case alloc_global m g of
        None \<Rightarrow> None
      | Some m' \<Rightarrow> alloc_globals m' gl'
      )
  )"
end

fun init_mem :: "('f, 'v) program \<Rightarrow> (mem option)" where
  "init_mem p = alloc_globals (Genv'.globalenv p) Mem.empty (prog_defs p)"

lemmas simps = find_symbol.simps symbol_address.simps public_symbol.simps find_def.simps
  find_funct_ptr.simps find_funct.simps invert_symbol.simps find_var_info.simps
  block_is_volatile.simps add_global.simps add_globals.simps empty_genv.simps globalenv.simps
  to_senv.simps store_init_data.simps store_init_data_list.simps perm_globvar.simps
  alloc_global.simps alloc_globals.simps init_mem.simps

section \<open>Check invariants\<close>

context
  notes [simp] = Genv'.inv_def Genv_t.defs
begin

lemma empty_inv: "invariants (empty_genv pub)"
  by auto

lemma add_global_inv:
  "invariants ge \<Longrightarrow> add_global ge (ident, gdef) = ge' \<Longrightarrow> invariants ge'"
proof (goal_cases)
  case 1

  let ?nb = "genv_next ge"

  {
    fix id b

    have "ITree.get id (genv_symb ge') = Some b \<longrightarrow> b < (genv_next ge')"
      apply (cases "id = ident")
      using 1 pos_less_trans
      by auto
  }

  note all = this

  {
    fix b g

    have "PTree.get b (genv_defs ge') = Some g \<longrightarrow> b < (genv_next ge')"
      apply (cases "b = ?nb")
      using 1 pos_less_trans
      by auto
  }

  note all = all this

  {
    fix id1 id2 b

    have "ITree.get id1 (genv_symb ge') = Some b \<longrightarrow> ITree.get id2 (genv_symb ge') = Some b \<longrightarrow> id1 = id2"
      apply (cases "id1 = ident"; cases "id2 = ident")
      using 1 apply auto
      by blast+
  }

  note all = all this

  then show ?case
    by simp
qed

lemma add_globals_inv:
  "invariants ge \<Longrightarrow> add_globals ge gl = ge' \<Longrightarrow> invariants ge'"
  apply (induction gl arbitrary: ge ge')
  apply simp
  using add_global_inv
  by (metis add_global.cases add_globals.simps foldl_Cons)

lemma globalenv_inv:
  "invariants ge \<Longrightarrow> globalenv p = ge' \<Longrightarrow> invariants ge'"
  by (metis empty_inv add_globals_inv globalenv.simps)

end
end

end


section \<open>Binary compositionality theorem\<close>

text \<open>This theory provides the binary version of
the compositionality theorem for BD security.
It corresponds to Theorem 1 from \<^cite>\<open>"cosmedis-SandP2017"\<close>
and to Theorem 5 (the System Compositionality Theorem) from
\<^cite>\<open>"BDsecurity-ITP2021"\<close>.
\<close>

theory Composing_Security
  imports Bounded_Deducibility_Security.BD_Security_TS
begin

(* Preliminaries *)

lemma list2_induct[case_names NilNil Cons1 Cons2]:
assumes NN: "P [] []"
and CN: "\<And>x xs ys. P xs ys \<Longrightarrow> P (x # xs) ys"
and NC: "\<And>xs y ys. P xs ys \<Longrightarrow> P xs (y # ys)"
shows "P xs ys"
proof (induction xs)
  case Nil show ?case using NN NC by (induction ys) auto next
  case (Cons x xs) then show ?case using CN by auto
qed

lemma list22_induct[case_names NilNil ConsNil NilCons ConsCons]:
assumes NN: "P [] []"
and CN: "\<And>x xs. P xs [] \<Longrightarrow> P (x # xs) []"
and NC: "\<And>y ys. P [] ys \<Longrightarrow> P [] (y # ys)"
and CC: "\<And>x xs y ys.
   P xs ys \<Longrightarrow>
   (\<And> ys'. length ys' \<le> Suc (length ys) \<Longrightarrow> P xs ys') \<Longrightarrow>
   (\<And> xs'. length xs' \<le> Suc (length xs) \<Longrightarrow> P xs' ys) \<Longrightarrow>
   P (x # xs) (y # ys)"
shows "P xs ys"
proof (induction rule: measure_induct2[of "\<lambda>xs ys. length xs + length ys", case_names IH])
  case (IH xs ys) with assms show ?case by (cases xs; cases ys) auto
qed

context BD_Security_TS begin

declare O_append[simp]
declare V_append[simp]
declare validFrom_Cons[simp]
declare validFrom_append[simp]

declare list_all_O_map[simp]
declare never_O_Nil[simp]
declare list_all_V_map[simp]
declare never_V_Nil[simp]

end (* BD_Security_NIO_Aut *)

locale Abstract_BD_Security_Comp =
  One: Abstract_BD_Security validSystemTraces1 V1 O1 B1 TT1 +
  Two: Abstract_BD_Security validSystemTraces2 V2 O2 B2 TT2 +
  Comp?: Abstract_BD_Security validSystemTraces V O B TT (* Note: the "Comp" prefix will be optional *)
for
   validSystemTraces1 :: "'traces1 \<Rightarrow> bool"
 and
   V1 :: "'traces1 \<Rightarrow> 'values1" and O1 :: "'traces1 \<Rightarrow> 'observations1"
 and
   TT1 :: "'traces1 \<Rightarrow> bool"
 and
   B1 :: "'values1 \<Rightarrow> 'values1 \<Rightarrow> bool"
 and
(*  *)
   validSystemTraces2 :: "'traces2 \<Rightarrow> bool"
 and
   V2 :: "'traces2 \<Rightarrow> 'values2" and O2 :: "'traces2 \<Rightarrow> 'observations2"
 and
   TT2 :: "'traces2 \<Rightarrow> bool"
 and
   B2 :: "'values2 \<Rightarrow> 'values2 \<Rightarrow> bool"
 and
 (*  *)
   validSystemTraces :: "'traces \<Rightarrow> bool"
 and
   V :: "'traces \<Rightarrow> 'values" and O :: "'traces \<Rightarrow> 'observations"
 and
   TT :: "'traces \<Rightarrow> bool"
 and
   B :: "'values \<Rightarrow> 'values \<Rightarrow> bool"
+
fixes
   comp :: "'traces1 \<Rightarrow> 'traces2 \<Rightarrow> 'traces \<Rightarrow> bool"
 and
   compO :: "'observations1 \<Rightarrow> 'observations2 \<Rightarrow> 'observations \<Rightarrow> bool"
 and
   compV :: "'values1 \<Rightarrow> 'values2 \<Rightarrow> 'values \<Rightarrow> bool"
assumes
validSystemTraces:
"\<And> tr. validSystemTraces tr \<Longrightarrow>
 (\<exists> tr1 tr2. validSystemTraces1 tr1 \<and> validSystemTraces2 tr2 \<and> comp tr1 tr2 tr)"
and
V_comp:
"\<And> tr1 tr2 tr.
   validSystemTraces1 tr1 \<Longrightarrow> validSystemTraces2 tr2 \<Longrightarrow> comp tr1 tr2 tr
   \<Longrightarrow> compV (V1 tr1) (V2 tr2) (V tr)"
and
O_comp:
"\<And> tr1 tr2 tr.
   validSystemTraces1 tr1 \<Longrightarrow> validSystemTraces2 tr2 \<Longrightarrow> comp tr1 tr2 tr
   \<Longrightarrow> compO (O1 tr1) (O2 tr2) (O tr)"
and
TT_comp:
"\<And> tr1 tr2 tr.
   validSystemTraces1 tr1 \<Longrightarrow> validSystemTraces2 tr2 \<Longrightarrow> comp tr1 tr2 tr
   \<Longrightarrow> TT tr \<Longrightarrow> TT1 tr1 \<and> TT2 tr2"
and
B_comp:
"\<And> vl1 vl2 vl vl'.
   compV vl1 vl2 vl \<Longrightarrow> B vl vl'
   \<Longrightarrow> \<exists> vl1' vl2'. compV vl1' vl2' vl' \<and> B1 vl1 vl1' \<and> B2 vl2 vl2'"
and
O_V_comp:
"\<And> tr1 tr2 vl ol.
   validSystemTraces1 tr1 \<Longrightarrow> validSystemTraces2 tr2 \<Longrightarrow>
   compV (V1 tr1) (V2 tr2) vl \<Longrightarrow> compO (O1 tr1) (O2 tr2) ol
   \<Longrightarrow> \<exists> tr. validSystemTraces tr \<and> O tr = ol \<and> V tr = vl"
begin

abbreviation secure where "secure \<equiv> Comp.secure"
abbreviation secure1 where "secure1 \<equiv> One.secure"
abbreviation secure2 where "secure2 \<equiv> Two.secure"

theorem secure1_secure2_secure:
assumes s1: secure1 and s2: secure2
shows secure
unfolding secure_def proof clarify
  fix tr vl vl'
  assume v: "validSystemTraces tr" and T: "TT tr" and B: "B (V tr) vl'"
  then obtain tr1 tr2 where v1: "validSystemTraces1 tr1" and v2: "validSystemTraces2 tr2"
  and tr: "comp tr1 tr2 tr" using validSystemTraces by blast
  have T1: "TT1 tr1" and T2: "TT2 tr2" using TT_comp[OF v1 v2 tr T] by auto
  have Vtr: "compV (V1 tr1) (V2 tr2) (V tr)" using V_comp[OF v1 v2 tr] .
  have Otr: "compO (O1 tr1) (O2 tr2) (O tr)" using O_comp[OF v1 v2 tr] .
  obtain vl1' vl2' where vl': "compV vl1' vl2' vl'" and
  B1: "B1 (V1 tr1) vl1'" and B2: "B2 (V2 tr2) vl2'" using B_comp[OF Vtr B] by auto
  obtain tr1' where v1': "validSystemTraces1 tr1'" and O1: "O1 tr1 = O1 tr1'" and vl1': "vl1' = V1 tr1'"
  using s1 v1 T1 B1 unfolding One.secure_def by fastforce
  obtain tr2' where v2': "validSystemTraces2 tr2'" and O2: "O2 tr2 = O2 tr2'" and vl2': "vl2' = V2 tr2'"
  using s2 v2 T2 B2 unfolding Two.secure_def by fastforce
  obtain tr' where "validSystemTraces tr' \<and> O tr' = O tr \<and> V tr' = vl'"
  using O_V_comp[OF v1' v2' vl'[unfolded vl1' vl2'] Otr[unfolded O1 O2]] by auto
  thus "\<exists>tr'. validSystemTraces tr' \<and> O tr' = O tr \<and> V tr' = vl'" by auto
qed

end (* context BD_Security_Comp *)

type_synonym ('state1,'state2) cstate = "'state1 \<times> 'state2"
datatype ('state1,'trans1,'state2,'trans2) ctrans = Trans1 'state2 'trans1 | Trans2 'state1 'trans2 | CTrans 'trans1 'trans2
datatype ('obs1,'obs2) cobs = Obs1 'obs1 | Obs2 'obs2 | CObs 'obs1 'obs2
datatype ('value1,'value2) "cvalue" = isValue1: Value1 'value1 | isValue2: Value2 'value2 | isCValue: CValue 'value1 'value2

locale BD_Security_TS_Comp =
  One: BD_Security_TS istate1 validTrans1 srcOf1 tgtOf1 \<phi>1 f1 \<gamma>1 g1 T1 B1 +
  Two: BD_Security_TS istate2 validTrans2 srcOf2 tgtOf2 \<phi>2 f2 \<gamma>2 g2 T2 B2
for
   istate1 :: "'state1" and validTrans1 :: "'trans1 \<Rightarrow> bool"
 and
   srcOf1 :: "'trans1 \<Rightarrow> 'state1" and tgtOf1 :: "'trans1 \<Rightarrow> 'state1"
 and
   \<phi>1 :: "'trans1 \<Rightarrow> bool" and f1 :: "'trans1 \<Rightarrow> 'value1"
 and
   \<gamma>1 :: "'trans1 \<Rightarrow> bool" and g1 :: "'trans1 \<Rightarrow> 'obs1"
 and
   T1 :: "'trans1 \<Rightarrow> bool" and B1 :: "'value1 list \<Rightarrow> 'value1 list \<Rightarrow> bool"
 and
 (*  *)
   istate2 :: "'state2" and validTrans2 :: "'trans2 \<Rightarrow> bool"
 and
   srcOf2 :: "'trans2 \<Rightarrow> 'state2" and tgtOf2 :: "'trans2 \<Rightarrow> 'state2"
 and
   \<phi>2 :: "'trans2 \<Rightarrow> bool" and f2 :: "'trans2 \<Rightarrow> 'value2"
 and
   \<gamma>2 :: "'trans2 \<Rightarrow> bool" and g2 :: "'trans2 \<Rightarrow> 'obs2"
 and
   T2 :: "'trans2 \<Rightarrow> bool" and B2 :: "'value2 list \<Rightarrow> 'value2 list \<Rightarrow> bool"
+
fixes (* An identification of the communication transitions and of the synchronization predicate:  *)
  isCom1 :: "'trans1 \<Rightarrow> bool" and isCom2 :: "'trans2 \<Rightarrow> bool"
and
  sync :: "'trans1 \<Rightarrow> 'trans2 \<Rightarrow> bool"
and
  isComV1 :: "'value1 \<Rightarrow> bool" and isComV2 :: "'value2 \<Rightarrow> bool"
and
  syncV :: "'value1 \<Rightarrow> 'value2 \<Rightarrow> bool"
and
  isComO1 :: "'obs1 \<Rightarrow> bool" and isComO2 :: "'obs2 \<Rightarrow> bool"
and
  syncO :: "'obs1 \<Rightarrow> 'obs2 \<Rightarrow> bool"
(*  *)
assumes
  isCom1_isComV1: "\<And> trn1. validTrans1 trn1 \<Longrightarrow> One.reach (srcOf1 trn1) \<Longrightarrow> \<phi>1 trn1 \<Longrightarrow> isCom1 trn1 \<longleftrightarrow> isComV1 (f1 trn1)"
and
  isCom1_isComO1: "\<And> trn1. validTrans1 trn1 \<Longrightarrow> One.reach (srcOf1 trn1) \<Longrightarrow> \<gamma>1 trn1 \<Longrightarrow> isCom1 trn1 \<longleftrightarrow> isComO1 (g1 trn1)"
and
  isCom2_isComV2: "\<And> trn2. validTrans2 trn2 \<Longrightarrow> Two.reach (srcOf2 trn2) \<Longrightarrow> \<phi>2 trn2 \<Longrightarrow> isCom2 trn2 \<longleftrightarrow> isComV2 (f2 trn2)"
and
  isCom2_isComO2: "\<And> trn2. validTrans2 trn2 \<Longrightarrow> Two.reach (srcOf2 trn2) \<Longrightarrow> \<gamma>2 trn2 \<Longrightarrow> isCom2 trn2 \<longleftrightarrow> isComO2 (g2 trn2)"
and
  sync_syncV:
  "\<And> trn1 trn2.
       validTrans1 trn1 \<Longrightarrow> One.reach (srcOf1 trn1) \<Longrightarrow>
       validTrans2 trn2 \<Longrightarrow> Two.reach (srcOf2 trn2) \<Longrightarrow>
       isCom1 trn1 \<Longrightarrow> isCom2 trn2 \<Longrightarrow> \<phi>1 trn1 \<Longrightarrow> \<phi>2 trn2 \<Longrightarrow>
       sync trn1 trn2 \<Longrightarrow> syncV (f1 trn1) (f2 trn2)"
and
  sync_syncO:
  "\<And> trn1 trn2.
       validTrans1 trn1 \<Longrightarrow> One.reach (srcOf1 trn1) \<Longrightarrow>
       validTrans2 trn2 \<Longrightarrow> Two.reach (srcOf2 trn2) \<Longrightarrow>
       isCom1 trn1 \<Longrightarrow> isCom2 trn2 \<Longrightarrow> \<gamma>1 trn1 \<Longrightarrow> \<gamma>2 trn2 \<Longrightarrow>
       sync trn1 trn2 \<Longrightarrow> syncO (g1 trn1) (g2 trn2)"
and
  sync_\<phi>1_\<phi>2:
  "\<And> trn1 trn2.
       validTrans1 trn1 \<Longrightarrow> One.reach (srcOf1 trn1) \<Longrightarrow>
       validTrans2 trn2 \<Longrightarrow> Two.reach (srcOf2 trn2) \<Longrightarrow>
       isCom1 trn1 \<Longrightarrow> isCom2 trn2 \<Longrightarrow>
       sync trn1 trn2 \<Longrightarrow> \<phi>1 trn1 \<longleftrightarrow> \<phi>2 trn2"
and
  sync_\<phi>_\<gamma>:
"\<And> trn1 trn2.
     validTrans1 trn1 \<Longrightarrow> One.reach (srcOf1 trn1) \<Longrightarrow>
     validTrans2 trn2 \<Longrightarrow> Two.reach (srcOf2 trn2) \<Longrightarrow>
     isCom1 trn1 \<Longrightarrow> isCom2 trn2 \<Longrightarrow>
     \<gamma>1 trn1 \<Longrightarrow> \<gamma>2 trn2 \<Longrightarrow>
     syncO (g1 trn1) (g2 trn2) \<Longrightarrow>
     (\<phi>1 trn1 \<Longrightarrow> \<phi>2 trn2 \<Longrightarrow> syncV (f1 trn1) (f2 trn2))
     \<Longrightarrow>
     sync trn1 trn2"
and  (* Every communication is observable (which does not mean that everything in
       a communication is observable!): *)
  isCom1_\<gamma>1: "\<And> trn1. validTrans1 trn1 \<Longrightarrow> One.reach (srcOf1 trn1) \<Longrightarrow> isCom1 trn1 \<Longrightarrow> \<gamma>1 trn1"
and
  isCom2_\<gamma>2: "\<And> trn2. validTrans2 trn2 \<Longrightarrow> Two.reach (srcOf2 trn2) \<Longrightarrow> isCom2 trn2 \<Longrightarrow> \<gamma>2 trn2"
and (* Lack of symmetry here: all the value-producing transitions of the second component
       need to be "communicating" (and hence proceed only synchronously) -- Technically, this tames shuffling...
       This restriction means that the only component that produces secrets is the first component -- the
       second component only receives secrets. *)
  isCom2_V2: "\<And> trn2. validTrans2 trn2 \<Longrightarrow> Two.reach (srcOf2 trn2) \<Longrightarrow> \<phi>2 trn2 \<Longrightarrow> isCom2 trn2"
and (* Added dummy assumption about the locale data not involved in any assumption: *)
  Dummy: "istate1 = istate1 \<and> srcOf1 = srcOf1 \<and> tgtOf1 = tgtOf1 \<and> T1 = T1 \<and> B1 = B1 \<and>
          istate2 = istate2 \<and> srcOf2 = srcOf2 \<and> tgtOf2 = tgtOf2 \<and> T2 = T2 \<and> B2 = B2"
begin

lemma sync_\<gamma>1_\<gamma>2:
 "\<And> trn1 trn2.
      validTrans1 trn1 \<Longrightarrow> One.reach (srcOf1 trn1) \<Longrightarrow>
      validTrans2 trn2 \<Longrightarrow> Two.reach (srcOf2 trn2) \<Longrightarrow>
      isCom1 trn1 \<Longrightarrow> isCom2 trn2 \<Longrightarrow>
      sync trn1 trn2 \<Longrightarrow> \<gamma>1 trn1 \<longleftrightarrow> \<gamma>2 trn2"
using isCom1_\<gamma>1 isCom2_\<gamma>2
by auto

definition icstate where "icstate = (istate1,istate2)"

fun validTrans :: "('state1, 'trans1, 'state2, 'trans2) ctrans \<Rightarrow> bool" where
 "validTrans(Trans1 s2 trn1) = (validTrans1 trn1 \<and> \<not> isCom1 trn1)"
|"validTrans (Trans2 s1 trn2) = (validTrans2 trn2 \<and> \<not> isCom2 trn2)"
|"validTrans (CTrans trn1 trn2) =
   (validTrans1 trn1 \<and> validTrans2 trn2 \<and> isCom1 trn1 \<and> isCom2 trn2 \<and> sync trn1 trn2)"

fun srcOf :: "('state1, 'trans1, 'state2, 'trans2) ctrans \<Rightarrow> 'state1 \<times> 'state2" where
 "srcOf (Trans1 s2 trn1) = (srcOf1 trn1, s2)"
|"srcOf (Trans2 s1 trn2) = (s1, srcOf2 trn2)"
|"srcOf (CTrans trn1 trn2) = (srcOf1 trn1, srcOf2 trn2)"

fun tgtOf :: "('state1, 'trans1, 'state2, 'trans2) ctrans \<Rightarrow> 'state1 \<times> 'state2" where
 "tgtOf (Trans1 s2 trn1) = (tgtOf1 trn1, s2)"
|"tgtOf (Trans2 s1 trn2) = (s1, tgtOf2 trn2)"
|"tgtOf (CTrans trn1 trn2) = (tgtOf1 trn1, tgtOf2 trn2)"

fun \<phi> :: "('state1, 'trans1, 'state2, 'trans2) ctrans \<Rightarrow> bool" where
 "\<phi> (Trans1 s2 trn1) = \<phi>1 trn1"
|"\<phi> (Trans2 s1 trn2) = \<phi>2 trn2"
|"\<phi> (CTrans trn1 trn2) = (\<phi>1 trn1 \<or> \<phi>2 trn2)"

fun f :: "('state1, 'trans1, 'state2, 'trans2) ctrans \<Rightarrow> ('value1,'value2) cvalue" where
 "f (Trans1 s2 trn1) = Value1 (f1 trn1)"
|"f (Trans2 s1 trn2) = Value2 (f2 trn2)"
|"f (CTrans trn1 trn2) = CValue (f1 trn1) (f2 trn2)"

fun \<gamma> :: "('state1, 'trans1, 'state2, 'trans2) ctrans \<Rightarrow> bool" where
 "\<gamma> (Trans1 s2 trn1) = \<gamma>1 trn1"
|"\<gamma> (Trans2 s1 trn2) = \<gamma>2 trn2"
|"\<gamma> (CTrans trn1 trn2) = (\<gamma>1 trn1 \<or> \<gamma>2 trn2)"

fun g :: "('state1, 'trans1, 'state2, 'trans2) ctrans \<Rightarrow> ('obs1,'obs2) cobs" where
 "g (Trans1 s2 trn1) = Obs1 (g1 trn1)"
|"g (Trans2 s1 trn2) = Obs2 (g2 trn2)"
|"g (CTrans trn1 trn2) = CObs (g1 trn1) (g2 trn2)"

fun T :: "('state1, 'trans1, 'state2, 'trans2) ctrans \<Rightarrow> bool"
where
"T (Trans1 s2 trn1) = T1 trn1"
|
"T (Trans2 s1 trn2) = T2 trn2"
|
"T (CTrans trn1 trn2) = (T1 trn1 \<or> T2 trn2)"

inductive compV :: "'value1 list \<Rightarrow> 'value2 list \<Rightarrow> ('value1, 'value2) cvalue list \<Rightarrow> bool"
where
 Nil[intro!,simp]: "compV [] [] []"
|Step1[intro]:
"compV vl1 vl2 vl \<Longrightarrow> \<not> isComV1 v1
 \<Longrightarrow> compV (v1 # vl1) vl2 (Value1 v1 # vl)"
|Step2[intro]:
"compV vl1 vl2 vl \<Longrightarrow> \<not> isComV2 v2
 \<Longrightarrow> compV vl1 (v2 # vl2) (Value2 v2 # vl)"
|Com[intro]:
"compV vl1 vl2 vl \<Longrightarrow> isComV1 v1 \<Longrightarrow> isComV2 v2 \<Longrightarrow> syncV v1 v2
 \<Longrightarrow> compV (v1 # vl1) (v2 # vl2) (CValue v1 v2 # vl)"

lemma compV_cases_V[consumes 3, case_names Nil Step1 Com]:
assumes v: "Two.validFrom s2 tr2"
and c: "compV vl1 (Two.V tr2) vl"
and rs2: "Two.reach s2"
and Nil: "vl1 = [] \<Longrightarrow> Two.V tr2 = [] \<Longrightarrow> vl = [] \<Longrightarrow> P"
and Step1:
"\<And>vll1 vll2 vll v1.
    vl1 = v1 # vll1 \<Longrightarrow>
    Two.V tr2 = vll2 \<Longrightarrow>
    vl = Value1 v1 # vll \<Longrightarrow>
    compV vll1 vll2 vll \<Longrightarrow> \<not> isComV1 v1 \<Longrightarrow> P"
and Com:
"\<And>vll1 vll2 vll v1 v2.
    vl1 = v1 # vll1 \<Longrightarrow>
    Two.V tr2 = v2 # vll2 \<Longrightarrow>
    vl = CValue v1 v2 # vll \<Longrightarrow>
    compV vll1 vll2 vll \<Longrightarrow>
    isComV1 v1 \<Longrightarrow> isComV2 v2 \<Longrightarrow> syncV v1 v2 \<Longrightarrow> P"
shows P
using c proof cases
  case (Step2 vll2 vll1 v2)
  obtain tr2a trn2 tr2b where tr2: "tr2 = tr2a @ trn2 # tr2b" and
  \<phi>2: "\<phi>2 trn2" and f2: "f2 trn2 = v2"
  using \<open>Two.V tr2 = v2 # vll2\<close> by (metis Two.V_eq_Cons append_Cons)
  have v2: "validTrans2 trn2" using tr2 v
  by (metis Nil_is_append_conv Two.validFrom_def Two.valid_ConsE
          Two.valid_append list.distinct(2) self_append_conv2)
  have rs2': "Two.reach (srcOf2 trn2)" using v rs2 unfolding tr2
    by (induction tr2a arbitrary: s2) (auto intro: Two.reach.Step)
  then have False using isCom2_V2[OF v2 rs2' \<phi>2] \<open>\<not> isComV2 v2\<close>
  using \<phi>2 f2 isCom2_isComV2 v2 by blast
  thus ?thesis by simp
qed (insert assms, auto)

inductive compO :: "'obs1 list \<Rightarrow> 'obs2 list \<Rightarrow> ('obs1, 'obs2) cobs list \<Rightarrow> bool"
where
 Nil[intro!,simp]: "compO [] [] []"
|Step1[intro]:
"compO ol1 ol2 ol \<Longrightarrow> \<not> isComO1 o1
 \<Longrightarrow> compO (o1 # ol1) ol2 (Obs1 o1 # ol)"
|Step2[intro]:
"compO ol1 ol2 ol \<Longrightarrow> \<not> isComO2 o2
 \<Longrightarrow> compO ol1 (o2 # ol2) (Obs2 o2 # ol)"
|Com[intro]:
"compO ol1 ol2 ol \<Longrightarrow> isComO1 o1 \<Longrightarrow> isComO2 o2 \<Longrightarrow> syncO o1 o2
 \<Longrightarrow> compO (o1 # ol1) (o2 # ol2) (CObs o1 o2 # ol)"

definition B :: "('value1,'value2) cvalue list \<Rightarrow> ('value1,'value2) cvalue list \<Rightarrow> bool" where
"B vl vl' \<equiv> \<forall> vl1 vl2. compV vl1 vl2 vl \<longrightarrow>
  (\<exists> vl1' vl2'. compV vl1' vl2' vl' \<and> B1 vl1 vl1' \<and> B2 vl2 vl2')"

inductive ccomp ::
"'state1 \<Rightarrow> 'state2 \<Rightarrow> 'trans1 trace \<Rightarrow> 'trans2 trace \<Rightarrow>
 ('state1, 'trans1, 'state2, 'trans2) ctrans trace \<Rightarrow> bool"
where
Nil[simp,intro!]: "ccomp s1 s2 [] [] []"
|
Step1[intro]:
"ccomp (tgtOf1 trn1) s2 tr1 tr2 tr \<Longrightarrow> \<not> isCom1 trn1 \<Longrightarrow>
 ccomp (srcOf1 trn1) s2 (trn1 # tr1) tr2 (Trans1 s2 trn1 # tr)"
|
Step2[intro]:
"ccomp s1 (tgtOf2 trn2) tr1 tr2 tr \<Longrightarrow> \<not> isCom2 trn2 \<Longrightarrow>
 ccomp s1 (srcOf2 trn2) tr1 (trn2 # tr2) (Trans2 s1 trn2 # tr)"
|
Com[intro]:
"ccomp (tgtOf1 trn1) (tgtOf2 trn2) tr1 tr2 tr \<Longrightarrow>
 isCom1 trn1 \<Longrightarrow> isCom2 trn2 \<Longrightarrow> sync trn1 trn2 \<Longrightarrow>
 ccomp (srcOf1 trn1) s2 (trn1 # tr1) (trn2 # tr2) (CTrans trn1 trn2 # tr)"

definition comp where "comp \<equiv> ccomp istate1 istate2"

end (* context BD_Security_TS_Comp *)

sublocale BD_Security_TS_Comp \<subseteq> BD_Security_TS icstate validTrans srcOf tgtOf \<phi> f \<gamma> g T B .

context BD_Security_TS_Comp
begin

lemma valid:
assumes "valid tr" and "srcOf (hd tr) = (s1,s2)"
shows
"\<exists>tr1 tr2.
   One.validFrom s1 tr1 \<and> Two.validFrom s2 tr2 \<and>
   ccomp s1 s2 tr1 tr2 tr"
using assms proof(induction arbitrary: s1 s2)
  case (Singl trn)
  show ?case proof(cases trn)
    case (Trans1 s22 trn1)
    show ?thesis using Singl unfolding Trans1
    by (intro exI[of _ "[trn1]"] exI[of _ "[]"]) auto
  next
    case (Trans2 s11 trn2)
    show ?thesis using Singl unfolding Trans2
    by (intro exI[of _ "[]::'trans1 trace"] exI[of _ "[trn2]"]) auto
  next
    case (CTrans trn1 trn2)
    show ?thesis using Singl unfolding CTrans
    by (intro exI[of _ "[trn1]"] exI[of _ "[trn2]"]) auto
  qed
next
  case (Cons trn tr)
  show ?case proof(cases trn)
    case (Trans1 s22 trn1)
    let ?s1 = "tgtOf1 trn1"
    have s22[simp]: "s22 = s2" using \<open>srcOf (hd (trn # tr)) = (s1, s2)\<close>
    unfolding Trans1 by simp
    hence "tgtOf trn = (?s1, s2)" unfolding Trans1 by simp
    hence "srcOf (hd tr) = (?s1, s2)" using Cons.hyps(2) by auto
    from Cons.IH[OF this] obtain tr1 tr2 where
    1: "One.validFrom ?s1 tr1 \<and> Two.validFrom s2 tr2 \<and>
        ccomp ?s1 s2 tr1 tr2 tr" by auto
    show ?thesis using Cons.prems Cons.hyps 1 unfolding Trans1
    by (intro exI[of _ "trn1 # tr1"] exI[of _ "tr2"], cases tr2) auto
  next
    case (Trans2 s11 trn2)
    let ?s2 = "tgtOf2 trn2"
    have s11[simp]: "s11 = s1" using \<open>srcOf (hd (trn # tr)) = (s1, s2)\<close>
    unfolding Trans2 by simp
    hence "tgtOf trn = (s1, ?s2)" unfolding Trans2 by simp
    hence "srcOf (hd tr) = (s1, ?s2)" using Cons.hyps(2) by auto
    from Cons.IH[OF this] obtain tr1 tr2 where
    1: "One.validFrom s1 tr1 \<and> Two.validFrom ?s2 tr2 \<and>
        ccomp s1 ?s2 tr1 tr2 tr" by auto
    show ?thesis using Cons.prems Cons.hyps 1 unfolding Trans2
    by (intro exI[of _ "tr1"] exI[of _ "trn2 # tr2"], cases tr1) auto
  next
    case (CTrans trn1 trn2)
    let ?s1 = "tgtOf1 trn1" let ?s2 = "tgtOf2 trn2"
    have "tgtOf trn = (?s1, ?s2)" unfolding CTrans by simp
    hence "srcOf (hd tr) = (?s1, ?s2)" using Cons.hyps(2) by auto
    from Cons.IH[OF this] obtain tr1 tr2 where
    1: "One.validFrom ?s1 tr1 \<and> Two.validFrom ?s2 tr2 \<and>
        ccomp ?s1 ?s2 tr1 tr2 tr" by auto
    show ?thesis using Cons.prems Cons.hyps 1 unfolding CTrans
    by (intro exI[of _ "trn1 # tr1"] exI[of _ "trn2 # tr2"], cases tr2) auto
  qed
qed

lemma validFrom:
assumes "validFrom icstate tr"
shows "\<exists>tr1 tr2. One.validFrom istate1 tr1 \<and> Two.validFrom istate2 tr2 \<and> comp tr1 tr2 tr"
using assms valid unfolding comp_def icstate_def validFrom_def by(cases tr) fastforce+

lemma reach_reach12:
assumes "reach s"
obtains "One.reach (fst s)" and "Two.reach (snd s)"
using assms proof (induction rule: reach.induct)
  case Istate
    then show thesis using One.reach.Istate Two.reach.Istate unfolding icstate_def by auto
next
  case (Step s trn s')
    then show thesis
      using One.reach.Step[of "fst s" _ "fst s'"] Two.reach.Step[of "snd s" _ "snd s'"]
      by (auto elim: validTrans.elims)
qed

lemma compV_ccomp:
assumes v: "One.validFrom s1 tr1" "Two.validFrom s2 tr2"
and c: "ccomp s1 s2 tr1 tr2 tr"
and rs1: "One.reach s1" and rs2: "Two.reach s2"
shows "compV (One.V tr1) (Two.V tr2) (V tr)"
using c v rs1 rs2 proof(induction)
  case (Step1 trn1 s2 tr1 tr2 tr)
  moreover then have "One.reach (tgtOf1 trn1)"
    using One.reach.Step[of "srcOf1 trn1" trn1 "tgtOf1 trn1"] by auto
  ultimately show ?case by (cases "\<phi>1 trn1") (auto simp: isCom1_isComV1)
next
  case (Step2 s1 trn2 tr1 tr2 tr)
  moreover then have "Two.reach (tgtOf2 trn2)"
    using Two.reach.Step[of "srcOf2 trn2" trn2 "tgtOf2 trn2"] by auto
  ultimately show ?case by (cases "\<phi>2 trn2") (auto simp: isCom2_isComV2)
next
  case (Com trn1 trn2 tr1 tr2 tr s2)
  moreover then have "One.reach (tgtOf1 trn1)" "Two.reach (tgtOf2 trn2)"
    using One.reach.Step[of "srcOf1 trn1" trn1 "tgtOf1 trn1"]
          Two.reach.Step[of "srcOf2 trn2" trn2 "tgtOf2 trn2"]
    by auto
  ultimately show ?case
    by (cases "\<phi>1 trn1"; cases "\<phi>2 trn2"; simp add: isCom1_isComV1 isCom2_isComV2)
       (use sync_\<phi>1_\<phi>2 sync_syncV Com in auto)
qed auto

lemma compV:
assumes "One.validFrom istate1 tr1" and "Two.validFrom istate2 tr2"
and "comp tr1 tr2 tr"
shows "compV (One.V tr1) (Two.V tr2) (V tr)"
using compV_ccomp assms One.reach.Istate Two.reach.Istate unfolding comp_def by auto

lemma compO_ccomp:
assumes v: "One.validFrom s1 tr1" "Two.validFrom s2 tr2"
and c: "ccomp s1 s2 tr1 tr2 tr"
and rs1: "One.reach s1" and rs2: "Two.reach s2"
shows "compO (One.O tr1) (Two.O tr2) (O tr)"
using c v rs1 rs2 proof(induction)
  case (Step1 trn1 s2 tr1 tr2 tr)
  moreover then have "One.reach (tgtOf1 trn1)"
    using One.reach.Step[of "srcOf1 trn1" trn1 "tgtOf1 trn1"] by auto
  ultimately show ?case by (cases "\<gamma>1 trn1") (auto simp: isCom1_isComO1)
next
  case (Step2 s1 trn2 tr1 tr2 tr)
  moreover then have "Two.reach (tgtOf2 trn2)"
    using Two.reach.Step[of "srcOf2 trn2" trn2 "tgtOf2 trn2"] by auto
  ultimately show ?case by (cases "\<gamma>2 trn2") (auto simp: isCom2_isComO2)
next
  case (Com trn1 trn2 tr1 tr2 tr s2)
  moreover then have "One.reach (tgtOf1 trn1)" "Two.reach (tgtOf2 trn2)"
    using One.reach.Step[of "srcOf1 trn1" trn1 "tgtOf1 trn1"]
          Two.reach.Step[of "srcOf2 trn2" trn2 "tgtOf2 trn2"]
    by auto
  ultimately show ?case
    by (cases "\<gamma>1 trn1"; cases "\<gamma>2 trn2"; simp add: isCom1_isComO1 isCom2_isComO2)
       (use sync_\<gamma>1_\<gamma>2 sync_syncO Com in auto)
qed auto

lemma compO:
assumes "One.validFrom istate1 tr1" and "Two.validFrom istate2 tr2"
and "comp tr1 tr2 tr"
shows "compO (One.O tr1) (Two.O tr2) (O tr)"
using compO_ccomp assms One.reach.Istate Two.reach.Istate unfolding comp_def by auto

lemma T_ccomp:
assumes v: "One.validFrom s1 tr1" "Two.validFrom s2 tr2"
and c: "ccomp s1 s2 tr1 tr2 tr" and n: "never T tr"
shows "never T1 tr1 \<and> never T2 tr2"
using c n v by (induction) auto

lemma T:
assumes "One.validFrom istate1 tr1" and "Two.validFrom istate2 tr2"
and "comp tr1 tr2 tr" and "never T tr"
shows "never T1 tr1 \<and> never T2 tr2"
using T_ccomp assms unfolding comp_def by auto

lemma B:
assumes "compV vl1 vl2 vl" and "B vl vl'"
shows "\<exists>vl1' vl2'. compV vl1' vl2' vl' \<and> B1 vl1 vl1' \<and> B2 vl2 vl2'"
using assms unfolding B_def by auto

lemma pullback_O_V_aux:
assumes "One.validFrom s1 tr1" "Two.validFrom s2 tr2"
and "One.reach s1" "Two.reach s2"
and "compV (One.V tr1) (Two.V tr2) vl"
and "compO (One.O tr1) (Two.O tr2) obl"
shows "\<exists>tr. validFrom (s1,s2) tr \<and> O tr = obl \<and> V tr = vl"
using assms proof(induction tr1 tr2 arbitrary: s1 s2 vl obl rule: list22_induct)
  case (NilNil s1 s2 vl obl)
  thus ?case by (intro exI[of _ "[]"]) (auto elim: compV.cases compO.cases)
next
  case (ConsNil trn1 tr1 s1 s2 vl obl)
  let ?s1 = "tgtOf1 trn1"
  have trn1: "validTrans1 trn1" and tr1: "One.validFrom ?s1 tr1"
  and s1: "srcOf1 trn1 = s1" "One.reach s1" and rs2: "Two.reach s2" using ConsNil.prems by auto
  then have rs1': "One.reach ?s1" by (intro One.reach.Step[of s1 trn1 ?s1]) auto
  show ?case proof(cases "isCom1 trn1")
    case True note com1 = True
    hence \<gamma>1: "\<gamma>1 trn1" using trn1 isCom1_\<gamma>1 s1 by auto
    hence "isComO1 (g1 trn1)" using \<gamma>1 com1 s1 isCom1_isComO1 trn1 by blast
    hence False using \<open>compO (One.O (trn1 # tr1)) (Two.O []) obl\<close>
    using \<gamma>1 by (auto elim: compO.cases)
    thus ?thesis by simp
  next
    case False note com1 = False
    show ?thesis proof(cases "\<phi>1 trn1")
      case True note \<phi>1 = True
      hence comv1: "\<not> isComV1 (f1 trn1)" using \<phi>1 com1 isCom1_isComV1 trn1 s1 by blast
      with \<open>compV (One.V (trn1 # tr1)) (Two.V []) vl\<close> \<phi>1
      obtain vll where vl: "vl = Value1 (f1 trn1) # vll"
      and vll: "compV (One.V tr1) (Two.V []) vll" by (auto elim: compV.cases)
      show ?thesis proof(cases "\<gamma>1 trn1")
        case True note \<gamma>1 = True
        hence "\<not> isComO1 (g1 trn1)" using \<gamma>1 com1 isCom1_isComO1 trn1 s1 by blast
        with \<open>compO (One.O (trn1 # tr1)) (Two.O []) obl\<close> \<gamma>1
        obtain obll where obl: "obl = Obs1 (g1 trn1) # obll"
        and obll: "compO (One.O tr1) (Two.O []) obll" by (auto elim: compO.cases)
        from ConsNil.IH[OF tr1 _ rs1' rs2 vll obll] obtain trr where
        "validFrom (?s1, s2) trr" and "O trr = obll \<and> V trr = vll" by auto
        thus ?thesis
        unfolding obl vl using trn1 com1 s1 \<phi>1 \<gamma>1
        by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
      next
        case False note \<gamma>1 = False
        note obl = \<open>compO (One.O (trn1 # tr1)) (Two.O []) obl\<close>
        from ConsNil.IH[OF tr1 _ rs1' rs2 vll] obl \<gamma>1 obtain trr where
        "validFrom (?s1, s2) trr" and "O trr = obl \<and> V trr = vll" by auto
        thus ?thesis
        unfolding obl vl using trn1 com1 s1 \<phi>1 \<gamma>1
        by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
      qed
    next
      case False note \<phi>1 = False
      note vl = \<open>compV (One.V (trn1 # tr1)) (Two.V []) vl\<close>
      show ?thesis proof(cases "\<gamma>1 trn1")
        case True note \<gamma>1 = True
        hence "\<not> isComO1 (g1 trn1)" using \<gamma>1 com1 isCom1_isComO1 trn1 s1 by blast
        with \<open>compO (One.O (trn1 # tr1)) (Two.O []) obl\<close> \<gamma>1
        obtain obll where obl: "obl = Obs1 (g1 trn1) # obll"
        and obll: "compO (One.O tr1) (Two.O []) obll" by (auto elim: compO.cases)
        from ConsNil.IH[OF tr1 _ rs1' rs2 _ obll] vl \<phi>1 obtain trr where
        "validFrom (?s1, s2) trr" and "O trr = obll \<and> V trr = vl" by auto
        thus ?thesis
        unfolding obl vl using trn1 com1 s1 \<phi>1 \<gamma>1
        by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
      next
        case False note \<gamma>1 = False
        note obl = \<open>compO (One.O (trn1 # tr1)) (Two.O []) obl\<close>
        from ConsNil.IH[OF tr1 _ rs1' rs2 _] vl \<phi>1 obl \<gamma>1 obtain trr where
        "validFrom (?s1, s2) trr" and "O trr = obl \<and> V trr = vl" by fastforce
        thus ?thesis
        unfolding obl vl using trn1 com1 s1 \<phi>1 \<gamma>1
        by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
      qed
    qed
  qed
next
  case (NilCons trn2 tr2 s1 s2 vl obl)
  let ?s2 = "tgtOf2 trn2"
  have trn2: "validTrans2 trn2" and tr2: "Two.validFrom ?s2 tr2"
  and s2: "srcOf2 trn2 = s2" "Two.reach s2" and rs1: "One.reach s1" using NilCons.prems by auto
  then have rs2': "Two.reach ?s2" by (intro Two.reach.Step[of s2 trn2 ?s2]) auto
  show ?case proof(cases "isCom2 trn2")
    case True note com2 = True
    hence \<gamma>2: "\<gamma>2 trn2" using trn2 isCom2_\<gamma>2 s2 by auto
    hence "isComO2 (g2 trn2)" using \<gamma>2 com2 isCom2_isComO2 trn2 s2 by blast
    hence False using \<open>compO (One.O []) (Two.O (trn2 # tr2)) obl\<close>
    using \<gamma>2 by (auto elim: compO.cases)
    thus ?thesis by simp
  next
    case False note com2 = False
    show ?thesis proof(cases "\<phi>2 trn2")
      case True note \<phi>2 = True
      hence comv1: "\<not> isComV2 (f2 trn2)" using \<phi>2 com2 isCom2_isComV2 trn2 s2 by blast
      with \<open>compV (One.V []) (Two.V (trn2 # tr2)) vl\<close> \<phi>2
      obtain vll where vl: "vl = Value2 (f2 trn2) # vll"
      and vll: "compV (One.V []) (Two.V tr2) vll" by (auto elim: compV.cases)
      show ?thesis proof(cases "\<gamma>2 trn2")
        case True note \<gamma>2 = True
        hence "\<not> isComO2 (g2 trn2)" using \<gamma>2 com2 isCom2_isComO2 trn2 s2 by blast
        with \<open>compO (One.O []) (Two.O (trn2 # tr2)) obl\<close> \<gamma>2
        obtain obll where obl: "obl = Obs2 (g2 trn2) # obll"
        and obll: "compO (One.O []) (Two.O tr2) obll" by (auto elim: compO.cases)
        from NilCons.IH[OF _ tr2 rs1 rs2' vll obll] obtain trr where
        "validFrom (s1, ?s2) trr" and "O trr = obll \<and> V trr = vll" by auto
        thus ?thesis
        unfolding obl vl using trn2 com2 s2 \<phi>2 \<gamma>2
        by (intro exI[of _ "Trans2 s1 trn2 # trr"]) auto
      next
        case False note \<gamma>2 = False
        note obl = \<open>compO (One.O []) (Two.O (trn2 # tr2)) obl\<close>
        from NilCons.IH[OF _ tr2 rs1 rs2' vll] obl \<gamma>2 obtain trr where
        "validFrom (s1, ?s2) trr" and "O trr = obl \<and> V trr = vll" by auto
        thus ?thesis
        unfolding obl vl using trn2 com2 s2 \<phi>2 \<gamma>2
        by (intro exI[of _ "Trans2 s1 trn2 # trr"]) auto
      qed
    next
      case False note \<phi>2 = False
      note vl = \<open>compV (One.V []) (Two.V (trn2 # tr2)) vl\<close>
      show ?thesis proof(cases "\<gamma>2 trn2")
        case True note \<gamma>2 = True
        hence "\<not> isComO2 (g2 trn2)" using \<gamma>2 com2 isCom2_isComO2 trn2 s2 by blast
        with \<open>compO (One.O []) (Two.O (trn2 # tr2)) obl\<close> \<gamma>2
        obtain obll where obl: "obl = Obs2 (g2 trn2) # obll"
        and obll: "compO (One.O []) (Two.O tr2) obll" by (auto elim: compO.cases)
        from NilCons.IH[OF _ tr2 rs1 rs2' _ obll] vl \<phi>2 obtain trr where
        "validFrom (s1, ?s2) trr" and "O trr = obll \<and> V trr = vl" by auto
        thus ?thesis
        unfolding obl vl using trn2 com2 s2 \<phi>2 \<gamma>2
        by (intro exI[of _ "Trans2 s1 trn2 # trr"]) auto
      next
        case False note \<gamma>2 = False
        note obl = \<open>compO (One.O []) (Two.O (trn2 # tr2)) obl\<close>
        from NilCons.IH[OF _ tr2 rs1 rs2' _] vl \<phi>2 obl \<gamma>2 obtain trr where
        "validFrom (s1, ?s2) trr" and "O trr = obl \<and> V trr = vl" by fastforce
        thus ?thesis
        unfolding obl vl using trn2 com2 s2 \<phi>2 \<gamma>2
        by (intro exI[of _ "Trans2 s1 trn2 # trr"]) auto
      qed
    qed
  qed
next
  case (ConsCons trn1 tr1 trn2 tr2 s1 s2 vl obl)
  let ?s1 = "tgtOf1 trn1"  let ?s2 = "tgtOf2 trn2"
  let ?tr1 = "trn1 # tr1" let ?tr2 = "trn2 # tr2"
  have trn1: "validTrans1 trn1" and tr1: "One.validFrom ?s1 tr1" and s1: "srcOf1 trn1 = s1" "One.reach s1"
  and trn2: "validTrans2 trn2" and tr2: "Two.validFrom ?s2 tr2" and s2: "srcOf2 trn2 = s2" "Two.reach s2"
  using ConsCons.prems by auto
  then have rs1': "One.reach ?s1" and rs2': "Two.reach ?s2"
    using One.reach.Step[of s1 trn1 ?s1] Two.reach.Step[of s2 trn2 ?s2] by auto
  note vl = \<open>compV (One.V ?tr1) (Two.V ?tr2) vl\<close>
  note obl = \<open>compO (One.O ?tr1) (Two.O ?tr2) obl\<close>
  note trr1 = \<open>One.validFrom s1 ?tr1\<close> note trr2 = \<open>Two.validFrom s2 ?tr2\<close>
  show ?case proof(cases "\<phi>1 trn1 \<or> \<gamma>1 trn1")
    case False note \<phi>\<gamma>1 = False
    hence com1: "\<not> isCom1 trn1" using isCom1_\<gamma>1 trn1 s1 by blast
    from ConsCons.IH(2)[of ?tr2, OF _ tr1 trr2 rs1' s2(2)] vl obl \<phi>\<gamma>1
    obtain trr where "validFrom (?s1, s2) trr" and "O trr = obl \<and> V trr = vl"
    by fastforce
    thus ?thesis
    unfolding obl vl using trn1 com1 s1 \<phi>\<gamma>1
    by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
  next
    case True note \<phi>\<gamma>1 = True
    show ?thesis proof(cases "\<phi>2 trn2 \<or> \<gamma>2 trn2")
      case False note \<phi>\<gamma>2 = False
      hence com2: "\<not> isCom2 trn2" using isCom2_\<gamma>2 trn2 s2 by blast
      from ConsCons.IH(3)[of ?tr1, OF _ trr1 tr2 s1(2) rs2'] vl obl \<phi>\<gamma>2
      obtain trr where "validFrom (s1, ?s2) trr" and "O trr = obl \<and> V trr = vl"
      by fastforce
      thus ?thesis
      unfolding obl vl using trn2 com2 s2 \<phi>\<gamma>2
      by (intro exI[of _ "Trans2 s1 trn2 # trr"]) auto
    next
      case True note \<phi>\<gamma>2 = True
      show ?thesis using obl ConsCons proof cases
        case Nil hence \<gamma>12: "\<not> \<gamma>1 trn1 \<and> \<not> \<gamma>2 trn2" by auto
        hence obl: "compO (One.O tr1) (Two.O ?tr2) obl"
                   "compO (One.O tr1) (Two.O tr2) obl"
        using obl by auto
        have \<phi>12: "\<phi>1 trn1 \<and> \<phi>2 trn2" using \<phi>\<gamma>1 \<phi>\<gamma>2 \<gamma>12 by auto
        show ?thesis using trr2 vl s2(2) proof(cases rule: compV_cases_V)
          case Nil hence False using \<phi>12 by auto
          thus ?thesis by simp
        next
          case (Step1 vll1 vll2 vll v1)
          hence f1: "f1 trn1 = v1" and vll1: "One.V tr1 = vll1" using \<phi>12 by auto
          hence vll: "compV (One.V tr1) (Two.V ?tr2) vll" using Step1 by auto
          from ConsCons.IH(2)[OF _ tr1 trr2 rs1' s2(2) vll obl(1)]
          obtain trr where "validFrom (?s1, s2) trr" and "O trr = obl \<and> V trr = vll"
          by auto
          thus ?thesis using trn1 Step1 f1 \<phi>12 \<gamma>12 isCom2_V2 isCom2_\<gamma>2 trn2 s2
          by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
        next
          case (Com vll1 vll2 vll v1 v2)
          hence f1: "f1 trn1 = v1" and vll1: "One.V tr1 = vll1"
          and f2: "f2 trn2 = v2" and vll2: "Two.V tr2 = vll2"
          using \<phi>12 by auto
          hence vll: "compV (One.V tr1) (Two.V tr2) vll" using Com by auto
          from ConsCons.IH(1)[OF tr1 tr2 rs1' rs2' vll obl(2)]
          obtain trr where "validFrom (?s1, ?s2) trr" and "O trr = obl \<and> V trr = vll"
          by auto
          thus ?thesis using trn1 Step1 f1 \<phi>12 \<gamma>12 isCom2_V2 isCom2_\<gamma>2 trn2 s2
          by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
        qed
      next
        case (Step1 obll1 obll ob1) note Step1O = Step1
        show ?thesis proof(cases "\<gamma>1 trn1")
          case True note \<gamma>1 = True
          hence g1: "g1 trn1 = ob1" and "obll1 = One.O tr1" using Step1 by auto
          hence obll: "compO (One.O tr1) (Two.O ?tr2) obll" using Step1 by auto
          have com1: "\<not> isCom1 trn1" using Step1O \<gamma>1 g1 isCom1_isComO1 trn1 s1 by blast
          show ?thesis using trr2 vl s2(2) proof(cases rule: compV_cases_V)
            case Nil
            hence \<phi>12: "\<not> \<phi>1 trn1 \<and> \<not> \<phi>2 trn2" by auto
            hence vl: "compV (One.V tr1) (Two.V ?tr2) vl" using vl by auto
            from ConsCons.IH(2)[OF _ tr1 trr2 rs1' s2(2) vl obll]
            obtain trr where "validFrom (?s1, s2) trr" and "O trr = obll \<and> V trr = vl"
            by auto
            thus ?thesis using trn1 Step1O g1 \<phi>12 \<gamma>1 trn1 s1 isCom1_isComO1
            by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
          next
            case (Step1 vll1 vll2 vll v1) note Step1V = Step1
            show ?thesis proof(cases "\<phi>1 trn1")
              case False note \<phi>1 = False
              hence vl: "compV (One.V tr1) (Two.V ?tr2) vl" using vl by auto
              from ConsCons.IH(2)[OF _ tr1 trr2 rs1' s2(2) vl obll]
              obtain trr where "validFrom (?s1, s2) trr" and "O trr = obll \<and> V trr = vl"
              by auto
              thus ?thesis using trn1 Step1O g1 \<phi>1 \<gamma>1 trn1 s1 isCom1_isComO1
              by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
            next
              case True note \<phi>1 = True
              hence f1: "f1 trn1 = v1" and "vll1 = One.V tr1" using Step1V by auto
              hence vll: "compV (One.V tr1) (Two.V ?tr2) vll" using Step1V com1 by auto
              from ConsCons.IH(2)[OF _ tr1 trr2 rs1' s2(2) vll obll]
              obtain trr where "validFrom (?s1, s2) trr" and "O trr = obll \<and> V trr = vll"
              by auto
              thus ?thesis using trn1 Step1O Step1V f1 \<phi>1 g1 \<phi>1 \<gamma>1 trn1 s1 isCom1_isComO1
              by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
            qed
          next
            case (Com vll1 vll2 vll v1 v2)
            hence \<phi>1: "\<not> \<phi>1 trn1" using com1 isCom1_isComV1[OF trn1] s1 by auto
            hence vl: "compV (One.V tr1) (Two.V ?tr2) vl" using vl by auto
            from ConsCons.IH(2)[OF _ tr1 trr2 rs1' s2(2) vl obll]
            obtain trr where "validFrom (?s1, s2) trr" and "O trr = obll \<and> V trr = vl"
            by auto
            thus ?thesis using trn1 Step1O g1 \<phi>1 \<gamma>1 trn1 s1 isCom1_isComO1
            by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
          qed
        next
          case False note \<gamma>1 = False
          hence obl: "compO (One.O tr1) (Two.O ?tr2) obl" using obl by simp
          hence \<phi>1: "\<phi>1 trn1" and com1: "\<not> isCom1 trn1" using \<phi>\<gamma>1 \<gamma>1 isCom1_\<gamma>1 trn1 s1 by auto
          show ?thesis using trr2 vl s2(2) proof(cases rule: compV_cases_V)
            case Nil hence False using \<phi>1 by auto
            thus ?thesis by simp
          next
            case Com hence False using \<phi>1 com1 trn1 using isCom1_isComV1 s1 by auto
            thus ?thesis by simp
          next
            case (Step1 vll1 vll2 vll v1) note Step1V = Step1
            hence f1: "f1 trn1 = v1" and "vll1 = One.V tr1" using \<phi>1 by auto
            hence vll: "compV (One.V tr1) (Two.V ?tr2) vll" using Step1V com1 by auto
            from ConsCons.IH(2)[OF _ tr1 trr2 rs1' s2(2) vll obl]
            obtain trr where "validFrom (?s1, s2) trr" and "O trr = obl \<and> V trr = vll"
            by auto
            thus ?thesis using trn1 Step1O Step1V f1 \<phi>1 \<phi>1 \<gamma>1 trn1 s1 isCom1_isComV1
            by(intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
          qed
        qed
      next
        case (Step2 obl2 obll ob2) note Step2O = Step2
        hence com2: "\<not> isCom2 trn2" using isCom2_\<gamma>2[OF trn2] isCom2_isComO2[OF trn2] s2 by auto
        hence \<phi>2: "\<not> \<phi>2 trn2" using isCom2_V2[OF trn2] s2 by auto
        hence vl: "compV (One.V ?tr1) (Two.V tr2) vl" using vl by simp
        have \<gamma>2: "\<gamma>2 trn2" using \<phi>\<gamma>2 \<phi>2 by simp
        hence g2: "g2 trn2 = ob2" and "obl2 = Two.O tr2" using Step2 by auto
        hence obll: "compO (One.O ?tr1) (Two.O tr2) obll" using Step2 by auto
        from ConsCons.IH(3)[OF _ trr1 tr2 s1(2) rs2' vl obll]
        obtain trr where "validFrom (s1, ?s2) trr" and "O trr = obll \<and> V trr = vl" by auto
        thus ?thesis using trn1 Step2O g2 \<phi>2 \<gamma>2 trn2 s2 isCom2_isComO2
        by (intro exI[of _ "Trans2 s1 trn2 # trr"]) auto
      next
        case (Com obll1 obll2 obll ob1 ob2) note ComO = Com
        show ?thesis
        proof(cases "\<gamma>1 trn1")
          case True note \<gamma>1 = True
          hence com1: "isCom1 trn1" using isCom1_isComO1[OF trn1] s1 ComO by auto
          show ?thesis proof(cases "\<gamma>2 trn2")
            case True note \<gamma>2 = True
            hence com2: "isCom2 trn2" using isCom2_isComO2[OF trn2] s2 ComO by auto
            have obll: "compO (One.O tr1) (Two.O tr2) obll" using obl ComO \<gamma>1 \<gamma>2 by auto
            have g1: "g1 trn1 = ob1" and "obll1 = One.O tr1" and
                 g2: "g2 trn2 = ob2" and "obll2 = Two.O tr2"
            using \<gamma>1 \<gamma>2 ComO by auto
            have rs1: "One.reach (srcOf1 trn1)" and rs2: "Two.reach (srcOf2 trn2)"
              using s1 s2 by auto
            have sync: "sync trn1 trn2" proof(rule sync_\<phi>_\<gamma>[OF trn1 rs1 trn2 rs2 com1 com2])
              show "syncO (g1 trn1) (g2 trn2)" using Com \<gamma>1 \<gamma>2 by auto
            next
              assume \<phi>12: "\<phi>1 trn1" "\<phi>2 trn2"
              hence comV: "isComV1 (f1 trn1) \<and> isComV2 (f2 trn2)"
              using com1 com2 isCom1_isComV1 isCom2_isComV2 trn1 trn2 rs1 rs2 by blast
              show "syncV (f1 trn1) (f2 trn2)" using vl \<phi>12 comV by cases auto
            qed(insert \<gamma>1 \<gamma>2, auto)
            show ?thesis
            proof(cases "\<phi>1 trn1")
              case True
              hence \<phi>12: "\<phi>1 trn1 \<and> \<phi>2 trn2" using sync_\<phi>1_\<phi>2[OF trn1 rs1 trn2 rs2 com1 com2 sync] by simp
              show ?thesis using trr2 vl s2(2) proof(cases rule: compV_cases_V)
                case Nil hence False using \<phi>12 by auto
                thus ?thesis by simp
              next
                case Step1 hence False using \<phi>12 com1 isCom1_isComV1[OF trn1] s1 by auto
                thus ?thesis by simp
              next
                case (Com vll1 vll2 vll v1 v2) note ComV = Com
                hence f1: "f1 trn1 = v1" and "vll1 = One.V tr1" and
                      f2: "f2 trn2 = v2" and "vll2 = Two.V tr2"
                using \<phi>12 by auto
                hence vll: "compV (One.V tr1) (Two.V tr2) vll" using ComV com1 com2 \<phi>12 by auto
                from ConsCons.IH(1)[OF tr1 tr2 rs1' rs2' vll obll]
                obtain trr where "validFrom (?s1, ?s2) trr" and "O trr = obll \<and> V trr = vll"
                by auto
                thus ?thesis using trn1 trn2 ComO ComV f1 f2 \<phi>12 g1 g2 \<gamma>1 \<gamma>2 com1 com2 sync s1 s2
                by (intro exI[of _ "CTrans trn1 trn2 # trr"]) auto
              qed
            next
              case False
              hence \<phi>12: "\<not> \<phi>1 trn1 \<and> \<not> \<phi>2 trn2" using sync_\<phi>1_\<phi>2[OF trn1 rs1 trn2 rs2 com1 com2 sync] by simp
              hence vl: "compV (One.V tr1) (Two.V tr2) vl" using vl by simp
              from ConsCons.IH(1)[OF tr1 tr2 rs1' rs2' vl obll]
              obtain trr where "validFrom (?s1, ?s2) trr" and "O trr = obll \<and> V trr = vl" by auto
              thus ?thesis using trn1 trn2 ComO \<phi>12 g1 g2 \<gamma>1 \<gamma>2 com1 com2 sync s1 s2
              by (intro exI[of _ "CTrans trn1 trn2 # trr"]) auto
            qed
          next
            case False
            hence \<phi>2: "\<phi>2 trn2" and com2: "\<not> isCom2 trn2" using \<phi>\<gamma>2 isCom2_\<gamma>2 trn2 s2 by auto
            have False using trr2 vl s2(2) \<phi>2 com2 isCom2_V2[OF trn2] s2 by (cases rule: compV_cases_V) auto
            thus ?thesis by simp
          qed
        next
          case False note \<gamma>1 = False
          hence obl: "compO (One.O tr1) (Two.O ?tr2) obl" using obl by simp
          have \<phi>1: "\<phi>1 trn1" and com1: "\<not> isCom1 trn1" using \<gamma>1 \<phi>\<gamma>1 isCom1_\<gamma>1 trn1 s1 by auto
          show ?thesis using trr2 vl s2(2) proof(cases rule: compV_cases_V)
            case Nil hence False using \<phi>1 by auto
            thus ?thesis by simp
          next
            case Com hence False using com1 \<phi>1 isCom1_isComV1[OF trn1] s1 by auto
            thus ?thesis by simp
          next
            case (Step1 vll1 vll2 vll v1) note Step1V = Step1
            hence f1: "f1 trn1 = v1" and "vll1 = One.V tr1" using \<phi>1 by auto
            hence vll: "compV (One.V tr1) (Two.V ?tr2) vll" using Step1V com1 by auto
            from ConsCons.IH(2)[OF _ tr1 trr2 rs1' s2(2) vll obl]
            obtain trr where "validFrom (?s1, s2) trr" and "O trr = obl \<and> V trr = vll"
            by auto
            thus ?thesis using trn1 Step1V f1 \<phi>1 \<gamma>1 trn1 s1 isCom1_isComO1 com1
            by (intro exI[of _ "Trans1 s2 trn1 # trr"]) auto
          qed
        qed
      qed
    qed
  qed
qed

lemma pullback_O_V:
assumes "One.validFrom istate1 tr1" and "Two.validFrom istate2 tr2"
and "compV (One.V tr1) (Two.V tr2) vl"
and "compO (One.O tr1) (Two.O tr2) ol"
shows "\<exists>tr. validFrom icstate tr \<and> O tr = ol \<and> V tr = vl"
using assms pullback_O_V_aux One.reach.Istate Two.reach.Istate unfolding icstate_def by auto

end (* context BD_Security_TS_Comp *)

sublocale BD_Security_TS_Comp \<subseteq> K? : Abstract_BD_Security_Comp where
  validSystemTraces1 = "One.validFrom istate1" and V1 = One.V and O1 = One.O
   and TT1 = "never T1" and B1 = B1 and
  validSystemTraces2 = "Two.validFrom istate2" and V2 = Two.V and O2 = Two.O
   and TT2 = "never T2" and B2 = B2 and
  validSystemTraces = "validFrom icstate" and V = V and O = O
   and TT = "never T" and B = B and
   comp = comp and compO = compO and compV = compV
  apply standard
  subgoal using validFrom by fastforce
  subgoal using compV by fastforce
  subgoal using compO by fastforce
  subgoal using T by fastforce
  subgoal using B by fastforce
  subgoal using pullback_O_V by fastforce
  done

context BD_Security_TS_Comp begin

(* Just contemplating the theorem provided as a
consequence of the sublocale inclusion: *)
theorem "secure1 \<Longrightarrow> secure2 \<Longrightarrow> secure"
using secure1_secure2_secure .

end (* context BD_Security_TS_Comp *)

end


theory MP_AbstractLock
  imports Main AbstractLock_Proof_Rules OpSem_Proof_Rules
begin
datatype PC =
  L1
| L2
| L3
| L4
| L5

consts t1 :: T
consts t2 :: T
consts d1 :: L
consts d2 :: L
consts l :: L

definition "thrdsvars \<equiv>  t1 \<noteq> t2 \<and> d1 \<noteq> d2"

record prog_state =
  pc :: "T \<Rightarrow> PC"
  state :: surrey_state
  lstate :: lib_state
  r :: V
  r2 :: V
  loc1 :: bool
  loc2 :: bool
  rel1 :: bool
  rel2 :: bool
  ver1 :: V
  ver2 :: V

definition
  "update_pc t nv pcf \<equiv> pcf (t := nv)"

definition prog :: "T \<Rightarrow> prog_state \<Rightarrow> prog_state  \<Rightarrow> bool " where
"prog t s s' \<equiv>
(
if t = t1
then
if (pc s) t = L1
then
     [(state s) (lstate s) t LOCKACQ(l) (state s') (lstate s') (loc1 s') (ver1 s')]
     \<and> (loc1 s' \<longrightarrow> pc s' = update_pc t L2 (pc s))
     \<and> (\<not> loc1 s' \<longrightarrow> pc s' = pc s)
     \<and> (r s' = r s)
     \<and> (r2 s' = r2 s)
     \<and> (rel1 s' = rel1 s)
     \<and> (rel2 s' = rel2 s)
     \<and> (loc2 s' = loc2 s)
     \<and> (ver2 s' = ver2 s)
else
if (pc s) t = L2
then
    (state s) [d1 := 5]\<^sub>t (state s')
    \<and> pc s' = update_pc t L3 (pc s)
    \<and> (lstate s = lstate s')
    \<and> (r s = r s')
    \<and> (rel1 s' = rel1 s)
    \<and> (rel2 s' = rel2 s)
    \<and> (loc2 s' = loc2 s)
    \<and> (loc1 s' = loc1 s)
    \<and> (ver2 s' = ver2 s)
else
if (pc s) t = L3
then
    (state s) [d2 := 5]\<^sub>t (state s')
    \<and> pc s' = update_pc t L4 (pc s)
    \<and> (lstate s = lstate s')
    \<and> (r s = r s')
    \<and> (rel1 s' = rel1 s)
    \<and> (rel2 s' = rel2 s)
    \<and> (loc2 s' = loc2 s)
    \<and> (loc1 s' = loc1 s)
    \<and> (ver2 s' = ver2 s)
else
if (pc s) t = L4
then
    [(state s) (lstate s) t LOCKREL(l) (lstate s') (state s')]
     \<and> pc s' =  update_pc t L5 (pc s)
     \<and> (state s = state s')
     \<and> (r s = r s')
     \<and> (loc1 s' = loc1 s)
     \<and> (loc2 s' = loc2 s)
     \<and> (rel2 s' = rel2 s)
     \<and> (rel1 s' = True)
     \<and> (ver2 s' = ver2 s)
else
False
else

if t = t2
then
if (pc s) t = L1
then
     [(state s) (lstate s) t LOCKACQ(l) (state s') (lstate s') (loc2 s')  (ver2 s')]
     \<and> (loc2 s' = True \<longrightarrow> pc s' = update_pc t L2 (pc s))
     \<and> (loc2 s' = False \<longrightarrow> pc s' = pc s) \<and> (r s = r s') \<and> (r2 s = r2 s')
     \<and> (rel1 s' = rel1 s)  \<and> (rel2 s' = rel2 s) \<and> (loc1 s = loc1 s')
else
if (pc s) t = L2
then
    (state s) [r s' \<leftarrow> d1]\<^sub>t (state s')
    \<and> pc s' = update_pc t L3 (pc s)
    \<and> (lstate s = lstate s')
    \<and> (rel1 s' = rel1 s)  \<and> (rel2 s' = rel2 s)
    \<and> (loc2 s = loc2 s') \<and>  (loc1 s = loc1 s')
    \<and> (ver2 s' = ver2 s)
else
if (pc s) t = L3
then
    (state s) [r2 s' \<leftarrow> d2]\<^sub>t (state s')
    \<and> pc s' = update_pc t L4 (pc s)
    \<and> (lstate s = lstate s')
    \<and> (rel1 s' = rel1 s)  \<and> (rel2 s' = rel2 s)
    \<and> (loc2 s = loc2 s') \<and>  (loc1 s = loc1 s') \<and> (r s = r s')
    \<and> (ver2 s' = ver2 s)
else
if (pc s) t = L4
then
    [(state s) (lstate s) t LOCKREL(l) (lstate s') (state s')]
     \<and> pc s' =   update_pc t L5 (pc s) \<and>
    (state s = state s') \<and> (r s = r s')
    \<and> (loc2 s' = loc2 s) \<and> (loc1 s' = loc1 s)
    \<and> (rel1 s' = rel1 s)  \<and> (rel2 s' = True) \<and> (r s = r s')
    \<and> (ver2 s' = ver2 s)
else
False
else
False
)
"

definition "mutex s \<equiv> (rel1 s \<longrightarrow> loc1 s) \<and>
                      (rel2 s \<longrightarrow> loc2 s) \<and>
                      \<not> ((loc1 s \<and> \<not>rel1 s) \<and> (loc2 s \<and> \<not>rel2 s))"

(* need to add that ver2 s = 0 \<or> ver2 s = 2 *)
definition "global_inv s \<equiv> (wfs (state s)) \<and> (lib_wfs (lstate s) (state s)) \<and> thrdsvars \<and> mutex s "

definition "init_state s \<equiv> thrdsvars \<and> (wfs (state s)) \<and>  (lib_wfs (lstate s) (state s)) \<and> ([lib(l) =\<^sub>t1 0] (lstate s)) \<and> ([lib(l) =\<^sub>t2 0] (lstate s))
                  \<and> ([d1 =\<^sub>t1 0] (state s)) \<and> ([d1 =\<^sub>t2 0] (state s))
                  \<and> ([d2 =\<^sub>t1 0] (state s)) \<and> ([d2 =\<^sub>t2 0] (state s))
                  \<and> (loc1 s = False) \<and> (loc2 s = False)
                  \<and> (rel1 s = False) \<and> (rel2 s = False) \<and> (r s = 0)
                  \<and>  cvd[lib(l), 0] (lstate s)"

definition "prog_inv t p s \<equiv>
  global_inv s \<and>
  (if t = t1
  then
    let t' = t2 in
    (case p of
          L1 \<Rightarrow>  (\<not>rel1 s)  \<and> (\<not>loc1 s)
                \<and> ([d1 =\<^sub>t 0] (state s))
                \<and> ([d2 =\<^sub>t 0] (state s))
                \<and> (\<not>loc2 s \<longrightarrow> ([lib(l) =\<^sub>t 0] (lstate s)) \<and> (\<not>[lib(l) \<approx>\<^sub>t' 2] (lstate s)))
                \<and> (\<not>loc2 s \<longrightarrow> ([lib(l) =\<^sub>t' 0] (lstate s)) \<and> (cvd[lib(l), 0] (lstate s)))
                \<and> (loc2 s \<and> \<not>rel2 s \<longrightarrow> cvd[lib(l), 1] (lstate s))
                \<and> (loc2 s \<and> rel2 s \<longrightarrow> (cvv[lib(l), 0] (lstate s)))
        | L2 \<Rightarrow>  (loc1 s) \<and> (\<not>rel1 s)
                \<and> ([d1 =\<^sub>t 0] (state s))
                \<and> ([d2 =\<^sub>t 0] (state s))
                \<and> (\<not>loc2 s \<longrightarrow>  \<not>[lib(l) \<approx>\<^sub>t' 2] (lstate s))
                \<and> cvv[lib(l),0] (lstate s)
        | L3 \<Rightarrow>  (loc1 s) \<and> (\<not>rel1 s)
                \<and> ([d1 =\<^sub>t 5] (state s))
                \<and> ([d2 =\<^sub>t 0] (state s))
                \<and> (\<not>loc2 s \<longrightarrow>  \<not>[lib(l) \<approx>\<^sub>t' 2] (lstate s))
                \<and> cvv[lib(l),0] (lstate s)
        | L4 \<Rightarrow>  (loc1 s) \<and> (\<not>rel1 s)
                \<and> (\<not>loc2 s \<longrightarrow>  \<not>[lib(l) \<approx>\<^sub>t' 2] (lstate s))
                \<and> ([d1 =\<^sub>t 5] (state s))
                \<and> ([d2 =\<^sub>t 5] (state s))
                \<and> cvv[lib(l),0] (lstate s)
        | L5 \<Rightarrow> (rel1 s) \<and> (loc1 s)
    )
  else
    if t = t2 then
      let t' = t1 in
      (case p of
          L1 \<Rightarrow>  \<not>rel2 s \<and> \<not>loc2 s
                \<and> (
                    (rel1 s \<and> ([lib(l) = 2]\<lparr>d1 =\<^sub>t 5\<rparr> (lstate s) (state s))
                     \<and> ([lib(l) = 2]\<lparr>d2 =\<^sub>t 5\<rparr> (lstate s) (state s)))
                  \<or> (  ([lib(l) =\<^sub>t 0] (lstate s)) \<and> [d1 =\<^sub>t 0] (state s)
                     \<and> [d2 =\<^sub>t 0] (state s))
                  \<or> (loc1 s \<and> \<not> rel1 s))
                \<and> (\<not>loc1 s \<longrightarrow> ([lib(l) =\<^sub>t' 0] (lstate s)) \<and> (cvd[lib(l), 0] (lstate s)))
                \<and> (loc1 s \<and> \<not>rel1 s \<longrightarrow> cvd[lib(l), 1] (lstate s))
                \<and> (rel1 s \<longrightarrow> cvv[lib(l), 0] (lstate s))
        | L2 \<Rightarrow>   \<not>rel2 s \<and> loc2 s  \<and> (cvv[lib(l), 0] (lstate s))
                \<and> (ver2 s = 2 \<longrightarrow> [d1 =\<^sub>t 5] (state s) \<and> [d2 =\<^sub>t 5] (state s))
                \<and> (ver2 s = 0 \<longrightarrow> [d1 =\<^sub>t 0] (state s) \<and> [d2 =\<^sub>t 0] (state s))
        | L3 \<Rightarrow>  \<not>rel2 s \<and> loc2 s  \<and> (cvv[lib(l), 0] (lstate s))
                \<and> (ver2 s = 2 \<longrightarrow> r s = 5 \<and> [d2 =\<^sub>t 5] (state s))
                \<and> (ver2 s = 0 \<longrightarrow> r s = 0 \<and> [d2 =\<^sub>t 0] (state s))
        | L4 \<Rightarrow>  loc2 s \<and> \<not>rel2 s \<and> (cvv[lib(l), 0] (lstate s))
                \<and> (ver2 s = 2 \<longrightarrow> r s = 5 \<and> r2 s = 5)
                \<and> (ver2 s = 0 \<longrightarrow> r s = 0 \<and> r2 s = 0)
        | L5 \<Rightarrow> loc2 s \<and> rel2 s
      )

  else
    False)
"

(* r s = 5 \<and> r1 s = 5 \<or> r s = 0 \<and> r s = 0 *)

lemmas autos = mutex_def global_inv_def update_pc_def prog_def prog_inv_def thrdsvars_def

lemma init_inv:
  assumes  "init_state s"
    and "global_inv s"
      and "t\<in>{t1,t2}"
    shows "prog_inv t L1 s"
  using assms
  apply (simp add: autos  init_state_def)
  apply(intro conjI impI; elim disjE)
  using lib_d_obs_not_p_obs zero_neq_numeral apply blast
  apply blast
  apply blast
  by blast

lemma global_inv_init:
  assumes "init_state s"
  shows "global_inv s"
  using assms
  apply (simp add: init_state_def autos)
  done

lemma t1_local:
  assumes "prog_inv t1 ((pc s) t1) s"
      and "prog t1 s s'"
    shows "prog_inv t1 ((pc s') t1) s'"
  using assms
  apply(case_tac "pc s t1", simp_all)
     apply(case_tac "pc s' t1", simp_all)
            apply (simp_all add: prog_inv_def prog_def global_inv_def thrdsvars_def update_pc_def)
         apply(unfold mutex_def, elim conjE)
  apply (smt PC.distinct(1) fun_upd_same lock_acquire_def lock_acquire_step_def prod.sel(1) prod.sel(2))
  apply(intro conjI)
  using lock_acqure_wfs_pres apply blast
  using lock_acqure_lib_wfs_pres apply blast
  using lock_acquire_cvd_odd_false apply force
            apply blast+
  using lock_acquire_cvd_odd_false apply force
            apply (metis PC.distinct(1))

           apply (metis (full_types) PC.distinct(1) lock_acqure_successfulib_client_pres_d_obs)
  apply (metis (full_types) PC.distinct(1) lock_acqure_successfulib_client_pres_d_obs)

      apply (smt PC.distinct(1) add_le_same_cancel2 lock_acquire_successful_p_obs of_nat_0 of_nat_le_0_iff)
         defer
  apply (metis PC.distinct(4) PC.simps(10) fun_upd_same)
  apply (metis PC.distinct(11) PC.distinct(5) fun_upd_same)
  apply (metis PC.distinct(13) PC.distinct(7) fun_upd_same)
  apply (metis d_obs_WrX_other d_obs_WrX_set step_pres_lib_wfs wfs_preserved)
  apply (meson d_obs_WrX_other d_obs_WrX_set step_pres_lib_wfs wfs_preserved)
   apply (metis lock_release_lib_wfs_pres)
  apply(elim conjE)
  apply simp
  apply(cases "loc2 s", simp_all)
  apply(cases "rel2 s", simp_all)
  defer
    apply (metis PC.distinct(1) even_Suc even_zero lock_acquire_cvd_odd_false)
   apply(cases "loc1 s'", simp_all)
  apply(elim conjE)
  using cvd_cvv_val apply blast
  using cvv_lock_acquire_pres by blast

lemma t2_local:
  assumes "prog_inv t2 ((pc s) t2) s"
      and "prog t2 s s'"
    shows "prog_inv t2 ((pc s') t2) s'"
  using assms
  apply(case_tac "t1 \<noteq> t2")
  apply(case_tac "pc s t2", simp_all)
     apply(case_tac "pc s' t2", simp_all)
            apply (simp_all add: prog_inv_def prog_def global_inv_def thrdsvars_def update_pc_def)
        apply(unfold mutex_def)
          apply simp_all
  apply (smt PC.distinct(1) fun_upd_same lock_acquire_def lock_acquire_step_def prod.sel(1) prod.sel(2))
       apply(elim conjE, intro conjI)
  using lock_acqure_wfs_pres apply blast
  using lock_acqure_lib_wfs_pres apply blast
         apply (metis One_nat_def lock_acquire_cvd_odd_false odd_one)
      apply auto[1]
          apply (elim disjE conjE)
  using cvv_lock_acquire_pres apply blast
  apply (metis (full_types) PC.distinct(1) cvd_cvv_val cvv_lock_acquire_pres even_Suc even_zero lock_acquire_cvd_odd_false)
  apply (metis PC.distinct(1) even_Suc even_zero lock_acquire_cvd_odd_false)
         apply (intro conjI impI)
         apply (metis (full_types) PC.distinct(1) lock_acquire_cvd_odd_false lock_acquire_successful_c_o_s lock_acquire_successful_rv numeral_1_eq_Suc_0 numeral_One odd_one zero_neq_numeral)
  apply (metis (full_types) PC.distinct(1) lock_acquire_cvd_odd_false lock_acquire_successful_c_o_s lock_acquire_successful_rv numeral_1_eq_Suc_0 numeral_One odd_one zero_neq_numeral)
        defer
  apply (metis PC.distinct(3) PC.distinct(9) fun_upd_same)
  apply (metis PC.distinct(11) PC.distinct(5) fun_upd_same)
  apply (metis PC.distinct(13) PC.distinct(7) fun_upd_same)
     apply (metis d_obs_RdX_other d_obs_read_value step_pres_lib_wfs wfs_preserved)
  using d_obs_read_value step_pres_lib_wfs wfs_preserved apply blast
   apply (metis lock_release_lib_wfs_pres)
  apply (elim disjE)
    defer
    apply (metis (full_types) PC.distinct(1) lock_acqure_successfulib_client_pres_d_obs)
  apply (metis PC.distinct(1) even_Suc even_zero lock_acquire_cvd_odd_false)
  by (metis (full_types)  PC.distinct(1) cvv_val)

lemma t1_global:
  assumes "prog_inv t1 ((pc s) t1) s"
      and "prog_inv t2 ((pc s) t2) s"
      and "prog t2 s s'"
    shows "prog_inv t1 ((pc s') t1) s'"
  using assms
  apply(case_tac "pc s t1")
     apply(case_tac "pc s t2")
  apply(case_tac "pc s' t1")
           apply(simp_all add: prog_inv_def prog_def global_inv_def mutex_def thrdsvars_def update_pc_def)
          apply(intro conjI)
  using lock_acqure_wfs_pres apply blast
  using lock_acqure_lib_wfs_pres apply blast
  apply (metis (full_types) lock_acquire_successfulib_diff_t_d_p_obs_pres lock_acquire_unsuccessful_diff_t_d_p_obs_pres)

  apply (metis (full_types) lock_acquire_successfulib_diff_t_d_p_obs_pres lock_acquire_unsuccessful_diff_t_d_p_obs_pres)

  apply (metis (full_types) OpSem.null_def lock_acquire_successful_not_p_obs_pres lock_acquire_unsuccessful_d_obs_pres)

  apply (metis (full_types) lock_acquire_unsuccessful_d_obs_pres lock_acquire_unsuccessfulib_cvd_pres)

  apply (elim conjE, intro impI, simp)

  using lock_acquire_successfulib_cvd apply fastforce
   apply fastforce
            apply auto[3]
  using dobs_RdX_pres step_pres_lib_wfs wfs_preserved apply blast
  using dobs_RdX_pres step_pres_lib_wfs wfs_preserved apply blast
  apply(intro conjI)
  apply (metis lock_release_lib_wfs_pres)
  apply(case_tac "pc s t2"; simp)
      apply(case_tac "pc s' t1"; simp)
      apply (metis cvv_release)
  apply(case_tac "pc s t2"; simp)
      apply(case_tac "pc s' t1"; simp)
  using lock_acquire_cvd_odd_false apply fastforce
  apply (smt One_nat_def lock_acquire_cvd_odd_false lock_acquire_def lock_acquire_step_def odd_one prod.sel(1) prod.sel(2))
  apply (metis PC.distinct(9) even_Suc even_zero lock_acquire_cvd_odd_false)
  apply (metis One_nat_def PC.distinct(11) lock_acquire_cvd_odd_false odd_one)
  apply (metis PC.distinct(14) autos(3) fun_upd_def)
  apply(case_tac "pc s t2"; simp)
  apply(case_tac "pc s' t1"; simp)
  apply (metis)
  apply (metis)
  apply (smt One_nat_def lock_acquire_cvd_odd_false lock_acquire_def lock_acquire_step_def odd_one prod.sel(1) prod.sel(2))
  apply (metis)
  apply (metis)
  apply(case_tac "pc s t2"; simp)
  apply(case_tac "pc s' t1"; simp)
  apply (metis)
  apply (metis)
  apply (metis)
  apply (smt One_nat_def lock_acquire_cvd_odd_false lock_acquire_def lock_acquire_step_def odd_one prod.sel(1) prod.sel(2))
  apply (metis)
  apply blast+
  apply(case_tac "pc s t2"; simp)
       apply(case_tac "pc s' t1"; simp)
  using lock_acquire_cvd_odd_false apply fastforce
  apply (metis PC.simps(10) autos(3) fun_upd_def)
  apply (smt One_nat_def lock_acquire_cvd_odd_false lock_acquire_def lock_acquire_step_def odd_one prod.sel(1) prod.sel(2))
  apply (metis PC.distinct(15) autos(3) fun_upd_def)
  apply (metis PC.distinct(17) autos(3) fun_upd_other)
  apply (metis)
  apply (metis)
  apply (metis)
  apply(case_tac "pc s t2"; simp)
       apply(case_tac "pc s' t1"; simp)
  apply (metis PC.distinct(5) autos(3) fun_upd_apply)
  apply (metis PC.distinct(11) autos(3) fun_upd_other)
  apply (metis PC.distinct(15) autos(3) fun_upd_apply)
  apply (smt One_nat_def lock_acquire_cvd_odd_false lock_acquire_def lock_acquire_step_def odd_one prod.sel(1) prod.sel(2))
  apply (metis PC.simps(20) autos(3) fun_upd_apply)
  apply blast+
  apply(case_tac "pc s t2"; simp)
       apply(case_tac "pc s' t1"; simp)
  apply (metis PC.distinct(7) autos(3) fun_upd_other)
  apply (metis PC.distinct(13) autos(3) fun_upd_other)
  apply (metis PC.distinct(17) autos(3) fun_upd_other)
  apply (metis PC.distinct(19) autos(3) fun_upd_other)
  using lock_acqure_lib_wfs_pres lock_acqure_wfs_pres apply blast
  apply (smt PC.simps(25) autos(3) fun_upd_other step_pres_lib_wfs wfs_preserved)
    apply (smt PC.simps(25) autos(3) fun_upd_other step_pres_lib_wfs wfs_preserved)
  apply (smt PC.simps(25) autos(3) fun_upd_other lock_release_lib_wfs_pres)
  done

lemma t2_global:
  assumes "prog_inv t1 ((pc s) t1) s"
      and "prog_inv t2 ((pc s) t2) s"
      and "prog t1 s s'"
    shows "prog_inv t2 ((pc s') t2) s'"
  using assms
  apply(subgoal_tac "t1 \<noteq> t2")
  apply(simp add: prog_def)
  apply(case_tac "pc s t1", simp_all)
    apply(case_tac "pc s t2", simp_all)
       apply(case_tac "pc s' t2", simp_all)
           apply(simp_all add: prog_inv_def global_inv_def thrdsvars_def update_pc_def)
           apply(unfold  mutex_def, elim conjE)
           apply simp
  apply(intro conjI)
  using lock_acqure_wfs_pres apply blast
  using lock_acqure_lib_wfs_pres apply blast
               apply (metis (full_types)  lock_acquire_unsuccessful_d_obs_pres lock_acquire_unsuccessful_diff_t_d_p_obs_pres)

  apply (metis (full_types) lock_acquire_unsuccessful_d_obs_pres lock_acquire_unsuccessfulib_cvd_pres)
  using lock_acquire_successfulib_cvd apply force
 apply force
           apply auto[1]

          apply auto[1]

  apply auto[1]

  apply (intro conjI)
  apply (smt One_nat_def PC.simps(22) global_inv_def lock_acquire_cvd_odd_false lock_acquire_unsuccessful_diff_t_d_p_obs_pres lock_acqure_lib_wfs_pres lock_acqure_wfs_pres mutex_def odd_one thrdsvars_def)
  apply (smt One_nat_def PC.simps(23) global_inv_def lock_acquire_cvd_odd_false lock_acquire_unsuccessful_diff_t_d_p_obs_pres lock_acqure_lib_wfs_pres lock_acqure_wfs_pres mutex_def odd_one thrdsvars_def)
  apply (smt One_nat_def PC.simps(24) global_inv_def lock_acquire_cvd_odd_false lock_acqure_lib_wfs_pres lock_acqure_wfs_pres mutex_def odd_one thrdsvars_def)
  apply (smt PC.simps(25) fun_upd_other global_inv_def lock_acqure_lib_wfs_pres lock_acqure_wfs_pres mutex_def thrdsvars_def)
     defer defer defer
  apply (case_tac "pc s t1"; simp add: thrdsvars_def prog_def global_inv_def)
    apply (case_tac "pc s t2"; simp)
         apply (intro conjI)
  using lock_acqure_wfs_pres apply blast

  using lock_acqure_lib_wfs_pres apply blast
  apply (metis lock_acquire_cvd_odd_false numeral_1_eq_Suc_0 numeral_One odd_one)
    apply (case_tac "pc s' t2"; simp)
  apply auto[1]
  apply (metis PC.distinct(11) fun_upd_apply)
  apply (metis PC.distinct(15) fun_upd_other)
  using cvv_lock_acquire_pres apply blast
  apply auto[1]
         apply (intro conjI)
  using lock_acqure_wfs_pres apply blast
  using lock_acqure_lib_wfs_pres apply blast
  apply blast+
  apply auto[1]
    apply (case_tac "pc s t2"; simp)
  using step_pres_lib_wfs wfs_preserved apply blast
  using step_pres_lib_wfs wfs_preserved apply blast
    apply (case_tac "pc s t2"; simp)
  using step_pres_lib_wfs wfs_preserved apply blast
  using step_pres_lib_wfs wfs_preserved apply blast
  apply (case_tac "pc s t2"; simp)
  using step_pres_lib_wfs wfs_preserved apply blast
  apply (case_tac "pc s t2"; simp)
  using step_pres_lib_wfs wfs_preserved apply blast+
  apply (case_tac "pc s t2"; simp)
  apply (metis cvv_release lock_rel_c_obs_intro lock_release_lib_wfs_pres)
        apply blast+
  using lock_release_lib_wfs_pres apply force
  apply (metis lock_acquire_cvd_odd_false numeral_1_eq_Suc_0 numeral_One odd_one)
  apply (case_tac "pc s' t2"; simp)
       apply auto[1]
  apply (smt cvv_lock_acquire_pres lock_acquire_successfulib_diff_t_d_p_obs_pres lock_acquire_unsuccessful_diff_t_d_p_obs_pres)
  apply (metis PC.distinct(9) fun_upd_apply)
  apply (metis PC.distinct(11) fun_upd_other)
  apply auto[1]
  by (smt PC.simps(23) cvv_lock_acquire_pres lock_acquire_cvd_odd_false lock_acquire_unsuccessful_diff_t_d_p_obs_pres lock_acqure_lib_wfs_pres lock_acqure_wfs_pres numeral_1_eq_Suc_0 numeral_One odd_one)

end


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

  Project: IsaNet

  Author:  Tobias Klenze, ETH Zurich <tobias.klenze@inf.ethz.ch>
  Version: JCSPaper.1.0
  Isabelle Version: Isabelle2021-1

  Copyright (c) 2022 Tobias Klenze
  Licence: Mozilla Public License 2.0 (MPL) / BSD-3-Clause (dual license)

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

section \<open>ICING variant\<close>
text\<open>We abstract and simplify from the protocol ICING in several ways. First, we only consider
Proofs of Consent (PoC), not Proofs of Provenance (PoP). Our framework does not support proving the
path validation properties that PoPs provide, and it also currently does not support XOR, and
dynamically changing hop fields.
Thus, instead of embedding $A_i \oplus PoP_{0,1}$, we embed $A_i$ directly.
We also remove the payload from the Hash that is included in each packet.

We offer three versions of this protocol:
\begin{itemize}
\item @{text "ICING"}, which contains our best effort at modeling the protocol as accurately as
possible.
\item @{text "ICING_variant"}, in which we strip down the protocol to what is required to obtain the
security guarantees and remove unnecessary fields.
\item @{text "ICING_variant2"}, in which we furthermore simplify the protocol. The key of the MAC in
this protocol is only the key of the AS, as opposed to a key derived specifically for this hop field.
In order to prove that this scheme is secure, we have to assume that ASes only occur once on an
authorized path, since otherwise the MAC for two different hop fields (by the same AS) would be the
same, and the AS could not distinguish the hop fields based on the MAC.
\end{itemize}\<close>
theory ICING_variant2
  imports
    "../Parametrized_Dataplane_3_undirected"
begin

locale icing_defs = network_assums_undirect _ _ _ auth_seg0
  for auth_seg0 :: "(msgterm \<times> ahi list) set"
+ assumes auth_seg0_no_dups:
  "\<lbrakk>(ainfo, hfs) \<in> auth_seg0; hf \<in> set hfs; hf' \<in> set hfs; ASID hf' = ASID hf\<rbrakk> \<Longrightarrow> hf' = hf"
begin

(******************************************************************************)
subsection \<open>Hop validation check and extract functions\<close>
(******************************************************************************)
type_synonym ICING_HF = "(unit, unit) HF"

text\<open>The term @{term "sntag"} simply is the AS key. We use it in the computation of @{term "hf_valid"}.\<close>

fun sntag :: "ahi \<Rightarrow> msgterm" where
  "sntag \<lparr>UpIF = upif, DownIF = downif, ASID = asid\<rparr> = macKey asid"

text\<open>The predicate @{term "hf_valid"} is given to the concrete parametrized model as a parameter.
It ensures the authenticity of the hop authenticator in the hop field. The predicate takes an
expiration timestamp (in this model always a numeric value, hence the matching on
@{term "Num PoC_i_expire"}), the entire segment and the hop field to be validated.\<close>
fun hf_valid :: "msgterm \<Rightarrow> msgterm
    \<Rightarrow> ICING_HF list
    \<Rightarrow> ICING_HF
    \<Rightarrow> bool" where
  "hf_valid (Num PoC_i_expire) uinfo hfs \<lparr>AHI = ahi, UHI = uhi, HVF = x\<rparr> \<longleftrightarrow> uhi = () \<and>
    x = Mac[sntag ahi] (L ((Num PoC_i_expire)#(map (hf2term o AHI) hfs))) \<and> uinfo = \<epsilon>"
| "hf_valid _ _ _ _ = False"

text\<open>We can extract the entire path (past and future) from the hvf field.\<close>
fun extr :: "msgterm \<Rightarrow> ahi list" where
  "extr (Mac[_] (L hfs))
 = map term2hf (tl hfs)"
| "extr _ = []"

text\<open>Extract the authenticated info field from a hop validation field.\<close>
fun extr_ainfo :: "msgterm \<Rightarrow> msgterm" where
  "extr_ainfo (Mac[_] (L (Num ts # xs))) = Num ts"
| "extr_ainfo _ = \<epsilon>"

abbreviation term_ainfo :: "msgterm \<Rightarrow> msgterm" where
  "term_ainfo \<equiv> id"

text\<open>An authenticated info field is always a number (corresponding to a timestamp). The
     unauthenticated info field is set to the empty term @{term "\<epsilon>"}.\<close>
definition auth_restrict where
  "auth_restrict ainfo uinfo l \<equiv> (\<exists>ts. ainfo = Num ts) \<and> (uinfo = \<epsilon>)"

text\<open>When observing a hop field, an attacker learns the HVF. UHI is empty and the AHI only contains
public information that are not terms.\<close>
fun terms_hf :: "ICING_HF \<Rightarrow> msgterm set" where
  "terms_hf hf = {HVF hf}"

abbreviation terms_uinfo :: "msgterm \<Rightarrow> msgterm set" where
  "terms_uinfo x \<equiv> {x}"

abbreviation no_oracle where "no_oracle \<equiv> (\<lambda> _ _. True)"

text\<open>We now define useful properties of the above definition.\<close>
lemma hf_valid_invert:
  "hf_valid tsn uinfo hfs hf \<longleftrightarrow>
(\<exists> ts ahi. tsn = Num ts \<and> ahi = AHI hf \<and>
UHI hf = () \<and>
HVF hf = Mac[sntag ahi] (L ((Num ts)#(map (hf2term o AHI) hfs))) \<and> uinfo = \<epsilon>)"
  apply(cases hf) by(auto elim!: hf_valid.elims)

lemma hf_valid_auth_restrict[dest]: "hf_valid ainfo uinfo hfs hf \<Longrightarrow> auth_restrict ainfo uinfo l"
  by(auto simp add: hf_valid_invert auth_restrict_def)

lemma auth_restrict_ainfo[dest]: "auth_restrict ainfo uinfo l \<Longrightarrow> \<exists>ts. ainfo = Num ts"
  by(auto simp add: auth_restrict_def)
lemma auth_restrict_uinfo[dest]: "auth_restrict ainfo uinfo l \<Longrightarrow> uinfo = \<epsilon>"
  by(auto simp add: auth_restrict_def)

(******************************************************************************)
subsection\<open>Definitions and properties of the added intruder knowledge\<close>
(******************************************************************************)
text\<open>Here we define a @{text "ik_add"} and @{text "ik_oracle"} as being empty, as these features are
not used in this instance model.\<close>
print_locale dataplane_3_undirected_defs
sublocale dataplane_3_undirected_defs _ _ _ auth_seg0 hf_valid auth_restrict extr extr_ainfo
  term_ainfo terms_hf terms_uinfo no_oracle
  by unfold_locales

declare parts_singleton[dest]

abbreviation ik_add :: "msgterm set" where "ik_add \<equiv> {}"

abbreviation ik_oracle :: "msgterm set" where "ik_oracle \<equiv> {}"

lemma uinfo_empty[dest]: "(ainfo, hfs) \<in> auth_seg2 uinfo \<Longrightarrow> uinfo = \<epsilon>"
  by(auto simp add: auth_seg2_def auth_restrict_def)

(******************************************************************************)
subsection\<open>Properties of the intruder knowledge, including @{text "ik_add"} and  @{text "ik_oracle"}\<close>
  (******************************************************************************)
text\<open>We now instantiate the parametrized model's definition of the intruder knowledge, using the
definitions of @{text "ik_add"} and  @{text "ik_oracle"} from above. We then prove the properties
that we need to instantiate the @{text "dataplane_3_undirected"} locale.\<close>
print_locale dataplane_3_undirected_ik_defs
sublocale
  dataplane_3_undirected_ik_defs _ _ _ auth_seg0 terms_uinfo no_oracle hf_valid auth_restrict extr
    extr_ainfo term_ainfo terms_hf ik_add ik_oracle
  by unfold_locales

lemma ik_hfs_form: "t \<in> parts ik_hfs \<Longrightarrow> \<exists> t' . t = Hash t'"
  apply auto apply(drule parts_singleton)
  by(auto simp add: auth_seg2_def hf_valid_invert)

declare ik_hfs_def[simp del]

lemma parts_ik_hfs[simp]: "parts ik_hfs = ik_hfs"
  by (auto intro!: parts_Hash ik_hfs_form)

text\<open>This lemma allows us not only to expand the definition of @{term "ik_hfs"}, but also
to obtain useful properties, such as a term being a Hash, and it being part of a valid hop field.\<close>
lemma ik_hfs_simp:
  "t \<in> ik_hfs \<longleftrightarrow> (\<exists>t' . t = Hash t') \<and> (\<exists>hf . t = HVF hf
                    \<and> (\<exists>hfs uinfo. hf \<in> set hfs \<and> (\<exists>ainfo . (ainfo, hfs) \<in> auth_seg2 uinfo
                    \<and> hf_valid ainfo uinfo hfs hf)))" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume asm: "?lhs"
  then obtain ainfo uinfo hf hfs where
    dfs: "hf \<in> set hfs" "(ainfo, hfs) \<in> auth_seg2 uinfo" "t = HVF hf"
    by(auto simp add: ik_hfs_def)
  then obtain uinfo where "hfs_valid_prefix ainfo uinfo [] hfs = hfs"  "(ainfo, AHIS hfs) \<in> auth_seg0"
    by(auto simp add: auth_seg2_def)
  then show "?rhs" using asm dfs
    by (auto 3 4 simp add: auth_seg2_def intro!: ik_hfs_form exI[of _ hf])
qed(auto simp add: ik_hfs_def)

lemma ik_uinfo_empty[simp]: "ik_uinfo = {\<epsilon>}"
  by(auto simp add: ik_uinfo_def auth_seg2_def auth_restrict_def intro!: exI[of _ "[]"])
declare ik_uinfo_def[simp del]

(******************************************************************************)
subsubsection \<open>Properties of Intruder Knowledge\<close>
(******************************************************************************)
lemma auth_ainfo[dest]: "\<lbrakk>(ainfo, hfs) \<in> auth_seg2 uinfo\<rbrakk> \<Longrightarrow> \<exists> ts . ainfo = Num ts"
  by(auto simp add: auth_seg2_def)

lemma Num_ik[intro]: "Num ts \<in> ik"
  by(auto simp add: ik_def auth_seg2_def auth_restrict_def intro!: exI[of _ "[]"])

text \<open>There are no ciphertexts (or signatures) in @{term "parts ik"}. Thus, @{term "analz ik"}
and @{term "parts ik"} are identical.\<close>
lemma analz_parts_ik[simp]: "analz ik = parts ik"
  by(rule no_crypt_analz_is_parts)
    (auto simp add: ik_def auth_seg2_def ik_hfs_simp auth_restrict_def)

lemma parts_ik[simp]: "parts ik = ik"
  by(auto 3 4 simp add: ik_def auth_seg2_def auth_restrict_def dest!: parts_singleton_set)

lemma sntag_synth_bad: "sntag ahi \<in> synth ik \<Longrightarrow> ASID ahi \<in> bad"
  apply(cases ahi)
  by(auto simp add: ik_def ik_hfs_simp)

lemma back_subst_set_member: "\<lbrakk>hf' \<in> set hfs; hf' = hf\<rbrakk> \<Longrightarrow> hf \<in> set hfs" by simp

lemma sntag_asid: "sntag hf = sntag hf' \<Longrightarrow> ASID hf' = ASID hf" apply(cases hf, cases hf') by auto

lemma map_hf2term_eq: "map (\<lambda>x. hf2term (AHI x)) hfs = map (\<lambda>x. hf2term (AHI x)) hfs'
\<Longrightarrow> AHIS hfs' = AHIS hfs" apply(induction hfs hfs' rule: list_induct2', auto)
  using term2hf_hf2term by (metis)
(******************************************************************************)
subsection\<open>Direct proof goals for interpretation of @{text "dataplane_3_undirected"}\<close>
(******************************************************************************)

lemma COND_honest_hf_analz:
  assumes "ASID (AHI hf) \<notin> bad" "hf_valid ainfo uinfo hfs hf" "terms_hf hf \<subseteq> synth (analz ik)"
    "no_oracle ainfo uinfo" "hf \<in> set hfs"
    shows "terms_hf hf \<subseteq> analz ik"
proof-
  from assms(3) have hf_synth_ik: "HVF hf \<in> synth ik" by auto
  then have "\<exists>hfs uinfo. hf \<in> set hfs \<and> (ainfo, hfs) \<in> auth_seg2 uinfo"
    using assms(1,2,4,5)
    apply(auto simp add: ik_def hf_valid_invert ik_hfs_simp)
    subgoal for ts' hf' hfs'
      apply (auto intro!: exI[of _ hfs'])
      apply(frule back_subst_set_member[where hfs="hfs'"])
      apply(rule HF.equality)
          apply auto
      apply(drule sntag_asid)
      apply(drule map_hf2term_eq)
      using auth_seg0_no_dups
      by (metis (mono_tags, lifting) AHIS_set_rev HF.surjective auth_seg20 old.unit.exhaust)
    by(auto simp add: ik_hfs_simp ik_def hf_valid_invert sntag_synth_bad)
  then have "HVF hf \<in> ik"
    using assms(2)
    by(auto simp add: ik_hfs_def intro!: ik_ik_hfs intro!: exI)
  then show ?thesis by auto
qed

lemma COND_terms_hf:
  assumes "hf_valid ainfo uinfo hfs hf" and "HVF hf \<in> ik" and "no_oracle ainfo uinfo" and "hf \<in> set hfs"
  shows "\<exists>hfs. hf \<in> set hfs \<and> (\<exists>uinfo' . (ainfo, hfs) \<in> auth_seg2 uinfo')"
  using assms apply(auto 3 4 simp add: hf_valid_invert ik_hfs_simp ik_def dest: ahi_eq)
  subgoal for ts' hf' hfs'
      apply (auto intro!: exI[of _ hfs'])
    apply(frule back_subst_set_member[where hfs="hfs'"])
    apply auto
      apply(rule HF.equality)
          apply auto
      apply(drule sntag_asid)
      apply(drule map_hf2term_eq)
      using auth_seg0_no_dups
      by (metis (mono_tags, lifting) AHIS_set_rev HF.surjective auth_seg20 old.unit.exhaust)
    done

lemma COND_extr:
    "\<lbrakk>hf_valid ainfo uinfo l hf\<rbrakk> \<Longrightarrow> extr (HVF hf) = AHIS l"
  by(auto simp add: hf_valid_invert)

lemma COND_hf_valid_uinfo:
    "\<lbrakk>hf_valid ainfo uinfo l hf; hf_valid ainfo' uinfo' l' hf\<rbrakk>
    \<Longrightarrow> uinfo' = uinfo"
  by(auto simp add: hf_valid_invert)

(******************************************************************************)
subsection\<open>Instantiation of @{text "dataplane_3_undirected"} locale\<close>
(******************************************************************************)
print_locale dataplane_3_undirected
sublocale
  dataplane_3_undirected _ _ _ auth_seg0 hf_valid auth_restrict extr extr_ainfo term_ainfo terms_uinfo ik_add terms_hf
            ik_oracle  no_oracle
  apply unfold_locales
  using COND_terms_hf COND_honest_hf_analz COND_extr COND_hf_valid_uinfo by auto

end
end


theory Scratch
  imports Main "HOL-Library.Mapping"
begin

fun reverse :: "'a list => 'a list" where
  "reverse [] = []" |
  "reverse (x # xs) = reverse xs @ [x]"

value "reverse [1::nat, 2, 3]"

value "reverse (a # xs)"

lemma rev1: "reverse (xs @ [a]) = a # reverse xs"
  apply(induct xs)
  apply auto
  done

theorem "reverse (reverse xs) = xs"
  apply(induct xs)
  apply auto
  by (simp add:rev1)

type_synonym word = nat
type_synonym addr = nat
type_synonym buffer = "nat list"
type_synonym contract = buffer

record frameState =
   contract     :: addr
   codeContract :: addr
   code         :: buffer
   pc           :: nat
   stack        :: "nat list"
   memory       :: buffer
   memorySize   :: nat
   calldata     :: buffer
   callvalue    :: nat
   caller       :: addr
   gas          :: nat
   returndata   :: buffer
   static       :: bool

record subState =
  selfdestructs   :: "addr list"
  touchedAccounts :: "addr list"

(*  refunds         :: "(addr, word) list" *)

record creationContext =
    creationContextCodehash  :: word
    creationContextReversion :: "(addr, buffer) mapping"
    creationContextSubstate  :: subState

record callContext =
    callContextTarget    :: addr
    callContextContext   :: addr
    callContextOffset    :: word
    callContextSize      :: word
    callContextCodehash  :: word
    callContextAbi       :: "word option"
    callContextData      :: buffer
    callContextReversion :: "(addr, contract) mapping"
    callContextSubState  :: subState

datatype frameContext =
    CallContext "callContext"
  | CreationContext "creationContext"

record frame =
  frameContext   :: frameContext
  frameState     :: frameState

datatype storageModel = ConcreteS | SymbolicS | InitialS

record env =
  contracts    :: "(addr, contract) mapping"
  chainId      :: word
  storageModel :: storageModel
  sha3Crack    :: "(word, buffer) mapping"

(*  keccakUsed   :: [([SWord 8], SWord 256)] *)

record block =
  coinbase    :: addr
  timestamp   :: word
  number      :: word
  difficulty  :: word
  gaslimit    :: word
  maxCodeSize :: word
(*  schedule    :: feeSchedule word*)

record txState =
  gasprice        :: word
  txgaslimit      :: word
  origin          :: addr
  toAddr          :: addr
  val             :: word
  substate        :: subState
  isCreate        :: bool
  txReversion     :: "(addr, contract) mapping"

datatype error
  = BalanceTooLow word word
  | UnrecognizedOpcode word
  | SelfDestruction
  | StackUnderrun
  | BadJumpDestination
  | Revert buffer
  | NoSuchContract addr
  | OutOfGas word word
  | BadCheatCode "word option"
  | StackLimitExceeded
  | IllegalOverflow
  | StateChangeWhileStatic
  | InvalidMemoryAccess
  | CallDepthLimitReached
  | MaxCodeSizeExceeded word word
  | PrecompileFailure
  | UnexpectedSymbolicArg
  | DeadPath

datatype vmResult
  = VMFailure error
  | VMSuccess buffer

datatype log = Log addr buffer "word list"

record vm =
  result         :: "vmResult option"
  state          :: frameState
  env            :: env
  block          :: block
  tx             :: txState
  logs           :: "log list"
  burned         :: word

end


theory Example_NetModel
imports "../TopoS_Interface" "../TopoS_Helper"
begin

text{* A toy example that defines a valid network security requirement model *}

definition default_node_properties :: "bool"
  where  "default_node_properties \<equiv> False"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> (edges G). (nP e1) \<and> (nP e2))"

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

(* we will not define receiver_violation!! Works for both! *)

-- "The preliminaries: mostly, sinvar is monotonic"
interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
and verify_globals = verify_globals
  apply unfold_locales
  apply(frule_tac finite_distinct_list[OF valid_graph.finiteE])
  apply(erule_tac exE)
  apply(rename_tac list_edges)
  apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
  apply(auto)[6]
  apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[2]
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
done

-- "With generic target focus"
interpretation Example_NetModel: SecurityInvariant
where default_node_properties = default_node_properties
and sinvar = sinvar
and verify_globals = verify_globals
and receiver_violation = receiver_violation (*yep, that's a variable*)
  unfolding default_node_properties_def
  apply unfold_locales

  -- "Secure bydefault"
  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add: graph_ops)
  apply (simp split: split_split_asm split_split)
    apply blast

 -- "Uniqueness"
 apply(simp add:default_node_properties_def)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add: graph_ops)
  apply (simp split: split_split_asm split_split)
  -- "proof by counter example: assume False is not the unique default parameter"
  apply(rule_tac x="\<lparr> nodes={vertex_1}, edges = {(vertex_1,vertex_1)} \<rparr>" in exI, simp)
  apply(rule conjI)
  apply(simp add: valid_graph_def)
  apply(rule_tac x="(\<lambda> x. default_node_properties)(vertex_1 := False)" in exI, simp add:default_node_properties_def)
  apply(case_tac receiver_violation)
    apply(simp_all)
    apply(rule_tac x="{(vertex_1,vertex_1)}" in exI, simp)+
done

text{*And we end up with a totally useless network security requirement model. I hope this was instructive.*}

end