(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(GD_GPL)
 *)

(* Title:   System_S
 * Description: High-level security model of the kernel.
 *)

(*
  Naming conventions:
  - Names of sets end with an `s'.
    Hence `rights', `caps', `states'.
    Try to avoid other names that end in `s'.
 *)

theory System_S
imports "../../lib/$L4V_ARCH/WordSetup"
begin

(* System entities: Definition of entities that constitute the system
 *)

type_synonym entity_id = word32 (* kernel objects - identified by a UID *)

datatype
  right = Read      (* Authorise reading of information *)
         | Write    (* Authorise writing of information *)
         | Take     (* Having sufficient authority to take a capability from another entity *)
         | Grant    (* Having sufficient authority to propagate a capability to another entity *)
         | Create   (* Confers the authority to create new entities *)
         | Store    (* Simulates CNodeCap - get caps of said entity *)

record cap =
  target :: entity_id      (* The entity over which it has control *)
  rights :: "right set"    (* The control it has over that entity  *)

datatype entity = Entity "cap set"
declare entity.splits [split]

type_synonym state = "entity_id \<Rightarrow> entity option"

type_synonym modify_state   = "state \<Rightarrow> state"
type_synonym modify_state_n = "state \<Rightarrow> state set"
type_synonym mask = "right set"

definition
  null_entity :: "entity" where
  "null_entity \<equiv> Entity {}"

definition
  all_rights :: "right set" where
  "all_rights \<equiv> UNIV"

lemma all_rights_def2:
  "all_rights = {Read, Write, Take, Grant, Create, Store}"
  apply (clarsimp simp: all_rights_def, rule, simp_all, rule, simp)
  apply (metis right.exhaust)
  done

definition
  entity_ids :: "state \<Rightarrow> entity_id set" where
  "entity_ids s \<equiv> dom s"

definition
  is_entity :: "state \<Rightarrow> entity_id \<Rightarrow> bool" where
  "is_entity s e \<equiv> s e \<noteq> None"

definition
  exist :: "state \<Rightarrow> cap \<Rightarrow> bool" where
  "exist s c \<equiv> is_entity s (target c)"

(* Manipulating entities. *)
definition
  direct_caps :: "entity \<Rightarrow> cap set"
where
  "direct_caps e \<equiv> case e of (Entity c) \<Rightarrow> c"

definition
  direct_caps_of :: "state \<Rightarrow> entity_id \<Rightarrow> cap set"
where
  "direct_caps_of s p \<equiv>
  case s p of
    None \<Rightarrow> {}
  | Some (Entity e) \<Rightarrow> e"

definition
  store_connected_direct :: "state \<Rightarrow> (entity_id \<times> entity_id) set" where
  "store_connected_direct s \<equiv> {(e\<^sub>x, e\<^sub>y). \<exists>cap. cap \<in> direct_caps_of s e\<^sub>x \<and>
                                               Store \<in> rights cap \<and>
                                               target cap = e\<^sub>y}"

definition
  store_connected :: "state \<Rightarrow> (entity_id \<times> entity_id) set" where
  "store_connected s \<equiv> (store_connected_direct s)^*"

definition
  (* returns all capabilities an entity has access to
    (via store or directly) *)
  caps_of :: "state \<Rightarrow> entity_id \<Rightarrow> cap set" where
  "caps_of s e  \<equiv> \<Union>(direct_caps_of s ` {e' . (e,e') \<in> store_connected s})"

lemma caps_rel:
  "caps_of s e = \<Union>(direct_caps_of s ` store_connected s `` {e})"
  by (simp add: caps_of_def Image_def)

definition  (* All the different capabilities of the system *)
  all_caps_of :: "state \<Rightarrow> cap set" where
  "all_caps_of s \<equiv> \<Union>e. direct_caps_of s e"

definition
  read_cap :: "entity_id \<Rightarrow> cap" where
  "read_cap e\<^sub>x \<equiv> \<lparr>target = e\<^sub>x, rights = {Read}\<rparr>"

definition
  write_cap :: "entity_id \<Rightarrow> cap" where
  "write_cap e\<^sub>x \<equiv> \<lparr>target = e\<^sub>x, rights = {Write}\<rparr>"

definition
  take_cap :: "entity_id \<Rightarrow> cap" where
  "take_cap e\<^sub>x \<equiv> \<lparr>target = e\<^sub>x, rights = {Take}\<rparr>"

definition
  grant_cap :: "entity_id \<Rightarrow> cap" where
  "grant_cap e\<^sub>x \<equiv> \<lparr>target = e\<^sub>x, rights = {Grant}\<rparr>"

definition
  create_cap :: "entity_id \<Rightarrow> cap" where
  "create_cap e\<^sub>x \<equiv> \<lparr>target = e\<^sub>x, rights = {Create}\<rparr>"

definition
  store_cap :: "entity_id \<Rightarrow> cap" where
  "store_cap e \<equiv> \<lparr>target = e, rights = {Store}\<rparr>"

definition
  full_cap :: "entity_id \<Rightarrow> cap" where
  "full_cap e \<equiv> \<lparr>target = e, rights = all_rights \<rparr>"

(* System operations: primitive kernel operations *)

datatype sysOPs =
    SysCreate entity_id cap cap
  | SysTake   entity_id cap cap mask
  | SysGrant  entity_id cap cap mask
  | SysCopy   entity_id cap cap mask
  | SysRemove entity_id cap cap
  | SysRemoveSet entity_id cap "cap set"
  | SysRevoke entity_id cap
  | SysDestroy entity_id cap

(* determine if an operation is allowed in the given state_s *)
primrec
  legal :: "sysOPs \<Rightarrow> state \<Rightarrow> bool"
where
  "legal (SysCreate e c\<^sub>1 c\<^sub>2) s = (is_entity s e \<and> is_entity s (target c\<^sub>1) \<and> \<not> (is_entity s (target c\<^sub>2)) \<and>
                                   {c\<^sub>1, c\<^sub>2} \<subseteq> caps_of s e \<and>
                                   Write \<in> rights c\<^sub>1 \<and> Store \<in> rights c\<^sub>1 \<and> Create \<in> rights c\<^sub>2)"

| "legal (SysTake  e c\<^sub>1 c\<^sub>2 r) s = (is_entity s e \<and>  is_entity s (target c\<^sub>1) \<and>
                                  c\<^sub>1 \<in> caps_of s e \<and> c\<^sub>2 \<in> caps_of s (target c\<^sub>1) \<and> Take \<in> rights c\<^sub>1)"

| "legal (SysGrant e c\<^sub>1 c\<^sub>2 r) s = (is_entity s e \<and>  is_entity s (target c\<^sub>1) \<and>
                                  {c\<^sub>1,c\<^sub>2} \<subseteq> caps_of s e \<and> Grant \<in> rights c\<^sub>1)"

| "legal (SysCopy  e c\<^sub>1 c\<^sub>2 r) s   = (is_entity s e \<and>  is_entity s (target c\<^sub>1) \<and>
                                  {c\<^sub>1,c\<^sub>2} \<subseteq> caps_of s e \<and> Store \<in> rights c\<^sub>1)"

| "legal (SysRemove e c\<^sub>1 c\<^sub>2) s = (is_entity s e \<and> c\<^sub>1 \<in> caps_of s e)"

| "legal (SysRemoveSet e c C) s = (is_entity s e \<and> c \<in> caps_of s e)"

| "legal (SysRevoke e c) s = (is_entity s e \<and> c \<in> caps_of s e)"

| "legal (SysDestroy e c) s = (is_entity s e \<and> c \<in> caps_of s e \<and> {Create} = rights c \<and>
                              target c \<notin> target ` (all_caps_of s - {c}))"

(* Following functions define how each of the sysOPs modifies the
 * system state_s
 *)

definition
  diminish :: "right set \<Rightarrow> cap \<Rightarrow> cap" where
  "diminish R cap \<equiv> cap \<lparr> rights := rights cap \<inter> R \<rparr>"

definition
  createOperation ::
  "entity_id \<Rightarrow> cap \<Rightarrow> cap \<Rightarrow> modify_state" where
  "createOperation e c\<^sub>1 c\<^sub>2 s \<equiv>
  s (target c\<^sub>1 \<mapsto> Entity (insert (full_cap (target c\<^sub>2))
                                (direct_caps_of s (target c\<^sub>1))),
     target c\<^sub>2 \<mapsto> null_entity)"

lemma createOperation_def2:
  "createOperation e c\<^sub>1 c\<^sub>2 s \<equiv>
  let new_cap = \<lparr> target = target c\<^sub>2, rights = all_rights \<rparr>;
      newTarget = ({new_cap} \<union> direct_caps_of s (target c\<^sub>1) )
  in
  s (target c\<^sub>1 \<mapsto> Entity newTarget, target c\<^sub>2 \<mapsto> null_entity)"
  by (simp add: createOperation_def Let_def full_cap_def null_entity_def)

definition
  takeOperation :: "entity_id \<Rightarrow> cap \<Rightarrow> cap \<Rightarrow> right set \<Rightarrow> modify_state" where
  "takeOperation e c\<^sub>1 c\<^sub>2 R s \<equiv>
  s (e \<mapsto> Entity (insert (diminish R c\<^sub>2) (direct_caps_of s e)))"

lemma takeOperation_def2:
  "takeOperation e c\<^sub>1 c\<^sub>2 R s \<equiv>
  s (e \<mapsto> Entity ({diminish R c\<^sub>2} \<union> direct_caps_of s e))"
  by (clarsimp simp: takeOperation_def caps_of_def)

definition
  grantOperation ::
  "entity_id \<Rightarrow> cap \<Rightarrow> cap \<Rightarrow> right set \<Rightarrow> modify_state" where
  "grantOperation e c\<^sub>1 c\<^sub>2 R s \<equiv>
  s (target c\<^sub>1 \<mapsto> Entity (insert (diminish R c\<^sub>2) (direct_caps_of s (target c\<^sub>1)) )) "

lemma grantOperation_def2:
  "grantOperation e c\<^sub>1 c\<^sub>2 R s \<equiv>
  s (target c\<^sub>1 \<mapsto> Entity ( {diminish R c\<^sub>2} \<union> direct_caps_of s (target c\<^sub>1)))"
  by (clarsimp simp: grantOperation_def caps_of_def)

definition
  copyOperation ::
  "entity_id \<Rightarrow> cap \<Rightarrow> cap \<Rightarrow> right set \<Rightarrow> modify_state" where
  "copyOperation sRef c\<^sub>1 c\<^sub>2 R s \<equiv>
  s (target c\<^sub>1 \<mapsto> Entity (insert (diminish R c\<^sub>2) (direct_caps_of s (target c\<^sub>1)))) "

definition
  removeOperation ::
  "entity_id \<Rightarrow> cap \<Rightarrow> cap \<Rightarrow> modify_state" where
  "removeOperation e c\<^sub>1 c\<^sub>2 s \<equiv>
  if is_entity s (target c\<^sub>1)
  then
     s ((target c\<^sub>1) \<mapsto> Entity ((direct_caps_of s (target c\<^sub>1)) - {c\<^sub>2} ))
  else
     s"

lemma removeOperation_simpler:
  "removeOperation e c\<^sub>1 c\<^sub>2 s \<equiv>
  (case s (target c\<^sub>1) of
    None \<Rightarrow> s
  | Some (Entity caps) \<Rightarrow> s (target c\<^sub>1 \<mapsto> Entity (caps - {c\<^sub>2})))"
  by (rule eq_reflection, simp add: removeOperation_def is_entity_def direct_caps_of_def
                             split: if_split_asm option.splits)

definition
  removeSetOperation ::
  "entity_id \<Rightarrow> cap \<Rightarrow> cap set \<Rightarrow> modify_state" where
  "removeSetOperation e c C s \<equiv>
  if is_entity s (target c) then
   s ((target c) \<mapsto> Entity ((direct_caps_of s (target c)) - C ))
  else
   s"

lemma removeSetOperation_simpler:
  "removeSetOperation e c caps s \<equiv>
  (case s (target c) of
    None \<Rightarrow> s
  | Some (Entity caps') \<Rightarrow> s (target c \<mapsto> Entity (caps' - caps)))"
  by (auto simp: removeSetOperation_def is_entity_def direct_caps_of_def
         intro!: eq_reflection
          split: if_split_asm option.splits)

lemma removeSetOperation_fold_removeOperation:
  "removeSetOperation e c (set caps) s = fold (removeOperation e c) caps s"
  apply (subst foldr_fold [symmetric])
   apply (fastforce simp: removeOperation_def direct_caps_of_def is_entity_def)
  apply (rule sym)
  apply (induct caps)
   apply (fastforce simp: removeSetOperation_def removeOperation_def direct_caps_of_def is_entity_def)
  apply (fastforce simp: removeSetOperation_def removeOperation_def direct_caps_of_def is_entity_def)
  done

definition
  removeSetOfCaps :: "(entity_id \<Rightarrow> cap set) \<Rightarrow> modify_state"
where
  "removeSetOfCaps cap_map s \<equiv> \<lambda>e.
     if is_entity s e
     then Some (Entity ((direct_caps_of s e) - cap_map e ))
     else None"

definition
  caps_to_entity :: "entity_id \<Rightarrow> entity_id \<Rightarrow> state \<Rightarrow> cap set"
where
  "caps_to_entity e e' s \<equiv> {cap. cap \<in> direct_caps_of s e' \<and> target cap = e}"

definition
  revokeOperation :: "entity_id \<Rightarrow> cap \<Rightarrow> modify_state_n" where
  "revokeOperation e c s \<equiv>
    {s'. \<exists>cap_map. \<forall>e'. cap_map e' \<subseteq> caps_to_entity (target c) e' s \<and>
         s' = removeSetOfCaps cap_map s}"

definition
  destroyOperation :: "entity_id \<Rightarrow> cap \<Rightarrow> modify_state" where
  "destroyOperation e c s \<equiv> s(target c := None)"

(* Non deterministically executing system calls:
 * How we execute a single operation
 *)
primrec
  step' :: "sysOPs \<Rightarrow> modify_state_n"
where
  "step' (SysCreate    e c\<^sub>1 c\<^sub>2) s   = {createOperation e c\<^sub>1 c\<^sub>2 s}"
| "step' (SysTake      e c\<^sub>1 c\<^sub>2 R) s = {takeOperation  e c\<^sub>1 c\<^sub>2 R s}"
| "step' (SysGrant     e c\<^sub>1 c\<^sub>2 R) s = {grantOperation  e c\<^sub>1 c\<^sub>2 R s}"
| "step' (SysCopy      e c\<^sub>1 c\<^sub>2 R) s = {copyOperation e c\<^sub>1 c\<^sub>2 R s}"
| "step' (SysRemove    e c\<^sub>1 c\<^sub>2)   s = {removeOperation e c\<^sub>1 c\<^sub>2 s}"
| "step' (SysRemoveSet e c C)    s = {removeSetOperation e c C s}"
| "step' (SysRevoke    e c) s      =  revokeOperation e c s"
| "step' (SysDestroy   e c) s      = {destroyOperation e c s}"

(* single operation is allowed only if it is legal in the current state_s *)
definition
  step :: "sysOPs \<Rightarrow> modify_state_n" where
  "step cmd s \<equiv> if legal cmd s then (step' cmd s) \<union> {s} else {s}"

(* execution of a list of commands (from back of list)
 *)
primrec
  execute :: "sysOPs list \<Rightarrow> state \<Rightarrow> state set"
where
  "execute [] s = {s}"
| "execute (cmd#cmds) s = \<Union> (step cmd ` ( execute cmds s ))"

(***************************
 * Lemmas about the model. *
 ***************************)

lemma Int_all_rights [simp]: "c \<inter> all_rights = c"
  by (simp add: all_rights_def)

lemma is_entity_dom: "is_entity s e = (e \<in> dom s)"
  by (simp add: is_entity_def dom_def)

lemma is_entity_imp_not_None:
  "is_entity s e \<Longrightarrow> s e \<noteq> None"
  by (simp add: is_entity_def)

lemma store_connected_refl [simp]:
  "(e, e) \<in> store_connected s"
  by (simp add: store_connected_def)

lemma no_caps_of_imp_not_connected [rule_format]:
  "\<lbrakk>(e, x) \<in> store_connected s\<rbrakk>
  \<Longrightarrow> direct_caps_of s e = {} \<longrightarrow> x = e"
  apply (unfold store_connected_def)
  apply (erule rtrancl.induct)
   apply simp
  apply (clarsimp simp: store_connected_direct_def direct_caps_of_def)
  done

lemma no_direct_caps_of_no_caps_of:
  "(direct_caps_of s e = {}) = (caps_of s e = {})"
  apply (rule iffI)
   apply (clarsimp simp add: caps_of_def)
   apply (drule (1) no_caps_of_imp_not_connected)
   apply simp
  apply (clarsimp simp add: caps_of_def store_connected_def)
  done

lemma no_direct_caps_of_imp_no_caps_of:
  "direct_caps_of s e = {} \<Longrightarrow> caps_of s e = {}"
  by (rule no_direct_caps_of_no_caps_of [THEN iffD1])

lemma no_caps_of_imp_no_direct_caps_of:
  "caps_of s e = {} \<Longrightarrow> direct_caps_of s e = {}"
  by (rule no_direct_caps_of_no_caps_of [THEN iffD2])

lemma store_connected_direct_in_store_connected:
  "(x, y) \<in> store_connected_direct s \<Longrightarrow> (x, y) \<in> store_connected s"
  by (simp add: store_connected_def)

lemma no_diminish [simp]:
  "diminish all_rights c = c"
  by (simp add: diminish_def)

lemma no_diminish_image [simp]:
  "diminish all_rights ` C = C"
  by (fastforce)

lemma diminish_diminish [simp]:
  "diminish dimR2 (diminish dimR1 sc) = diminish (dimR1 \<inter> dimR2) sc"
  by (clarsimp simp add: diminish_def Int_assoc)

lemma diminish_range_diminish [simp]:
  "diminish dimR2 ` diminish dimR1 ` ssc = diminish (dimR1 \<inter> dimR2) ` ssc"
  apply (rule set_eqI)
  apply (rule iffI)
   apply (clarsimp)
  apply (clarsimp simp del: diminish_diminish simp add: diminish_diminish [symmetric])
  done

lemma execute_not_empty:
  "execute ops s \<noteq> {}"
  apply (induct ops)
   apply (simp)
  apply (simp add: step_def del: if_image_distrib, fast)
  done

lemma execute_append [intro]:
  "\<And> s s' s'' opsA. \<lbrakk> s'' \<in> execute opsA s; s' \<in> execute opsB s'' \<rbrakk> \<Longrightarrow> s' \<in> execute (opsB @ opsA) s"
  apply (induct opsB)
   apply (simp)
  apply (atomize)
  apply (clarsimp)
  apply (rule bexI)
   apply (assumption)
  by (drule spec | drule(1) mp)+

(* Lemma on caps *)

lemma heapAdd_read_cap [simp]:
  "target (read_cap e) = e"
  by (simp add: read_cap_def)

lemma rights_read_cap [simp]:
  "rights (read_cap e) = {Read}"
  by (simp add: read_cap_def)

lemma heapAdd_write_cap [simp]:
  "target (write_cap e) = e"
  by (simp add: write_cap_def)

lemma rights_write_cap [simp]:
  "rights (write_cap e) = {Write}"
  by (simp add: write_cap_def)

lemma heapAdd_take_cap [simp]:
  "target (take_cap e) = e"
  by (simp add: take_cap_def)

lemma rights_take_cap [simp]:
  "rights (take_cap e) = {Take}"
  by (simp add: take_cap_def)

lemma heapAdd_grant_cap [simp]:
  "target (grant_cap e) = e"
  by (simp add: grant_cap_def)

lemma rights_grant_cap [simp]:
  "rights (grant_cap e) = {Grant}"
  by (simp add: grant_cap_def)

lemma heapAdd_create_cap [simp]:
  "target (create_cap e) = e"
  by (simp add: create_cap_def)

lemma rights_create_cap [simp]:
  "rights (create_cap e) = {Create}"
  by (simp add: create_cap_def)

lemma heapAdd_store_cap [simp]:
  "target (store_cap e) = e"
  by (simp add: store_cap_def)

lemma rights_store_cap [simp]:
  "rights (store_cap e) = {Store}"
  by (simp add: store_cap_def)

lemma heapAdd_full_cap [simp]:
  "target (full_cap e) = e"
  by (simp add: full_cap_def)

lemma rights_full_cap [simp]:
  "rights (full_cap e) = all_rights"
  by (simp add: full_cap_def)

lemma entity_diminish [simp]:
  "target (diminish R c) = target c"
  by (simp add: diminish_def)

lemma rights_diminish [simp]:
  "rights (diminish R c) = rights c \<inter> R"
  by (simp add: diminish_def)

(* Lemmas on caps_of *)

lemma caps_of_imp_some_direct_cap:
  "c \<in> caps_of s e \<Longrightarrow> \<exists>e'. c \<in> direct_caps_of s e'"
  by (auto simp: caps_of_def)

lemma caps_of_imp_some_store_connected_direct_cap:
  "c \<in> caps_of s e \<Longrightarrow> \<exists>e'. (e, e') \<in> store_connected s \<and> c \<in> direct_caps_of s e'"
  by (auto simp: caps_of_def)

lemma direct_cap_in_cap:
  "c \<in> direct_caps_of s e \<Longrightarrow> c \<in> caps_of s e"
  by (auto simp: caps_of_def store_connected_def)

lemma all_caps_ofE [elim!]:
  "\<lbrakk> c \<in> all_caps_of s; \<And>e'. c \<in> direct_caps_of s e' \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (fastforce simp add: all_caps_of_def)

lemma all_caps_ofI [intro]:
  "c \<in> direct_caps_of s e' \<Longrightarrow> c \<in> all_caps_of s"
  by (fastforce simp add: all_caps_of_def)

(* Lemmas on entities *)

lemma entity_not_not_entity:
  "\<lbrakk>is_entity s e\<^sub>1; \<not> is_entity s e\<^sub>2\<rbrakk> \<Longrightarrow> e\<^sub>1 \<noteq> e\<^sub>2"
  by (auto simp: is_entity_def)

lemma no_direct_caps_of_in_nonEntity:
  "\<not> is_entity s e \<Longrightarrow> direct_caps_of s e = {}"
  by (auto simp: direct_caps_of_def is_entity_def split:option.splits)

lemma not_is_entity_imp_no_direct_caps_of:
  "\<not> is_entity s e \<Longrightarrow> caps_of s e = {}"
  by (drule no_direct_caps_of_in_nonEntity, erule no_direct_caps_of_imp_no_caps_of)

lemma direct_caps_of_imp_is_entity:
  "c \<in> direct_caps_of s e \<Longrightarrow> is_entity s e"
  by (auto intro: classical dest: no_direct_caps_of_in_nonEntity)

lemma caps_of_imp_is_entity:
  "c \<in> caps_of s e \<Longrightarrow> is_entity s e"
  by (auto intro: classical dest: not_is_entity_imp_no_direct_caps_of)

(* Lemmas on store_connected *)

lemma store_caps_of_store_connected_direct:
  "\<lbrakk>c \<in> direct_caps_of s e; Store \<in> rights c\<rbrakk>
  \<Longrightarrow> (e, target c) \<in> store_connected_direct s"
  by (fastforce simp: store_connected_direct_def)

lemma store_caps_store_connected:
  "\<lbrakk>c \<in> caps_of s e; Store \<in> rights c\<rbrakk> \<Longrightarrow> (e, target c) \<in> store_connected s"
  apply (clarsimp simp: store_connected_def caps_of_def)
  by (frule (1) store_caps_of_store_connected_direct, simp)

end


(*  Title:      HOL/IOA/IOA.thy
    Author:     Tobias Nipkow & Konrad Slind
    Copyright   1994  TU Muenchen
*)

section \<open>The I/O automata of Lynch and Tuttle\<close>

theory IOA
imports Asig
begin

type_synonym 'a seq = "nat => 'a"
type_synonym 'a oseq = "nat => 'a option"
type_synonym ('a, 'b) execution = "'a oseq * 'b seq"
type_synonym ('a, 's) transition = "('s * 'a * 's)"
type_synonym ('a,'s) ioa = "'a signature * 's set * ('a, 's) transition set"

(* IO automata *)

definition state_trans :: "['action signature, ('action,'state)transition set] => bool"
  where "state_trans asig R \<equiv>
     (\<forall>triple. triple \<in> R \<longrightarrow> fst(snd(triple)) \<in> actions(asig)) \<and>
     (\<forall>a. (a \<in> inputs(asig)) \<longrightarrow> (\<forall>s1. \<exists>s2. (s1,a,s2) \<in> R))"

definition asig_of :: "('action,'state)ioa => 'action signature"
  where "asig_of == fst"

definition starts_of :: "('action,'state)ioa => 'state set"
  where "starts_of == (fst o snd)"

definition trans_of :: "('action,'state)ioa => ('action,'state)transition set"
  where "trans_of == (snd o snd)"

definition IOA :: "('action,'state)ioa => bool"
  where "IOA(ioa) == (is_asig(asig_of(ioa)) &
                (~ starts_of(ioa) = {}) &
                state_trans (asig_of ioa) (trans_of ioa))"

(* Executions, schedules, and traces *)

(* An execution fragment is modelled with a pair of sequences:
   the first is the action options, the second the state sequence.
   Finite executions have None actions from some point on. *)
definition is_execution_fragment :: "[('action,'state)ioa, ('action,'state)execution] => bool"
  where "is_execution_fragment A ex \<equiv>
     let act = fst(ex); state = snd(ex)
     in \<forall>n a. (act(n)=None \<longrightarrow> state(Suc(n)) = state(n)) \<and>
              (act(n)=Some(a) \<longrightarrow> (state(n),a,state(Suc(n))) \<in> trans_of(A))"

definition executions :: "('action,'state)ioa => ('action,'state)execution set"
  where "executions(ioa) \<equiv> {e. snd e 0 \<in> starts_of(ioa) \<and> is_execution_fragment ioa e}"

definition reachable :: "[('action,'state)ioa, 'state] => bool"
  where "reachable ioa s \<equiv> (\<exists>ex\<in>executions(ioa). \<exists>n. (snd ex n) = s)"

definition invariant :: "[('action,'state)ioa, 'state=>bool] => bool"
  where "invariant A P \<equiv> (\<forall>s. reachable A s \<longrightarrow> P(s))"

(* Composition of action signatures and automata *)

consts
  compatible_asigs ::"('a \<Rightarrow> 'action signature) \<Rightarrow> bool"
  asig_composition ::"('a \<Rightarrow> 'action signature) \<Rightarrow> 'action signature"
  compatible_ioas  ::"('a \<Rightarrow> ('action,'state)ioa) \<Rightarrow> bool"
  ioa_composition  ::"('a \<Rightarrow> ('action, 'state)ioa) \<Rightarrow> ('action,'a \<Rightarrow> 'state)ioa"

(* binary composition of action signatures and automata *)

definition compat_asigs ::"['action signature, 'action signature] => bool"
  where "compat_asigs a1 a2 ==
   (((outputs(a1) Int outputs(a2)) = {}) \<and>
    ((internals(a1) Int actions(a2)) = {}) \<and>
    ((internals(a2) Int actions(a1)) = {}))"

definition compat_ioas  ::"[('action,'s)ioa, ('action,'t)ioa] \<Rightarrow> bool"
  where "compat_ioas ioa1 ioa2 \<equiv> compat_asigs (asig_of(ioa1)) (asig_of(ioa2))"

definition asig_comp :: "['action signature, 'action signature] \<Rightarrow> 'action signature"
  where "asig_comp a1 a2 \<equiv>
      (((inputs(a1) \<union> inputs(a2)) - (outputs(a1) \<union> outputs(a2)),
        (outputs(a1) \<union> outputs(a2)),
        (internals(a1) \<union> internals(a2))))"

definition par :: "[('a,'s)ioa, ('a,'t)ioa] \<Rightarrow> ('a,'s*'t)ioa"  (infixr "||" 10)
  where "(ioa1 || ioa2) \<equiv>
     (asig_comp (asig_of ioa1) (asig_of ioa2),
      {pr. fst(pr) \<in> starts_of(ioa1) \<and> snd(pr) \<in> starts_of(ioa2)},
      {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
           in (a \<in> actions(asig_of(ioa1)) | a \<in> actions(asig_of(ioa2))) &
              (if a \<in> actions(asig_of(ioa1)) then
                 (fst(s),a,fst(t)) \<in> trans_of(ioa1)
               else fst(t) = fst(s))
              &
              (if a \<in> actions(asig_of(ioa2)) then
                 (snd(s),a,snd(t)) \<in> trans_of(ioa2)
               else snd(t) = snd(s))})"

(* Filtering and hiding *)

(* Restrict the trace to those members of the set s *)
definition filter_oseq :: "('a => bool) => 'a oseq => 'a oseq"
  where "filter_oseq p s \<equiv>
   (\<lambda>i. case s(i)
         of None \<Rightarrow> None
          | Some(x) \<Rightarrow> if p x then Some x else None)"

definition mk_trace :: "[('action,'state)ioa, 'action oseq] \<Rightarrow> 'action oseq"
  where "mk_trace(ioa) \<equiv> filter_oseq(\<lambda>a. a \<in> externals(asig_of(ioa)))"

(* Does an ioa have an execution with the given trace *)
definition has_trace :: "[('action,'state)ioa, 'action oseq] \<Rightarrow> bool"
  where "has_trace ioa b \<equiv> (\<exists>ex\<in>executions(ioa). b = mk_trace ioa (fst ex))"

definition NF :: "'a oseq => 'a oseq"
  where "NF(tr) \<equiv> SOME nf. \<exists>f. mono(f) \<and> (\<forall>i. nf(i)=tr(f(i))) \<and>
                    (\<forall>j. j \<notin> range(f) \<longrightarrow> nf(j)= None) &
                    (\<forall>i. nf(i)=None --> (nf (Suc i)) = None)"

(* All the traces of an ioa *)
definition traces :: "('action,'state)ioa => 'action oseq set"
  where "traces(ioa) \<equiv> {trace. \<exists>tr. trace=NF(tr) \<and> has_trace ioa tr}"

definition restrict_asig :: "['a signature, 'a set] => 'a signature"
  where "restrict_asig asig actns \<equiv>
    (inputs(asig) \<inter> actns, outputs(asig) \<inter> actns,
     internals(asig) \<union> (externals(asig) - actns))"

definition restrict :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
  where "restrict ioa actns \<equiv>
    (restrict_asig (asig_of ioa) actns, starts_of(ioa), trans_of(ioa))"

(* Notions of correctness *)

definition ioa_implements :: "[('action,'state1)ioa, ('action,'state2)ioa] => bool"
  where "ioa_implements ioa1 ioa2 \<equiv>
  ((inputs(asig_of(ioa1)) = inputs(asig_of(ioa2))) \<and>
     (outputs(asig_of(ioa1)) = outputs(asig_of(ioa2))) \<and>
      traces(ioa1) \<subseteq> traces(ioa2))"

(* Instantiation of abstract IOA by concrete actions *)

definition rename :: "('a, 'b)ioa \<Rightarrow> ('c \<Rightarrow> 'a option) \<Rightarrow> ('c,'b)ioa"
  where "rename ioa ren \<equiv>
    (({b. \<exists>x. Some(x)= ren(b) \<and> x \<in> inputs(asig_of(ioa))},
      {b. \<exists>x. Some(x)= ren(b) \<and> x \<in> outputs(asig_of(ioa))},
      {b. \<exists>x. Some(x)= ren(b) \<and> x \<in> internals(asig_of(ioa))}),
                starts_of(ioa)   ,
     {tr. let s = fst(tr); a = fst(snd(tr));  t = snd(snd(tr))
          in
          \<exists>x. Some(x) = ren(a) \<and> (s,x,t) \<in> trans_of(ioa)})"

declare Let_def [simp]

lemmas ioa_projections = asig_of_def starts_of_def trans_of_def
  and exec_rws = executions_def is_execution_fragment_def

lemma ioa_triple_proj:
    "asig_of(x,y,z) = x & starts_of(x,y,z) = y & trans_of(x,y,z) = z"
  apply (simp add: ioa_projections)
  done

lemma trans_in_actions:
  "[| IOA(A); (s1,a,s2) \<in> trans_of(A) |] ==> a \<in> actions(asig_of(A))"
  apply (unfold IOA_def state_trans_def actions_def is_asig_def)
  apply (erule conjE)+
  apply (erule allE, erule impE, assumption)
  apply simp
  done

lemma filter_oseq_idemp: "filter_oseq p (filter_oseq p s) = filter_oseq p s"
  apply (simp add: filter_oseq_def)
  apply (rule ext)
  apply (case_tac "s i")
  apply simp_all
  done

lemma mk_trace_thm:
"(mk_trace A s n = None) =
   (s(n)=None | (\<exists>a. s(n)=Some(a) \<and> a \<notin> externals(asig_of(A))))
   &
   (mk_trace A s n = Some(a)) =
    (s(n)=Some(a) \<and> a \<in> externals(asig_of(A)))"
  apply (unfold mk_trace_def filter_oseq_def)
  apply (case_tac "s n")
  apply auto
  done

lemma reachable_0: "s \<in> starts_of(A) \<Longrightarrow> reachable A s"
  apply (unfold reachable_def)
  apply (rule_tac x = "(%i. None, %i. s)" in bexI)
  apply simp
  apply (simp add: exec_rws)
  done

lemma reachable_n:
  "\<And>A. [| reachable A s; (s,a,t) \<in> trans_of(A) |] ==> reachable A t"
  apply (unfold reachable_def exec_rws)
  apply (simp del: bex_simps)
  apply (simp (no_asm_simp) only: split_tupled_all)
  apply safe
  apply (rename_tac ex1 ex2 n)
  apply (rule_tac x = "(%i. if i<n then ex1 i else (if i=n then Some a else None) , %i. if i<Suc n then ex2 i else t)" in bexI)
   apply (rule_tac x = "Suc n" in exI)
   apply (simp (no_asm))
  apply simp
  apply (metis ioa_triple_proj less_antisym)
  done

lemma invariantI:
  assumes p1: "\<And>s. s \<in> starts_of(A) \<Longrightarrow> P(s)"
    and p2: "\<And>s t a. [|reachable A s; P(s)|] ==> (s,a,t) \<in> trans_of(A) \<longrightarrow> P(t)"
  shows "invariant A P"
  apply (unfold invariant_def reachable_def Let_def exec_rws)
  apply safe
  apply (rename_tac ex1 ex2 n)
  apply (rule_tac Q = "reachable A (ex2 n) " in conjunct1)
  apply simp
  apply (induct_tac n)
   apply (fast intro: p1 reachable_0)
  apply (erule_tac x = na in allE)
  apply (case_tac "ex1 na", simp_all)
  apply safe
   apply (erule p2 [THEN mp])
    apply (fast dest: reachable_n)+
  done

lemma invariantI1:
 "[| \<And>s. s \<in> starts_of(A) \<Longrightarrow> P(s);
     \<And>s t a. reachable A s \<Longrightarrow> P(s) \<longrightarrow> (s,a,t) \<in> trans_of(A) \<longrightarrow> P(t)
  |] ==> invariant A P"
  apply (blast intro!: invariantI)
  done

lemma invariantE:
  "[| invariant A P; reachable A s |] ==> P(s)"
  apply (unfold invariant_def)
  apply blast
  done

lemma actions_asig_comp:
  "actions(asig_comp a b) = actions(a) \<union> actions(b)"
  apply (auto simp add: actions_def asig_comp_def asig_projections)
  done

lemma starts_of_par:
  "starts_of(A || B) = {p. fst(p) \<in> starts_of(A) \<and> snd(p) \<in> starts_of(B)}"
  apply (simp add: par_def ioa_projections)
  done

(* Every state in an execution is reachable *)
lemma states_of_exec_reachable:
  "ex \<in> executions(A) \<Longrightarrow> \<forall>n. reachable A (snd ex n)"
  apply (unfold reachable_def)
  apply fast
  done

lemma trans_of_par4:
"(s,a,t) \<in> trans_of(A || B || C || D) =
  ((a \<in> actions(asig_of(A)) | a \<in> actions(asig_of(B)) | a \<in> actions(asig_of(C)) |
    a \<in> actions(asig_of(D))) \<and>
   (if a \<in> actions(asig_of(A)) then (fst(s),a,fst(t)) \<in> trans_of(A)
    else fst t=fst s) \<and>
   (if a \<in> actions(asig_of(B)) then (fst(snd(s)),a,fst(snd(t))) \<in> trans_of(B)
    else fst(snd(t))=fst(snd(s))) \<and>
   (if a \<in> actions(asig_of(C)) then
      (fst(snd(snd(s))),a,fst(snd(snd(t)))) \<in> trans_of(C)
    else fst(snd(snd(t)))=fst(snd(snd(s)))) \<and>
   (if a \<in> actions(asig_of(D)) then
      (snd(snd(snd(s))),a,snd(snd(snd(t)))) \<in> trans_of(D)
    else snd(snd(snd(t)))=snd(snd(snd(s)))))"
  (*SLOW*)
  apply (simp (no_asm) add: par_def actions_asig_comp prod_eq_iff ioa_projections)
  done

lemma cancel_restrict: "starts_of(restrict ioa acts) = starts_of(ioa) &
              trans_of(restrict ioa acts) = trans_of(ioa) &
              reachable (restrict ioa acts) s = reachable ioa s"
  apply (simp add: is_execution_fragment_def executions_def
    reachable_def restrict_def ioa_projections)
  done

lemma asig_of_par: "asig_of(A || B) = asig_comp (asig_of A) (asig_of B)"
  apply (simp add: par_def ioa_projections)
  done

lemma externals_of_par: "externals(asig_of(A1||A2)) =
   (externals(asig_of(A1)) \<union> externals(asig_of(A2)))"
  apply (simp add: externals_def asig_of_par asig_comp_def
    asig_inputs_def asig_outputs_def Un_def set_diff_eq)
  apply blast
  done

lemma ext1_is_not_int2:
  "[| compat_ioas A1 A2; a \<in> externals(asig_of(A1))|] ==> a \<notin> internals(asig_of(A2))"
  apply (unfold externals_def actions_def compat_ioas_def compat_asigs_def)
  apply auto
  done

lemma ext2_is_not_int1:
 "[| compat_ioas A2 A1 ; a \<in> externals(asig_of(A1))|] ==> a \<notin> internals(asig_of(A2))"
  apply (unfold externals_def actions_def compat_ioas_def compat_asigs_def)
  apply auto
  done

lemmas ext1_ext2_is_not_act2 = ext1_is_not_int2 [THEN int_and_ext_is_act]
  and ext1_ext2_is_not_act1 = ext2_is_not_int1 [THEN int_and_ext_is_act]

end


section \<open> Concurrent Programming \<close>

theory utp_concurrency
  imports utp_rel_laws
begin

text \<open> In this theory we describe the UTP scheme for concurrency, \emph{parallel-by-merge},
  which provides a general parallel operator parametrised by a ``merge predicate'' that explains
  how to merge the after states of the composed predicates. It can thus be applied to many languages
  and concurrency schemes, with this theory providing a number of generic laws. The operator is
  explained in more detail in Chapter 7 of the UTP book~\cite{Hoare&98}. \<close>

subsection \<open> Variable Renamings \<close>

text \<open> In parallel-by-merge constructions, a merge predicate defines the behaviour following execution of
  of parallel processes, $P \parallel Q$, as a relation that merges the output of $P$ and $Q$. In order
  to achieve this we need to separate the variable values output from $P$ and $Q$, and in addition the
  variable values before execution. The following three constructs do these separations. The initial
  state-space before execution is @{typ "'\<alpha>"}, the final state-space after the first parallel process
  is @{typ "'\<beta>\<^sub>0"}, and the final state-space for the second is @{typ "'\<beta>\<^sub>1"}. These three functions
  lift variables on these three state-spaces, respectively.
\<close>

alphabet ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg =
  mrg_prior :: "'\<alpha>"
  mrg_left  :: "'\<beta>\<^sub>0"
  mrg_right  :: "'\<beta>\<^sub>1"

text \<open> We set up syntax for the three variable classes. \<close>

syntax
  "_svarprior" :: "svid" ("<")
  "_svarl"     :: "svid" ("0")
  "_svarr"     :: "svid" ("1")

translations
  "_svarprior"   == "CONST mrg_prior"
  "_svarl"       == "CONST mrg_left"
  "_svarr"       == "CONST mrg_right"

subsection \<open> Merge Predicates \<close>

text \<open> A merge predicate is a relation whose input has three parts: the prior variables, the output
  variables of the left predicate, and the output of the right predicate. \<close>

type_synonym '\<alpha> merge = "(('\<alpha>, '\<alpha>, '\<alpha>) mrg, '\<alpha>) urel"

text \<open> skip is the merge predicate which ignores the output of both parallel predicates \<close>

definition skip\<^sub>m :: "'\<alpha> merge" where
[pred, rel]: "skip\<^sub>m = ($\<^bold>v\<^sup>> = $<:\<^bold>v\<^sup><)\<^sub>e"

text \<open> swap is a predicate that the swaps the left and right indices; it is used to specify
        commutativity of the parallel operator \<close>

definition swap\<^sub>m :: "(('\<alpha>, '\<beta>, '\<beta>) mrg) hrel" where
[pred, rel]: "swap\<^sub>m = (0:\<^bold>v,1:\<^bold>v) := ($1:\<^bold>v,$0:\<^bold>v)"

text \<open> A symmetric merge is one for which swapping the order of the merged concurrent predicates
  has no effect. We represent this by the following healthiness condition that states that
  @{term "swap\<^sub>m"} is a left-unit. \<close>

abbreviation SymMerge :: "'\<alpha> merge \<Rightarrow> '\<alpha> merge" where
"SymMerge(M) \<equiv> (swap\<^sub>m ;; M)"

subsection \<open> Separating Simulations \<close>

text \<open> U0 and U1 are relations modify the variables of the input state-space such that they become
  indexed with $0$ and $1$, respectively. \<close>

definition U0 :: "('\<beta>\<^sub>0, ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg) urel" where
[pred, rel]: "U0 = ($0:\<^bold>v\<^sup>> = $\<^bold>v\<^sup><)\<^sub>e"

definition U1 :: "('\<beta>\<^sub>1, ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg) urel" where
[pred, rel]: "U1 = ($1:\<^bold>v\<^sup>> = $\<^bold>v\<^sup><)\<^sub>e"

lemma U0_swap: "(U0 ;; swap\<^sub>m) = U1"
  by (pred_auto)

lemma U1_swap: "(U1 ;; swap\<^sub>m) = U0"
  by (pred_auto)

text \<open> As shown below, separating simulations can also be expressed using the following two
  alphabet extrusions \<close>

definition U0\<alpha> :: "'a \<times> 'b \<Longrightarrow> 'a \<times> ('c, 'b, 'd) mrg" where [pred, rel]: "U0\<alpha> = (1\<^sub>L \<times>\<^sub>L mrg_left)"

definition U1\<alpha> where [pred, rel]: "U1\<alpha> = (1\<^sub>L \<times>\<^sub>L mrg_right)"

text \<open> We then create the following intuitive syntax for separating simulations. \<close>

abbreviation U0_alpha_lift :: "('s\<^sub>1, 's\<^sub>2) urel \<Rightarrow> ('s\<^sub>1, (_, 's\<^sub>2, _) mrg) urel" ("\<lceil>_\<rceil>\<^sub>0")
  where "\<lceil>P\<rceil>\<^sub>0 \<equiv> (U0\<alpha>\<^sup>\<up>) \<dagger> P"

abbreviation U1_alpha_lift :: "('s\<^sub>1, 's\<^sub>2) urel \<Rightarrow> ('s\<^sub>1, (_, _, 's\<^sub>2) mrg) urel" ("\<lceil>_\<rceil>\<^sub>1")
  where "\<lceil>P\<rceil>\<^sub>1 \<equiv> (U1\<alpha>\<^sup>\<up>) \<dagger> P"

text \<open> @{term "\<lceil>P\<rceil>\<^sub>0"} is predicate $P$ where all variables are indexed by $0$, and
  @{term "\<lceil>P\<rceil>\<^sub>1"} is where all variables are indexed by $1$. We can thus equivalently express separating
  simulations using alphabet extrusion. \<close>

lemma U0_as_alpha: "(P ;; U0) = \<lceil>P\<rceil>\<^sub>0"
  by (pred_auto)

lemma U1_as_alpha: "(P ;; U1) = \<lceil>P\<rceil>\<^sub>1"
  by (pred_auto)

lemma U0\<alpha>_vwb_lens [simp]: "vwb_lens U0\<alpha>"
  by (simp add: U0\<alpha>_def prod_vwb_lens)

lemma U1\<alpha>_vwb_lens [simp]: "vwb_lens U1\<alpha>"
  by (simp add: U1\<alpha>_def prod_vwb_lens)

lemma U0\<alpha>_indep_right_uvar [simp]: "vwb_lens x \<Longrightarrow> U0\<alpha> \<bowtie> (1:x\<^sup>>)\<^sub>v"
  by (simp add: U0\<alpha>_def prod_as_plus lens_indep_right_ext ns_alpha_def)

lemma U1\<alpha>_indep_left_uvar [simp]: "vwb_lens x \<Longrightarrow> U1\<alpha> \<bowtie> (0:x\<^sup>>)\<^sub>v"
  by (simp add: U1\<alpha>_def prod_as_plus lens_indep_right_ext ns_alpha_def)

lemma U0_alpha_lift_subst [usubst]:
  "\<sigma>(0:x\<^sup>> \<leadsto> \<guillemotleft>v\<guillemotright>) \<dagger> \<lceil>P\<rceil>\<^sub>0 = \<sigma> \<dagger> \<lceil>P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<^sup>>\<rbrakk>\<rceil>\<^sub>0"
  by pred_auto

lemma U1_alpha_lift_subst [usubst]:
  "\<sigma>(1:x\<^sup>> \<leadsto> \<guillemotleft>v\<guillemotright>) \<dagger> \<lceil>P\<rceil>\<^sub>1 = \<sigma> \<dagger> \<lceil>P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<^sup>>\<rbrakk>\<rceil>\<^sub>1"
  by pred_auto

lemma U0_alpha_out_var [usubst]: "\<lceil>($x\<^sup>>)\<^sub>e\<rceil>\<^sub>0 = ($0:x\<^sup>>)\<^sub>e"
  by (pred_auto)

lemma U1_alpha_out_var [usubst]: "\<lceil>($x\<^sup>>)\<^sub>e\<rceil>\<^sub>1 = ($1:x\<^sup>>)\<^sub>e"
  by (pred_auto)

lemma U0_skip [usubst]: "\<lceil>II\<rceil>\<^sub>0 = ($0:\<^bold>v\<^sup>> = $\<^bold>v\<^sup><)\<^sub>e"
  by (pred_auto)

lemma U1_skip [usubst]: "\<lceil>II\<rceil>\<^sub>1 = ($1:\<^bold>v\<^sup>> = $\<^bold>v\<^sup><)\<^sub>e"
  by (pred_auto)

lemma U0_seqr [usubst]: "\<lceil>P ;; Q\<rceil>\<^sub>0 = P ;; \<lceil>Q\<rceil>\<^sub>0"
  by (pred_auto)

lemma U1_seqr [usubst]: "\<lceil>P ;; Q\<rceil>\<^sub>1 = P ;; \<lceil>Q\<rceil>\<^sub>1"
  by (pred_auto)

lemma U0\<alpha>_comp_in_var [usubst]: "(x\<^sup><)\<^sub>v ;\<^sub>L U0\<alpha> = (x\<^sup><)\<^sub>v"
  by (simp add: U0\<alpha>_def prod_as_plus lens_indep_right_ext ns_alpha_def lens_comp_assoc[THEN sym] fst_lens_plus comp_vwb_lens)

lemma U0\<alpha>_comp_out_var [usubst]: "(x\<^sup>>)\<^sub>v ;\<^sub>L U0\<alpha> = (0:x\<^sup>>)\<^sub>v"
  by (simp add: U0\<alpha>_def prod_as_plus lens_indep_right_ext ns_alpha_def lens_comp_assoc[THEN sym] snd_lens_plus)

lemma U1\<alpha>_comp_in_var [usubst]: "(x\<^sup><)\<^sub>v ;\<^sub>L U1\<alpha> = (x\<^sup><)\<^sub>v"
  by (simp add: U1\<alpha>_def prod_as_plus lens_indep_right_ext ns_alpha_def lens_comp_assoc[THEN sym] fst_lens_plus comp_vwb_lens)

lemma U1\<alpha>_comp_out_var [usubst]: "(x\<^sup>>)\<^sub>v ;\<^sub>L U1\<alpha> = (1:x\<^sup>>)\<^sub>v"
  by (simp add: U1\<alpha>_def prod_as_plus lens_indep_right_ext ns_alpha_def lens_comp_assoc[THEN sym] snd_lens_plus)

subsection \<open> Associative Merges \<close>

text \<open> Associativity of a merge means that if we construct a three way merge from a two way merge
  and then rotate the three inputs of the merge to the left, then we get exactly the same three
  way merge back.

  We first construct the operator that constructs the three way merge by effectively wiring up
  the two way merge in an appropriate way.
\<close>

definition ThreeWayMerge :: "'\<alpha> merge \<Rightarrow> (('\<alpha>, '\<alpha>, ('\<alpha>, '\<alpha>, '\<alpha>) mrg) mrg, '\<alpha>) urel" ("\<^bold>M3'(_')") where
[pred, rel]: "ThreeWayMerge M = (($0:\<^bold>v\<^sup>> = $0:\<^bold>v\<^sup>< \<and> $1:\<^bold>v\<^sup>> = $1:0:\<^bold>v\<^sup>< \<and> $<:\<^bold>v\<^sup>> = $<:\<^bold>v\<^sup><)\<^sub>e ;; M ;; U0 \<and> ($1:\<^bold>v\<^sup>> = $1:1:\<^bold>v\<^sup>< \<and> $<:\<^bold>v\<^sup>> = $<:\<^bold>v\<^sup><)\<^sub>e) ;; M"

text \<open> The next definition rotates the inputs to a three way merge to the left one place. \<close>

abbreviation rotate\<^sub>m where "rotate\<^sub>m \<equiv> (0:\<^bold>v,1:0:\<^bold>v,1:1:\<^bold>v) := ($1:0:\<^bold>v,$1:1:\<^bold>v,$0:\<^bold>v)"

text \<open> Finally, a merge is associative if rotating the inputs does not effect the output. \<close>

definition AssocMerge :: "'\<alpha> merge \<Rightarrow> bool" where
[pred, rel]: "AssocMerge M = (rotate\<^sub>m ;; \<^bold>M3(M) = \<^bold>M3(M))"

subsection \<open> Parallel Operators \<close>

text \<open> We implement the following useful abbreviation for separating of two parallel processes and
  copying of the before variables, all to act as input to the merge predicate. \<close>

abbreviation par_sep (infixr "\<parallel>\<^sub>s" 85) where
"P \<parallel>\<^sub>s Q \<equiv> (P ;; U0) \<and> (Q ;; U1) \<and> ($<\<^sup>> = $\<^bold>v\<^sup><)\<^sub>e"

text \<open> The following implementation of parallel by merge is less general than the book version, in
  that it does not properly partition the alphabet into two disjoint segments. We could actually
  achieve this specifying lenses into the larger alphabet, but this would complicate the definition
  of programs. \<close>

definition
  par_by_merge :: "('\<alpha>, '\<beta>) urel \<Rightarrow> (('\<alpha>, '\<beta>, '\<gamma>) mrg, '\<delta>) urel \<Rightarrow> ('\<alpha>, '\<gamma>) urel \<Rightarrow> ('\<alpha>, '\<delta>) urel"
  ("_ \<parallel>\<^bsub>_\<^esub> _" [85,0,86] 85)
where [pred, rel]: "P \<parallel>\<^bsub>M\<^esub> Q = (P \<parallel>\<^sub>s Q ;; M)"

lemma par_by_merge_alt_def: "P \<parallel>\<^bsub>M\<^esub> Q = (\<lceil>P\<rceil>\<^sub>0 \<and> \<lceil>Q\<rceil>\<^sub>1 \<and> ($<\<^sup>> = $\<^bold>v\<^sup><)\<^sub>e) ;; M"
  by (simp add: par_by_merge_def U0_as_alpha U1_as_alpha)

(*
lemma shEx_pbm_left: "((\<exists> x. P x)\<^sub>e \<parallel>\<^bsub>M\<^esub> Q) = (\<^bold>\<exists> x \<bullet> (P x \<parallel>\<^bsub>M\<^esub> Q))"
  by (pred_auto)

lemma shEx_pbm_right: "(P \<parallel>\<^bsub>M\<^esub> (\<^bold>\<exists> x \<bullet> Q x)) = (\<^bold>\<exists> x \<bullet> (P \<parallel>\<^bsub>M\<^esub> Q x))"
  by (pred_auto)
*)

subsection \<open> Unrestriction Laws \<close>

lemma unrest_in_par_by_merge [unrest]:
  "\<lbrakk> vwb_lens x; $x\<^sup>< \<sharp> P; $<:x\<^sup>< \<sharp> M; $x\<^sup>< \<sharp> Q \<rbrakk> \<Longrightarrow> $x\<^sup>< \<sharp> P \<parallel>\<^bsub>M\<^esub> Q"
  by (pred_auto, blast, metis)

(*
lemma unrest_out_par_by_merge [unrest]:
  "\<lbrakk> $x\<^sup>> \<sharp> M \<rbrakk> \<Longrightarrow> $x\<^sup>> \<sharp> P \<parallel>\<^bsub>M\<^esub> Q"

lemma unrest_merge_vars [unrest]: "$1:x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>0" "$<:x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>0" "$0:x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>1" "$<:x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>1"
  by (pred_auto)+

subsection \<open> Substitution laws \<close>

text \<open> Substitution is a little tricky because when we push the expression through the composition
  operator the alphabet of the expression must also change. Consequently for now we only support
  literal substitution, though this could be generalised with suitable alphabet coercsions. We
  need quite a number of variants to support this which are below. \<close>

lemma U0_seq_subst: "(P ;; U0)\<lbrakk>\<guillemotleft>v\<guillemotright>/0:x\<^sup>>\<rbrakk> = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<^sup>>\<rbrakk> ;; U0)"
  by (pred_auto)

lemma U1_seq_subst: "(P ;; U1)\<lbrakk>\<guillemotleft>v\<guillemotright>/1:x\<^sup>>\<rbrakk> = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<^sup>>\<rbrakk> ;; U1)"
  by (pred_auto)

lemma lit_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>\<guillemotleft>v\<guillemotright>/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (pred_auto)+

lemma bool_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s false) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>false/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>false/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>false/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s true) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>true/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>true/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>true/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s false) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>false/$x\<acute>\<rbrakk>\<^esub> Q)"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s true) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>true/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (pred_auto)+

lemma zero_one_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 0) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>0/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>0/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>0/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 1) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>1/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>1/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>1/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 0) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>0/$x\<acute>\<rbrakk>\<^esub> Q)"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 1) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>1/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (pred_auto)+

lemma numeral_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s numeral n) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>numeral n/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>numeral n/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>numeral n/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s numeral n) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>numeral n/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (pred_auto)+
*)

subsection \<open> Parallel-by-merge laws \<close>

lemma par_by_merge_false [simp]:
  "P \<parallel>\<^bsub>false\<^esub> Q = false"
  by (pred_auto)

lemma par_by_merge_left_false [simp]:
  "false \<parallel>\<^bsub>M\<^esub> Q = false"
  by (pred_auto)

lemma par_by_merge_right_false [simp]:
  "P \<parallel>\<^bsub>M\<^esub> false = false"
  by (pred_auto)

lemma par_by_merge_seq_add: "(P \<parallel>\<^bsub>M\<^esub> Q) ;; R = (P \<parallel>\<^bsub>M ;; R\<^esub> Q)"
  by (simp add: par_by_merge_def seqr_assoc)

text \<open> A skip parallel-by-merge yields a skip whenever the parallel predicates are both feasible. \<close>

lemma par_by_merge_skip:
  assumes "P ;; true = true" "Q ;; true = true"
  shows "P \<parallel>\<^bsub>skip\<^sub>m\<^esub> Q = II"
  using assms by (pred_auto)

lemma skip_merge_swap: "swap\<^sub>m ;; skip\<^sub>m = skip\<^sub>m"
  by (pred_auto)

lemma par_sep_swap: "P \<parallel>\<^sub>s Q ;; swap\<^sub>m = Q \<parallel>\<^sub>s P"
  by (pred_auto)

end


header "Implementing Labelled Transition Systems by Maps"
theory LTSByTripleSetQQA
imports TripleSetSpec LTSSpec LTSGA
begin

locale ltsbm_QQA_defs =
  ts: triple_set ts_\<alpha> ts_invar
  for ts_\<alpha>::"'ts \<Rightarrow> ('Q \<times> 'Q \<times> 'A) set"
  and ts_invar
begin
  definition ltsbm_\<alpha> :: "('Q,'A,'ts) lts_\<alpha>" where
    "ltsbm_\<alpha> ts \<equiv> (\<lambda>(q, q', a). (q, a, q')) ` (ts_\<alpha> ts)"

  lemma ltsbm_\<alpha>_alt_def :
    "ltsbm_\<alpha> ts = {(q, a, q') . (q, q', a) \<in> ts_\<alpha> ts}"
  unfolding ltsbm_\<alpha>_def
  by (auto simp add: image_iff set_eq_iff Bex_def)

  definition "ltsbm_invar \<equiv> ts_invar"

  lemma ltsbm_empty_correct:
    "triple_set_empty ts_\<alpha> ts_invar emp \<Longrightarrow>
     lts_empty ltsbm_\<alpha> ltsbm_invar emp"
    unfolding lts_empty_def ltsbm_\<alpha>_def ltsbm_invar_def triple_set_empty_def
    by simp

  definition ltsbm_memb :: "_ \<Rightarrow> ('Q,'A,'ts) lts_memb" where
    "ltsbm_memb memb ts q a q' \<equiv> memb ts q q' a"

  lemma ltsbm_memb_correct:
    "triple_set_memb ts_\<alpha> ts_invar memb \<Longrightarrow>
     lts_memb ltsbm_\<alpha> ltsbm_invar (ltsbm_memb memb)"
  unfolding lts_memb_def ltsbm_memb_def ltsbm_invar_def ltsbm_\<alpha>_def triple_set_memb_def
  by (simp add: image_iff Bex_def)

  definition ltsbm_add :: "_ \<Rightarrow> ('Q,'A,'ts) lts_add" where
    "ltsbm_add ts_add q a q' ts \<equiv> ts_add q q' a ts"

  lemma ltsbm_add_correct:
    "triple_set_add ts_\<alpha> ts_invar add \<Longrightarrow>
     lts_add ltsbm_\<alpha> ltsbm_invar (ltsbm_add add)"
  unfolding lts_add_def ltsbm_add_def ltsbm_invar_def ltsbm_\<alpha>_def triple_set_add_def
  by simp

  definition ltsbm_add_succs :: "_ \<Rightarrow> ('Q,'A,'ts) lts_add_succs" where
    "ltsbm_add_succs add_Bl q a qs ts \<equiv> add_Bl q qs a ts"

  lemma ltsbm_add_succs_correct:
    "triple_set_add_Bl ts_\<alpha> ts_invar add_Bl \<Longrightarrow>
     lts_add_succs ltsbm_\<alpha> ltsbm_invar (ltsbm_add_succs add_Bl)"
    unfolding lts_add_succs_def ltsbm_\<alpha>_alt_def ltsbm_invar_def ltsbm_add_succs_def
              triple_set_add_Bl_def
    by auto

  definition ltsbm_delete :: "_ \<Rightarrow> ('Q,'A,'ts) lts_delete" where
    "ltsbm_delete ts_del q a q' ts \<equiv> ts_del q q' a ts"

  lemma ltsbm_delete_correct:
    "triple_set_delete ts_\<alpha> ts_invar ts_del \<Longrightarrow>
     lts_delete ltsbm_\<alpha> ltsbm_invar (ltsbm_delete ts_del)"
    unfolding lts_delete_def ltsbm_delete_def ltsbm_\<alpha>_alt_def ltsbm_invar_def
              triple_set_delete_def
    by auto

  lemma ltsbm_succ_it_correct :
    assumes "triple_set_B_it ts_\<alpha> ts_invar it"
    shows "lts_succ_it ltsbm_\<alpha> ltsbm_invar it"
  using assms
  unfolding lts_succ_it_def triple_set_B_it_def ltsbm_invar_def ltsbm_\<alpha>_alt_def
  by simp

  definition ltsbm_succ_label_it where
   "ltsbm_succ_label_it it (ts::'ts) (q::'Q) =
    set_iterator_image (\<lambda>(q', a). (a, q')) (it ts q)"

  lemma ltsbm_succ_label_it_correct :
    assumes BC_it: "triple_set_BC_it ts_\<alpha> ts_invar it"
    shows "lts_succ_label_it ltsbm_\<alpha> ltsbm_invar (ltsbm_succ_label_it it)"
  unfolding lts_succ_label_it_def
  proof (intro allI impI)
    fix ts q
    assume invar_ts: "ltsbm_invar ts"

    let ?S1 = "{(a, q') . (q, a, q') \<in> ltsbm_\<alpha> ts}"
    let ?S2 = "{(q', a) . (q, a, q') \<in> ltsbm_\<alpha> ts}"

    from triple_set_BC_it.triple_set_BC_it_correct [OF BC_it, of ts] invar_ts
    have step: "set_iterator (it ts q) ?S2"
      unfolding triple_set_BC_it_def ltsbm_\<alpha>_alt_def ltsbm_invar_def by simp

    show "set_iterator (ltsbm_succ_label_it it ts q) ?S1"
    unfolding ltsbm_succ_label_it_def
      apply (rule set_iterator_image_correct[OF step])
      apply (auto simp add: inj_on_def)
    done
  qed

  definition ltsbm_filter_it where
   "ltsbm_filter_it it P_q P_a P_q' (P::('Q \<times> 'A \<times> 'Q) \<Rightarrow> bool) ts =
    set_iterator_image (\<lambda>(q, q', a). (q, a, q'))
       (it P_q P_q' P_a (\<lambda>(q, q', a). P (q, a, q')) ts)"

  lemma ltsbm_filter_it_correct :
    assumes filter_it: "triple_set_filter_it ts_\<alpha> ts_invar it"
    shows "lts_filter_it ltsbm_\<alpha> ltsbm_invar (ltsbm_filter_it it)"
  unfolding lts_filter_it_def
  proof (intro allI impI)
    fix ts P_q1 P_a P_q2 P
    assume invar_ts: "ltsbm_invar ts"

    let ?P' = "\<lambda>(q::'Q, q'::'Q, a::'A). (P (q, a, q'))::bool"
    let ?S1 = "{(q1, a, q2). (q1, a, q2) \<in> ltsbm_\<alpha> ts \<and>
                     P_q1 q1 \<and> P_a a \<and> P_q2 q2 \<and> P (q1, a, q2)} "
    let ?S2 = "{(q1, q2, a). (q1, a, q2) \<in> ltsbm_\<alpha> ts \<and>
                     P_q1 q1 \<and> P_q2 q2 \<and> P_a a \<and> P (q1, a, q2)} "

    from triple_set_filter_it.triple_set_filter_it_correct [OF filter_it,
         of ts P_q1 P_q2 P_a ?P'] invar_ts
    have step: "set_iterator (it P_q1 P_q2 P_a (\<lambda>(q, q', a). P (q, a, q')) ts) ?S2"
      unfolding triple_set_BC_it_def ltsbm_\<alpha>_alt_def ltsbm_invar_def
      by simp

    show "set_iterator (ltsbm_filter_it it P_q1 P_a P_q2 P ts) ?S1"
    unfolding ltsbm_filter_it_def
      apply (rule set_iterator_image_correct[OF step])
      apply (auto simp add: inj_on_def image_iff)
    done
  qed

  definition ltsbm_it where
   "ltsbm_it it ts =
    set_iterator_image (\<lambda>(q::'Q, q'::'Q, a::'A). (q, a, q')) (it ts)"

  lemma ltsbm_it_correct :
    assumes it: "triple_set_iterator ts_\<alpha> ts_invar it"
    shows "lts_iterator ltsbm_\<alpha> ltsbm_invar (ltsbm_it it)"
  unfolding lts_iterator_def
  proof (intro allI impI)
    fix ts
    assume invar_ts: "ltsbm_invar ts"

    from triple_set_iterator.triple_set_it_correct [OF it, of ts] invar_ts
    have step: "set_iterator (it ts) {(q1, q2, a). (q1, a, q2) \<in> ltsbm_\<alpha> ts}"
      unfolding triple_set_BC_it_def ltsbm_\<alpha>_alt_def ltsbm_invar_def
      by simp

    show "set_iterator (ltsbm_it it ts) (ltsbm_\<alpha> ts)"
    unfolding ltsbm_it_def
      apply (rule set_iterator_image_correct[OF step])
      apply (auto simp add: inj_on_def image_iff)
    done
  qed

  definition ltsbm_pre_it where
   "ltsbm_pre_it it (ts::'ts) (q'::'Q) (a::'A) = it ts q' a"

  lemma ltsbm_pre_it_correct :
    assumes "triple_set_A_it ts_\<alpha> ts_invar it"
    shows "lts_pre_it ltsbm_\<alpha> ltsbm_invar (ltsbm_pre_it it)"
  using assms
  unfolding lts_pre_it_def triple_set_A_it_def ltsbm_pre_it_def ltsbm_invar_def ltsbm_\<alpha>_alt_def
  by simp

  lemma ltsbm_pre_label_it_correct :
    assumes "triple_set_AC_it ts_\<alpha> ts_invar it"
    shows "lts_pre_label_it ltsbm_\<alpha> ltsbm_invar it"
  using assms
  unfolding lts_pre_label_it_def triple_set_AC_it_def ltsbm_invar_def ltsbm_\<alpha>_alt_def
  by simp
end

end


(*  Title:       variants/d_fwdrreqs/Fresher.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
    Author:      Peter Höfner, NICTA
*)

section "Quality relations between routes"

theory D_Fresher
imports D_Aodv_Data
begin

subsection "Net sequence numbers"

subsubsection "On individual routes"

definition
  nsqn\<^sub>r :: "r \<Rightarrow> sqn"
where
  "nsqn\<^sub>r r \<equiv> if \<pi>\<^sub>4(r) = val \<or> \<pi>\<^sub>2(r) = 0 then \<pi>\<^sub>2(r) else (\<pi>\<^sub>2(r) - 1)"

lemma nsqnr_def':
  "nsqn\<^sub>r r = (if \<pi>\<^sub>4(r) = inv then \<pi>\<^sub>2(r) - 1 else \<pi>\<^sub>2(r))"
  unfolding nsqn\<^sub>r_def by simp

lemma nsqn\<^sub>r_zero [simp]:
  "\<And>dsn dsk flag hops nhip pre. nsqn\<^sub>r (0, dsk, flag, hops, nhip, pre) = 0"
  unfolding nsqn\<^sub>r_def by clarsimp

lemma nsqn\<^sub>r_val [simp]:
  "\<And>dsn dsk hops nhip pre. nsqn\<^sub>r (dsn, dsk, val, hops, nhip, pre) = dsn"
  unfolding nsqn\<^sub>r_def by clarsimp

lemma nsqn\<^sub>r_inv [simp]:
  "\<And>dsn dsk hops nhip pre. nsqn\<^sub>r (dsn, dsk, inv, hops, nhip, pre) = dsn - 1"
  unfolding nsqn\<^sub>r_def by clarsimp

lemma nsqn\<^sub>r_lte_dsn [simp]:
  "\<And>dsn dsk flag hops nhip pre. nsqn\<^sub>r (dsn, dsk, flag, hops, nhip, pre) \<le> dsn"
  unfolding nsqn\<^sub>r_def by clarsimp

subsubsection "On routes in routing tables"

definition
  nsqn :: "rt \<Rightarrow> ip \<Rightarrow> sqn"
where
  "nsqn \<equiv> \<lambda>rt dip. case \<sigma>\<^bsub>route\<^esub>(rt, dip) of None \<Rightarrow> 0 | Some r \<Rightarrow> nsqn\<^sub>r(r)"

lemma nsqn_sqn_def:
  "\<And>rt dip. nsqn rt dip = (if flag rt dip = Some val \<or> sqn rt dip = 0
                            then sqn rt dip else sqn rt dip - 1)"
  unfolding nsqn_def sqn_def by (clarsimp split: option.split)

lemma not_in_kD_nsqn [simp]:
  assumes "dip \<notin> kD(rt)"
  shows "nsqn rt dip = 0"
  using assms unfolding nsqn_def by simp

lemma nsqn\<^sub>r_addpreRT_inv [simp]:
  "\<And>rt dip npre dip'. dip \<in> kD(rt) \<Longrightarrow>
   nsqn\<^sub>r (the (the (addpreRT rt dip npre) dip')) = nsqn\<^sub>r (the (rt dip'))"
  unfolding addpreRT_def nsqn\<^sub>r_def
  by (frule kD_Some) (clarsimp split: option.split)

lemma sqn_nsqn:
  "\<And>rt dip. sqn rt dip - 1 \<le> nsqn rt dip"
  unfolding sqn_def nsqn_def by (clarsimp split: option.split)

lemma nsqn_sqn: "nsqn rt dip \<le> sqn rt dip"
  unfolding sqn_def nsqn_def by (cases "rt dip") auto

lemma val_nsqn_sqn [elim, simp]:
  assumes "ip\<in>kD(rt)"
      and "the (flag rt ip) = val"
    shows "nsqn rt ip = sqn rt ip"
  using assms unfolding nsqn_sqn_def by auto

lemma vD_nsqn_sqn [elim, simp]:
  assumes "ip\<in>vD(rt)"
    shows "nsqn rt ip = sqn rt ip"
  proof -
    from \<open>ip\<in>vD(rt)\<close> have "ip\<in>kD(rt)"
                      and "the (flag rt ip) = val" by auto
    thus ?thesis ..
  qed

lemma inv_nsqn_sqn [elim, simp]:
  assumes "ip\<in>kD(rt)"
      and "the (flag rt ip) = inv"
    shows "nsqn rt ip = sqn rt ip - 1"
  using assms unfolding nsqn_sqn_def by auto

lemma iD_nsqn_sqn [elim, simp]:
  assumes "ip\<in>iD(rt)"
    shows "nsqn rt ip = sqn rt ip - 1"
  proof -
    from \<open>ip\<in>iD(rt)\<close> have "ip\<in>kD(rt)"
                      and "the (flag rt ip) = inv" by auto
    thus ?thesis ..
  qed

lemma nsqn_update_changed_kno_val [simp]: "\<And>rt ip dsn dsk hops nhip.
  rt \<noteq> update rt ip (dsn, kno, val, hops, nhip, {})
   \<Longrightarrow> nsqn (update rt ip (dsn, kno, val, hops, nhip, {})) ip = dsn"
  unfolding nsqn\<^sub>r_def update_def
  by (clarsimp simp: kD_nsqn split: option.split_asm option.split if_split_asm)
     (metis fun_upd_triv)

lemma nsqn_addpreRT_inv [simp]:
  "\<And>rt dip npre dip'. dip \<in> kD(rt) \<Longrightarrow>
   nsqn (the (addpreRT rt dip npre)) dip' = nsqn rt dip'"
  unfolding addpreRT_def nsqn_def nsqn\<^sub>r_def
  by (frule kD_Some) (clarsimp split: option.split)

lemma nsqn_update_other [simp]:
    fixes dsn dsk flag hops dip nhip pre rt ip
  assumes "dip \<noteq> ip"
    shows "nsqn (update rt ip (dsn, dsk, flag, hops, nhip, pre)) dip = nsqn rt dip"
    using assms unfolding nsqn_def
    by (clarsimp split: option.split)

lemma nsqn_invalidate_eq:
  assumes "dip \<in> kD(rt)"
      and "dests dip = Some rsn"
    shows "nsqn (invalidate rt dests) dip = rsn - 1"
  using assms
  proof -
    from assms obtain dsk hops nhip pre
      where "invalidate rt dests dip = Some (rsn, dsk, inv, hops, nhip, pre)"
      unfolding invalidate_def
      by auto
    moreover from \<open>dip \<in> kD(rt)\<close> have "dip \<in> kD(invalidate rt dests)" by simp
    ultimately show ?thesis
      using \<open>dests dip = Some rsn\<close> by simp
  qed

lemma nsqn_invalidate_other [simp]:
  assumes "dip\<in>kD(rt)"
      and "dip\<notin>dom dests"
    shows "nsqn (invalidate rt dests) dip = nsqn rt dip"
  using assms by (clarsimp simp add: kD_nsqn)

subsection "Comparing routes "

definition
  fresher :: "r \<Rightarrow> r \<Rightarrow> bool" ("(_/ \<sqsubseteq> _)"  [51, 51] 50)
where
  "fresher r r' \<equiv> ((nsqn\<^sub>r r < nsqn\<^sub>r r') \<or> (nsqn\<^sub>r r  = nsqn\<^sub>r r' \<and> \<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r')))"

lemma fresherI1 [intro]:
  assumes "nsqn\<^sub>r r < nsqn\<^sub>r r'"
    shows "r \<sqsubseteq> r'"
  unfolding fresher_def using assms by simp

lemma fresherI2 [intro]:
  assumes "nsqn\<^sub>r r = nsqn\<^sub>r r'"
      and "\<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r')"
    shows "r \<sqsubseteq> r'"
  unfolding fresher_def using assms by simp

lemma fresherI [intro]:
  assumes "(nsqn\<^sub>r r < nsqn\<^sub>r r') \<or> (nsqn\<^sub>r r  = nsqn\<^sub>r r' \<and> \<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r'))"
    shows "r \<sqsubseteq> r'"
  unfolding fresher_def using assms .

lemma fresherE [elim]:
  assumes "r \<sqsubseteq> r'"
      and "nsqn\<^sub>r r < nsqn\<^sub>r r' \<Longrightarrow> P r r'"
      and "nsqn\<^sub>r r  = nsqn\<^sub>r r' \<and> \<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r') \<Longrightarrow> P r r'"
    shows "P r r'"
  using assms unfolding fresher_def by auto

lemma fresher_refl [simp]: "r \<sqsubseteq> r"
  unfolding fresher_def by simp

lemma fresher_trans [elim, trans]:
  "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
  unfolding fresher_def by auto

lemma not_fresher_trans [elim, trans]:
  "\<lbrakk> \<not>(x \<sqsubseteq> y); \<not>(z \<sqsubseteq> x) \<rbrakk> \<Longrightarrow> \<not>(z \<sqsubseteq> y)"
  unfolding fresher_def by auto

lemma addpre_fresher [simp]: "\<And>r npre. r \<sqsubseteq> (addpre r npre)"
  by clarsimp

subsection "Comparing routing tables "

definition
  rt_fresher :: "ip \<Rightarrow> rt \<Rightarrow> rt \<Rightarrow> bool"
where
  "rt_fresher \<equiv> \<lambda>dip rt rt'. (the (\<sigma>\<^bsub>route\<^esub>(rt, dip))) \<sqsubseteq> (the (\<sigma>\<^bsub>route\<^esub>(rt', dip)))"

abbreviation
   rt_fresher_syn :: "rt \<Rightarrow> ip \<Rightarrow> rt \<Rightarrow> bool" ("(_/ \<sqsubseteq>\<^bsub>_\<^esub> _)"  [51, 999, 51] 50)
where
  "rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2 \<equiv> rt_fresher i rt1 rt2"

lemma single_rt_fresher [intro]:
  assumes "the (rt1 ip) \<sqsubseteq> the (rt2 ip)"
    shows "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
  using assms unfolding rt_fresher_def .

lemma rt_fresher_single [intro]:
  assumes "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
    shows "the (rt1 ip) \<sqsubseteq> the (rt2 ip)"
  using assms unfolding rt_fresher_def .

lemma rt_fresher_def2:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
    shows "(rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2) = (nsqn rt1 dip < nsqn rt2 dip
                               \<or> (nsqn rt1 dip = nsqn rt2 dip
                                   \<and> the (dhops rt1 dip) \<ge> the (dhops rt2 dip)))"
  using assms unfolding rt_fresher_def fresher_def by (simp add: kD_nsqn proj5_eq_dhops)

lemma rt_fresherI1 [intro]:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "nsqn rt1 dip < nsqn rt2 dip"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
  unfolding rt_fresher_def2 [OF assms(1-2)] using assms(3) by simp

lemma rt_fresherI2 [intro]:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "nsqn rt1 dip = nsqn rt2 dip"
      and "the (dhops rt1 dip) \<ge> the (dhops rt2 dip)"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
  unfolding rt_fresher_def2 [OF assms(1-2)] using assms(3-4) by simp

lemma rt_fresherE [elim]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "\<lbrakk> nsqn rt1 dip < nsqn rt2 dip \<rbrakk> \<Longrightarrow> P rt1 rt2 dip"
      and "\<lbrakk> nsqn rt1 dip = nsqn rt2 dip;
             the (dhops rt1 dip) \<ge> the (dhops rt2 dip) \<rbrakk> \<Longrightarrow> P rt1 rt2 dip"
    shows "P rt1 rt2 dip"
  using assms(1) unfolding rt_fresher_def2 [OF assms(2-3)]
  using assms(4-5) by auto

lemma rt_fresher_refl [simp]: "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt"
  unfolding rt_fresher_def by simp

lemma rt_fresher_trans [elim, trans]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
  using assms unfolding rt_fresher_def by auto

lemma rt_fresher_if_Some [intro!]:
  assumes "the (rt dip) \<sqsubseteq> r"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> (\<lambda>ip. if ip = dip then Some r else rt ip)"
  using assms unfolding rt_fresher_def by simp

definition rt_fresh_as :: "ip \<Rightarrow> rt \<Rightarrow> rt \<Rightarrow> bool"
where
  "rt_fresh_as \<equiv> \<lambda>dip rt1 rt2. (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2) \<and> (rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"

abbreviation
   rt_fresh_as_syn :: "rt \<Rightarrow> ip \<Rightarrow> rt \<Rightarrow> bool" ("(_/ \<approx>\<^bsub>_\<^esub> _)"  [51, 999, 51] 50)
where
  "rt1 \<approx>\<^bsub>i\<^esub> rt2 \<equiv> rt_fresh_as i rt1 rt2"

lemma rt_fresh_as_refl [simp]: "\<And>rt dip. rt \<approx>\<^bsub>dip\<^esub> rt"
  unfolding rt_fresh_as_def by simp

lemma rt_fresh_as_trans [simp, intro, trans]:
  "\<And>rt1 rt2 rt3 dip. \<lbrakk> rt1 \<approx>\<^bsub>dip\<^esub> rt2; rt2 \<approx>\<^bsub>dip\<^esub> rt3 \<rbrakk> \<Longrightarrow> rt1 \<approx>\<^bsub>dip\<^esub> rt3"
  unfolding rt_fresh_as_def rt_fresher_def
  by (metis (mono_tags) fresher_trans)

lemma rt_fresh_asI [intro!]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
    shows "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_as_fresherI [intro]:
  assumes "dip\<in>kD(rt1)"
      and "dip\<in>kD(rt2)"
      and "the (rt1 dip) \<sqsubseteq> the (rt2 dip)"
      and "the (rt2 dip) \<sqsubseteq> the (rt1 dip)"
    shows "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_fresh_as_def
  by (clarsimp dest!: single_rt_fresher)

lemma nsqn_rt_fresh_asI:
  assumes "dip \<in> kD(rt)"
      and "dip \<in> kD(rt')"
      and "nsqn rt dip = nsqn rt' dip"
      and "\<pi>\<^sub>5(the (rt dip)) = \<pi>\<^sub>5(the (rt' dip))"
    shows "rt \<approx>\<^bsub>dip\<^esub> rt'"
  proof
    from assms(1-2,4) have dhops': "the (dhops rt' dip) \<le> the (dhops rt dip)"
      by (simp add: proj5_eq_dhops)
    with assms(1-3) show "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt'"
      by (rule rt_fresherI2)
  next
    from assms(1-2,4) have dhops: "the (dhops rt dip) \<le> the (dhops rt' dip)"
      by (simp add: proj5_eq_dhops)
    with assms(2,1) assms(3) [symmetric] show "rt' \<sqsubseteq>\<^bsub>dip\<^esub> rt"
      by (rule rt_fresherI2)
  qed

lemma rt_fresh_asE [elim]:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
      and "\<lbrakk> rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2; rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1 \<rbrakk> \<Longrightarrow> P rt1 rt2 dip"
    shows "P rt1 rt2 dip"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_asD1 [dest]:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_asD2 [dest]:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_as_sym:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "rt2 \<approx>\<^bsub>dip\<^esub> rt1"
  using assms unfolding rt_fresh_as_def by simp

lemma not_rt_fresh_asI1 [intro]:
  assumes "\<not> (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)"
    shows "\<not> (rt1 \<approx>\<^bsub>dip\<^esub> rt2)"
  proof
    assume "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    hence "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2" ..
    with \<open>\<not> (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)\<close> show False ..
  qed

lemma not_rt_fresh_asI2 [intro]:
  assumes "\<not> (rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
    shows "\<not> (rt1 \<approx>\<^bsub>dip\<^esub> rt2)"
  proof
    assume "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    hence "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1" ..
    with \<open>\<not> (rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)\<close> show False ..
  qed

lemma not_single_rt_fresher [elim]:
  assumes "\<not>(the (rt1 ip) \<sqsubseteq> the (rt2 ip))"
    shows "\<not>(rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2)"
  proof
    assume "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
    hence "the (rt1 ip) \<sqsubseteq> the (rt2 ip)" ..
    with \<open>\<not>(the (rt1 ip) \<sqsubseteq> the (rt2 ip))\<close> show False ..
  qed

lemmas not_single_rt_fresh_asI1 [intro] =  not_rt_fresh_asI1 [OF not_single_rt_fresher]
lemmas not_single_rt_fresh_asI2 [intro] =  not_rt_fresh_asI2 [OF not_single_rt_fresher]

lemma not_rt_fresher_single [elim]:
  assumes "\<not>(rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2)"
    shows "\<not>(the (rt1 ip) \<sqsubseteq> the (rt2 ip))"
  proof
    assume "the (rt1 ip) \<sqsubseteq> the (rt2 ip)"
    hence "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2" ..
    with \<open>\<not>(rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2)\<close> show False ..
  qed

lemma rt_fresh_as_nsqnr:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "nsqn\<^sub>r (the (rt2 dip)) = nsqn\<^sub>r (the (rt1 dip))"
  using assms(3) unfolding rt_fresh_as_def
  by (auto simp: rt_fresher_def2 [OF \<open>dip \<in> kD(rt1)\<close> \<open>dip \<in> kD(rt2)\<close>]
                 rt_fresher_def2 [OF \<open>dip \<in> kD(rt2)\<close> \<open>dip \<in> kD(rt1)\<close>]
                 kD_nsqn [OF \<open>dip \<in> kD(rt1)\<close>]
                 kD_nsqn [OF \<open>dip \<in> kD(rt2)\<close>])

lemma rt_fresher_mapupd [intro!]:
  assumes "dip\<in>kD(rt)"
      and "the (rt dip) \<sqsubseteq> r"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt(dip \<mapsto> r)"
  using assms unfolding rt_fresher_def by simp

lemma rt_fresher_map_update_other [intro!]:
  assumes "dip\<in>kD(rt)"
      and "dip \<noteq> ip"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt(ip \<mapsto> r)"
  using assms unfolding rt_fresher_def by simp

lemma rt_fresher_update_other [simp]:
  assumes inkD: "dip\<in>kD(rt)"
     and "dip \<noteq> ip"
   shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> update rt ip r"
   using assms unfolding update_def
   by (clarsimp split: option.split) (fastforce)

theorem rt_fresher_update [simp]:
  assumes "dip\<in>kD(rt)"
      and "the (dhops rt dip) \<ge> 1"
      and "update_arg_wf r"
   shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> update rt ip r"
  proof (cases "dip = ip")
    assume "dip \<noteq> ip" with \<open>dip\<in>kD(rt)\<close> show ?thesis
      by (rule rt_fresher_update_other)
  next
    assume "dip = ip"

    from \<open>dip\<in>kD(rt)\<close> obtain dsn\<^sub>n dsk\<^sub>n f\<^sub>n hops\<^sub>n nhip\<^sub>n pre\<^sub>n
      where rtn [simp]: "the (rt dip) = (dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n, pre\<^sub>n)"
      by (metis prod_cases6)
    with \<open>the (dhops rt dip) \<ge> 1\<close> and \<open>dip\<in>kD(rt)\<close> have "hops\<^sub>n \<ge> 1"
      by (metis proj5_eq_dhops projs(4))
    from \<open>dip\<in>kD(rt)\<close> rtn have [simp]: "sqn rt dip = dsn\<^sub>n"
                           and [simp]: "the (dhops rt dip) = hops\<^sub>n"
                           and [simp]: "the (flag rt dip) = f\<^sub>n"
      by (simp add: sqn_def proj5_eq_dhops [symmetric]
                            proj4_eq_flag [symmetric])+

    from \<open>update_arg_wf r\<close> have "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n, pre\<^sub>n)
                                  \<sqsubseteq> the ((update rt dip r) dip)"
      proof (rule wf_r_cases)
        fix nhip pre
        from \<open>hops\<^sub>n \<ge> 1\<close> have "\<And>pre'. (dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n, pre\<^sub>n)
                                        \<sqsubseteq> (dsn\<^sub>n, unk, val, Suc 0, nhip, pre')"
          unfolding fresher_def sqn_def by (cases f\<^sub>n) auto
        thus "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n, pre\<^sub>n)
               \<sqsubseteq> the (update rt dip (0, unk, val, Suc 0, nhip, pre) dip)"
          using \<open>dip\<in>kD(rt)\<close> by - (rule update_cases_kD, simp_all)
      next
        fix dsn :: sqn and hops nhip pre
        assume "0 < dsn"
        show "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n, pre\<^sub>n)
               \<sqsubseteq> the (update rt dip (dsn, kno, val, hops, nhip, pre) dip)"
        proof (rule update_cases_kD [OF _ \<open>dip\<in>kD(rt)\<close>], simp_all add: \<open>0 < dsn\<close>)
          assume "dsn\<^sub>n < dsn"
            thus "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n, pre\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip, pre \<union> pre\<^sub>n)"
              unfolding fresher_def by auto
        next
          assume "dsn\<^sub>n = dsn"
             and "hops < hops\<^sub>n"
            thus "(dsn, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n, pre\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip, pre \<union> pre\<^sub>n)"
              unfolding fresher_def nsqn\<^sub>r_def by simp
        next
          assume "dsn\<^sub>n = dsn"
            with \<open>0 < dsn\<close>
            show "(dsn, dsk\<^sub>n, inv, hops\<^sub>n, nhip\<^sub>n, pre\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip, pre \<union> pre\<^sub>n)"
              unfolding fresher_def by simp
        qed
      qed
    hence "rt \<sqsubseteq>\<^bsub>dip\<^esub> update rt dip r"
      by - (rule single_rt_fresher, simp)
    with \<open>dip = ip\<close> show ?thesis by simp
  qed

theorem rt_fresher_invalidate [simp]:
  assumes "dip\<in>kD(rt)"
      and indests: "\<forall>rip\<in>dom(dests). rip\<in>vD(rt) \<and> sqn rt rip < the (dests rip)"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> invalidate rt dests"
  proof (cases "dip\<in>dom(dests)")
    assume "dip\<notin>dom(dests)"
      thus ?thesis using \<open>dip\<in>kD(rt)\<close>
      by - (rule single_rt_fresher, simp)
  next
    assume "dip\<in>dom(dests)"
    moreover with indests have "dip\<in>vD(rt)"
                           and "sqn rt dip < the (dests dip)"
      by auto
    ultimately show ?thesis
      unfolding invalidate_def sqn_def
      by - (rule single_rt_fresher, auto simp: fresher_def)
  qed

lemma nsqn\<^sub>r_invalidate [simp]:
  assumes "dip\<in>kD(rt)"
      and "dip\<in>dom(dests)"
    shows "nsqn\<^sub>r (the (invalidate rt dests dip)) = the (dests dip) - 1"
  using assms unfolding invalidate_def by auto

lemma rt_fresh_as_inc_invalidate [simp]:
  assumes "dip\<in>kD(rt)"
      and "\<forall>rip\<in>dom(dests). rip\<in>vD(rt) \<and> the (dests rip) = inc (sqn rt rip)"
    shows "rt \<approx>\<^bsub>dip\<^esub> invalidate rt dests"
  proof (cases "dip\<in>dom(dests)")
    assume "dip\<notin>dom(dests)"
    with \<open>dip\<in>kD(rt)\<close> have "dip\<in>kD(invalidate rt dests)"
      by simp
    with \<open>dip\<in>kD(rt)\<close> show ?thesis
      by rule (simp_all add: \<open>dip\<notin>dom(dests)\<close>)
  next
    assume "dip\<in>dom(dests)"
    with assms(2) have "dip\<in>vD(rt)"
                  and "the (dests dip) = inc (sqn rt dip)" by auto
    from \<open>dip\<in>vD(rt)\<close> have "dip\<in>kD(rt)" by simp
    moreover then have "dip\<in>kD(invalidate rt dests)" by simp
    ultimately show ?thesis
    proof (rule nsqn_rt_fresh_asI)
      from \<open>dip\<in>vD(rt)\<close> have "nsqn rt dip = sqn rt dip" by simp
      also have "sqn rt dip = nsqn\<^sub>r (the (invalidate rt dests dip))"
      proof -
        from \<open>dip\<in>kD(rt)\<close> have "nsqn\<^sub>r (the (invalidate rt dests dip)) = the (dests dip) - 1"
          using \<open>dip\<in>dom(dests)\<close> by (rule nsqn\<^sub>r_invalidate)
        with \<open>the (dests dip) = inc (sqn rt dip)\<close>
          show "sqn rt dip = nsqn\<^sub>r (the (invalidate rt dests dip))" by simp
      qed
      also from \<open>dip\<in>kD(invalidate rt dests)\<close>
        have "nsqn\<^sub>r (the (invalidate rt dests dip)) = nsqn (invalidate rt dests) dip"
          by (simp add: kD_nsqn)
      finally show "nsqn rt dip = nsqn (invalidate rt dests) dip" .
    qed simp
  qed

lemmas rt_fresher_inc_invalidate [simp] = rt_fresh_as_inc_invalidate [THEN rt_fresh_asD1]

lemma rt_fresh_as_addpreRT [simp]:
  assumes "ip\<in>kD(rt)"
    shows "rt \<approx>\<^bsub>dip\<^esub> the (addpreRT rt ip npre)"
  using assms [THEN kD_Some] by (auto simp: addpreRT_def)

lemmas rt_fresher_addpreRT [simp] = rt_fresh_as_addpreRT [THEN rt_fresh_asD1]

subsection "Strictly comparing routing tables "

definition rt_strictly_fresher :: "ip \<Rightarrow> rt \<Rightarrow> rt \<Rightarrow> bool"
where
  "rt_strictly_fresher \<equiv> \<lambda>dip rt1 rt2. (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2) \<and> \<not>(rt1 \<approx>\<^bsub>dip\<^esub> rt2)"

abbreviation
   rt_strictly_fresher_syn :: "rt \<Rightarrow> ip \<Rightarrow> rt \<Rightarrow> bool" ("(_/ \<sqsubset>\<^bsub>_\<^esub> _)"  [51, 999, 51] 50)
where
  "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2 \<equiv> rt_strictly_fresher i rt1 rt2"

lemma rt_strictly_fresher_def'':
  "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2 = ((rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2) \<and> \<not>(rt2 \<sqsubseteq>\<^bsub>i\<^esub> rt1))"
  unfolding rt_strictly_fresher_def rt_fresh_as_def by auto

lemma rt_strictly_fresherI' [intro]:
  assumes "rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2"
      and "\<not>(rt2 \<sqsubseteq>\<^bsub>i\<^esub> rt1)"
    shows "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
  using assms unfolding rt_strictly_fresher_def'' by simp

lemma rt_strictly_fresherE' [elim]:
  assumes "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
      and "\<lbrakk> rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2; \<not>(rt2 \<sqsubseteq>\<^bsub>i\<^esub> rt1) \<rbrakk> \<Longrightarrow> P rt1 rt2 i"
    shows "P rt1 rt2 i"
  using assms unfolding rt_strictly_fresher_def'' by simp

lemma rt_strictly_fresherI [intro]:
  assumes "rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2"
      and "\<not>(rt1 \<approx>\<^bsub>i\<^esub> rt2)"
    shows "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
  unfolding rt_strictly_fresher_def using assms ..

lemmas rt_strictly_fresher_singleI [elim] = rt_strictly_fresherI [OF single_rt_fresher]

lemma rt_strictly_fresherE [elim]:
  assumes "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
      and "\<lbrakk> rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2; \<not>(rt1 \<approx>\<^bsub>i\<^esub> rt2) \<rbrakk> \<Longrightarrow> P rt1 rt2 i"
    shows "P rt1 rt2 i"
  using assms(1) unfolding rt_strictly_fresher_def
  by rule (erule(1) assms(2))

lemma rt_strictly_fresher_def':
  "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2 =
     (nsqn\<^sub>r (the (rt1 i)) < nsqn\<^sub>r (the (rt2 i))
       \<or> (nsqn\<^sub>r (the (rt1 i)) = nsqn\<^sub>r (the (rt2 i)) \<and> \<pi>\<^sub>5(the (rt1 i)) > \<pi>\<^sub>5(the (rt2 i))))"
  unfolding rt_strictly_fresher_def'' rt_fresher_def fresher_def by auto

lemma rt_strictly_fresher_fresherD [dest]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
    shows "the (rt1 dip) \<sqsubseteq> the (rt2 dip)"
  using assms unfolding rt_strictly_fresher_def rt_fresher_def by auto

lemma rt_strictly_fresher_not_fresh_asD [dest]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
    shows "\<not> rt1 \<approx>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_strictly_fresher_def by auto

lemma rt_strictly_fresher_trans [elim, trans]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
  using assms proof -
    from \<open>rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2\<close> obtain "the (rt1 dip) \<sqsubseteq> the (rt2 dip)" by auto
    also from \<open>rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3\<close> obtain "the (rt2 dip) \<sqsubseteq> the (rt3 dip)" by auto
    finally have "the (rt1 dip) \<sqsubseteq> the (rt3 dip)" .

    moreover have "\<not> (rt1 \<approx>\<^bsub>dip\<^esub> rt3)"
    proof -
      from \<open>rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2\<close> obtain "\<not>(the (rt2 dip) \<sqsubseteq> the (rt1 dip))" by auto
      also from \<open>rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3\<close> obtain "\<not>(the (rt3 dip) \<sqsubseteq> the (rt2 dip))" by auto
      finally have "\<not>(the (rt3 dip) \<sqsubseteq> the (rt1 dip))" .
      thus ?thesis ..
    qed
    ultimately show "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3" ..
 qed

lemma rt_strictly_fresher_irefl [simp]: "\<not> (rt \<sqsubset>\<^bsub>dip\<^esub> rt)"
  unfolding rt_strictly_fresher_def
  by clarsimp

lemma rt_fresher_trans_rt_strictly_fresher [elim, trans]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
  proof -
    from \<open>rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2\<close> have "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
                           and "\<not>(rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
      unfolding rt_strictly_fresher_def'' by auto
    from this(1) and \<open>rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3\<close> have "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt3" ..

    moreover from \<open>\<not>(rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)\<close> have "\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
      proof (rule contrapos_nn)
        assume "rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
        with \<open>rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3\<close> show "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1" ..
      qed

    ultimately show "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
      unfolding rt_strictly_fresher_def'' by auto
  qed

lemma rt_fresher_trans_rt_strictly_fresher' [elim, trans]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
  proof -
    from \<open>rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3\<close> have "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
                           and "\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)"
      unfolding rt_strictly_fresher_def'' by auto
    from \<open>rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2\<close> and this(1) have "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt3" ..

    moreover from \<open>\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)\<close> have "\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
      proof (rule contrapos_nn)
        assume "rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
        thus "rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt2" using \<open>rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2\<close> ..
      qed

    ultimately show "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
      unfolding rt_strictly_fresher_def'' by auto
  qed

lemma rt_fresher_imp_nsqn_le:
  assumes "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
      and "ip \<in> kD rt1"
      and "ip \<in> kD rt2"
    shows "nsqn rt1 ip \<le> nsqn rt2 ip"
  using assms(1)
  by (auto simp add: rt_fresher_def2 [OF assms(2-3)])

lemma rt_strictly_fresher_ltI [intro]:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "nsqn rt1 dip < nsqn rt2 dip"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
  proof
    from assms show "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2" ..
  next
    show "\<not>(rt1 \<approx>\<^bsub>dip\<^esub> rt2)"
    proof
      assume "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
      hence "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1" ..
      hence "nsqn rt2 dip \<le> nsqn rt1 dip"
        using \<open>dip \<in> kD(rt2)\<close> \<open>dip \<in> kD(rt1)\<close>
        by (rule rt_fresher_imp_nsqn_le)
      with \<open>nsqn rt1 dip < nsqn rt2 dip\<close> show "False"
        by simp
    qed
  qed

lemma rt_strictly_fresher_eqI [intro]:
  assumes "i\<in>kD(rt1)"
      and "i\<in>kD(rt2)"
      and "nsqn rt1 i = nsqn rt2 i"
      and "\<pi>\<^sub>5(the (rt2 i)) < \<pi>\<^sub>5(the (rt1 i))"
    shows "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
  using assms unfolding rt_strictly_fresher_def' by (auto simp add: kD_nsqn)

lemma invalidate_rtsf_left [simp]:
  "\<And>dests dip rt rt'. dests dip = None \<Longrightarrow> (invalidate rt dests \<sqsubset>\<^bsub>dip\<^esub> rt') = (rt \<sqsubset>\<^bsub>dip\<^esub> rt')"
  unfolding invalidate_def rt_strictly_fresher_def'
  by (rule iffI) (auto split: option.split_asm)

lemma vD_invalidate_rt_strictly_fresher [simp]:
  assumes "dip \<in> vD(invalidate rt1 dests)"
    shows "(invalidate rt1 dests \<sqsubset>\<^bsub>dip\<^esub> rt2) = (rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2)"
  proof (cases "dip \<in> dom(dests)")
    assume "dip \<in> dom(dests)"
    hence "dip \<notin> vD(invalidate rt1 dests)"
      unfolding invalidate_def vD_def
      by clarsimp (metis assms option.simps(3) vD_invalidate_vD_not_dests)
    with \<open>dip \<in> vD(invalidate rt1 dests)\<close> show ?thesis by simp
  next
    assume "dip \<notin> dom(dests)"
    hence "dests dip = None" by auto
    moreover with \<open>dip \<in> vD(invalidate rt1 dests)\<close> have "dip \<in> vD(rt1)"
      unfolding invalidate_def vD_def
      by clarsimp (metis (hide_lams, no_types) assms vD_Some vD_invalidate_vD_not_dests)
    ultimately show ?thesis
      unfolding invalidate_def rt_strictly_fresher_def' by auto
  qed

lemma rt_strictly_fresher_update_other [elim!]:
  "\<And>dip ip rt r rt'. \<lbrakk> dip \<noteq> ip; rt \<sqsubset>\<^bsub>dip\<^esub> rt' \<rbrakk> \<Longrightarrow> update rt ip r \<sqsubset>\<^bsub>dip\<^esub> rt'"
  unfolding rt_strictly_fresher_def' by clarsimp

lemma addpreRT_strictly_fresher [simp]:
  assumes "dip \<in> kD(rt)"
    shows "(the (addpreRT rt dip npre) \<sqsubset>\<^bsub>ip\<^esub> rt2) = (rt \<sqsubset>\<^bsub>ip\<^esub> rt2)"
  using assms unfolding rt_strictly_fresher_def' by clarsimp

lemma lt_sqn_imp_update_strictly_fresher:
  assumes "dip \<in> vD (rt2 nhip)"
      and  *: "osn < sqn (rt2 nhip) dip"
      and **: "rt \<noteq> update rt dip (osn, kno, val, hops, nhip, {})"
    shows "update rt dip (osn, kno, val, hops, nhip, {}) \<sqsubset>\<^bsub>dip\<^esub> rt2 nhip"
  unfolding rt_strictly_fresher_def'
  proof (rule disjI1)
    from ** have "nsqn (update rt dip (osn, kno, val, hops, nhip, {})) dip = osn"
      by (rule nsqn_update_changed_kno_val)
    with \<open>dip\<in>vD(rt2 nhip)\<close>
      have "nsqn\<^sub>r (the (update rt dip (osn, kno, val, hops, nhip, {}) dip)) = osn"
        by (simp add: kD_nsqn)
    also have "osn < sqn (rt2 nhip) dip" by (rule *)
    also have "sqn (rt2 nhip) dip = nsqn\<^sub>r (the (rt2 nhip dip))"
      unfolding nsqn\<^sub>r_def using \<open>dip \<in> vD (rt2 nhip)\<close>
      by - (metis vD_flag_val proj2_eq_sqn proj4_eq_flag vD_iD_gives_kD(1))
    finally show "nsqn\<^sub>r (the (update rt dip (osn, kno, val, hops, nhip, {}) dip))
                                                              < nsqn\<^sub>r (the (rt2 nhip dip))" .
  qed

lemma dhops_le_hops_imp_update_strictly_fresher:
  assumes "dip \<in> vD(rt2 nhip)"
      and sqn: "sqn (rt2 nhip) dip = osn"
      and hop: "the (dhops (rt2 nhip) dip) \<le> hops"
      and **: "rt \<noteq> update rt dip (osn, kno, val, Suc hops, nhip, {})"
    shows "update rt dip (osn, kno, val, Suc hops, nhip, {}) \<sqsubset>\<^bsub>dip\<^esub> rt2 nhip"
  unfolding rt_strictly_fresher_def'
  proof (rule disjI2, rule conjI)
    from ** have "nsqn (update rt dip (osn, kno, val, Suc hops, nhip, {})) dip = osn"
      by (rule nsqn_update_changed_kno_val)
    with \<open>dip\<in>vD(rt2 nhip)\<close>
      have "nsqn\<^sub>r (the (update rt dip (osn, kno, val, Suc hops, nhip, {}) dip)) = osn"
        by (simp add: kD_nsqn)
    also have "osn = sqn (rt2 nhip) dip" by (rule sqn [symmetric])
    also have "sqn (rt2 nhip) dip = nsqn\<^sub>r (the (rt2 nhip dip))"
      unfolding nsqn\<^sub>r_def using \<open>dip \<in> vD(rt2 nhip)\<close>
      by - (metis vD_flag_val proj2_eq_sqn proj4_eq_flag vD_iD_gives_kD(1))
    finally show "nsqn\<^sub>r (the (update rt dip (osn, kno, val, Suc hops, nhip, {}) dip))
                                                              = nsqn\<^sub>r (the (rt2 nhip dip))" .
  next
    have "the (dhops (rt2 nhip) dip) \<le> hops" by (rule hop)
    also have "hops < hops + 1" by simp
    also have "hops + 1 = the (dhops (update rt dip (osn, kno, val, Suc hops, nhip, {})) dip)"
      using ** by simp
    finally have "the (dhops (rt2 nhip) dip)
                        < the (dhops (update rt dip (osn, kno, val, Suc hops, nhip, {})) dip)" .
    thus "\<pi>\<^sub>5 (the (rt2 nhip dip)) < \<pi>\<^sub>5 (the (update rt dip (osn, kno, val, Suc hops, nhip, {}) dip))"
      using \<open>dip \<in> vD(rt2 nhip)\<close> by (simp add: proj5_eq_dhops)
  qed

lemma nsqn_invalidate:
  assumes "dip \<in> kD(rt)"
      and "\<forall>ip\<in>dom(dests). ip \<in> vD(rt) \<and> the (dests ip) = inc (sqn rt ip)"
    shows "nsqn (invalidate rt dests) dip = nsqn rt dip"
  proof -
    from \<open>dip \<in> kD(rt)\<close> have "dip \<in> kD(invalidate rt dests)" by simp

    from assms have "rt \<approx>\<^bsub>dip\<^esub> invalidate rt dests"
      by (rule rt_fresh_as_inc_invalidate)
    with \<open>dip \<in> kD(rt)\<close> \<open>dip \<in> kD(invalidate rt dests)\<close> show ?thesis
      by (simp add: kD_nsqn del: invalidate_kD_inv)
         (erule(2) rt_fresh_as_nsqnr)
  qed

end