theory Instance_Graph
  imports
    Main
    Multiplicity_Pair
    Type_Graph
    Extended_Graph_Theory
begin

section "Node set definitions"

datatype ('nt, 'lt) NodeDef = typed "'lt LabDef" "'nt" | bool bool | int int | real real | string string | invalid

fun nodeType :: "('nt, 'lt) NodeDef \<Rightarrow> ('lt) LabDef" where
  "nodeType (typed t n) = t" |
  "nodeType (bool v) = LabDef.bool" |
  "nodeType (int v) = LabDef.int" |
  "nodeType (real v) = LabDef.real" |
  "nodeType (string v) = LabDef.string" |
  "nodeType invalid = undefined"

fun nodeId :: "('nt, 'lt) NodeDef \<Rightarrow> 'nt" where
  "nodeId (typed t n) = n" |
  "nodeId _ = undefined"

subsection "Typed nodes"

inductive_set Node\<^sub>t :: "('nt, 'lt) NodeDef set"
  where
    rule_typed_nodes: "\<And>t n. t \<in> Lab\<^sub>t \<Longrightarrow> typed t n \<in> Node\<^sub>t"

lemma typed_nodes_member[simp]: "x \<in> Node\<^sub>t \<Longrightarrow> \<exists>y z. x = typed y z"
  using Node\<^sub>t.cases by blast

lemma typed_nodes_contains_no_bool[simp]: "bool x \<notin> Node\<^sub>t"
  using typed_nodes_member by blast

lemma typed_nodes_contains_no_int[simp]: "int x \<notin> Node\<^sub>t"
  using typed_nodes_member by blast

lemma typed_nodes_contains_no_real[simp]: "real x \<notin> Node\<^sub>t"
  using typed_nodes_member by blast

lemma typed_nodes_contains_no_string[simp]: "string x \<notin> Node\<^sub>t"
  using typed_nodes_member by blast

lemma typed_nodes_node_type: "x \<in> Node\<^sub>t \<Longrightarrow> nodeType x \<in> Lab\<^sub>t"
  using Node\<^sub>t.cases nodeType.simps(1)
  by metis

lemma typed_nodes_not_invalid[simp]: "invalid \<notin> Node\<^sub>t"
  using typed_nodes_member by blast

subsection "Set of value nodes"

subsubsection "Boolean nodes"

definition BooleanNode\<^sub>v :: "('nt, 'lt) NodeDef set" where
  "BooleanNode\<^sub>v \<equiv> {bool True, bool False}"

fun boolValue :: "('nt, 'lt) NodeDef \<Rightarrow> bool" where
  "boolValue (bool v) = v" |
  "boolValue _ = undefined"

lemma boolean_nodes_member[simp]: "x \<in> BooleanNode\<^sub>v \<Longrightarrow> x = bool True \<or> x = bool False"
  by (simp add: BooleanNode\<^sub>v_def)

lemma boolean_nodes_contains_no_typed_node[simp]: "typed x y \<notin> BooleanNode\<^sub>v"
  using boolean_nodes_member by blast

lemma boolean_nodes_contains_no_int[simp]: "int x \<notin> BooleanNode\<^sub>v"
  using boolean_nodes_member by blast

lemma boolean_nodes_contains_no_real[simp]: "real x \<notin> BooleanNode\<^sub>v"
  using boolean_nodes_member by blast

lemma boolean_nodes_contains_no_string[simp]: "string x \<notin> BooleanNode\<^sub>v"
  using boolean_nodes_member by blast

lemma boolean_nodes_typed_nodes_intersect[simp]: "BooleanNode\<^sub>v \<inter> Node\<^sub>t = {}"
  using typed_nodes_member by fastforce

lemma boolean_nodes_node_type[simp]: "x \<in> BooleanNode\<^sub>v \<Longrightarrow> nodeType x = LabDef.bool"
  using boolean_nodes_member nodeType.simps(2) by blast

lemma boolean_nodes_not_invalid[simp]: "invalid \<notin> BooleanNode\<^sub>v"
  using boolean_nodes_member by blast

lemma boolean_nodes_value[simp]: "x \<in> BooleanNode\<^sub>v \<Longrightarrow> x = bool y \<Longrightarrow> boolValue x = y"
  by simp

subsubsection "Integer nodes"

inductive_set IntegerNode\<^sub>v :: "('nt, 'lt) NodeDef set"
  where
    rule_integer_nodes: "\<And>i. int i \<in> IntegerNode\<^sub>v"

fun intValue :: "('nt, 'lt) NodeDef \<Rightarrow> int" where
  "intValue (int v) = v" |
  "intValue _ = undefined"

lemma integer_nodes_member[simp]: "x \<in> IntegerNode\<^sub>v \<Longrightarrow> \<exists>y. x = int y"
  using IntegerNode\<^sub>v.cases by blast

lemma integer_nodes_contains_no_typed_node[simp]: "typed x y \<notin> IntegerNode\<^sub>v"
  using integer_nodes_member by blast

lemma integer_nodes_contains_no_bool[simp]: "bool x \<notin> IntegerNode\<^sub>v"
  using integer_nodes_member by blast

lemma integer_nodes_contains_no_real[simp]: "real x \<notin> IntegerNode\<^sub>v"
  using integer_nodes_member by blast

lemma integer_nodes_contains_no_string[simp]: "string x \<notin> IntegerNode\<^sub>v"
  using integer_nodes_member by blast

lemma integer_nodes_typed_nodes_intersect[simp]: "IntegerNode\<^sub>v \<inter> Node\<^sub>t = {}"
  using typed_nodes_member by fastforce

lemma integer_nodes_boolean_nodes_intersect[simp]: "IntegerNode\<^sub>v \<inter> BooleanNode\<^sub>v = {}"
  using boolean_nodes_member by fastforce

lemma integer_nodes_node_type[simp]: "x \<in> IntegerNode\<^sub>v \<Longrightarrow> nodeType x = LabDef.int"
  using integer_nodes_member nodeType.simps(3) by blast

lemma integer_nodes_not_invalid[simp]: "invalid \<notin> IntegerNode\<^sub>v"
  using integer_nodes_member by blast

lemma integer_nodes_value[simp]: "x \<in> IntegerNode\<^sub>v \<Longrightarrow> x = int y \<Longrightarrow> intValue x = y"
  by simp

subsubsection "Real nodes"

inductive_set RealNode\<^sub>v :: "('nt, 'lt) NodeDef set"
  where
    rule_real_nodes: "\<And>r. real r \<in> RealNode\<^sub>v"

fun realValue :: "('nt, 'lt) NodeDef \<Rightarrow> real" where
  "realValue (real v) = v" |
  "realValue _ = undefined"

lemma real_nodes_member[simp]: "x \<in> RealNode\<^sub>v \<Longrightarrow> \<exists>y. x = real y"
  using RealNode\<^sub>v.cases by blast

lemma real_nodes_contains_no_typed_node[simp]: "typed x y \<notin> RealNode\<^sub>v"
  using real_nodes_member by blast

lemma real_nodes_contains_no_bool[simp]: "bool x \<notin> RealNode\<^sub>v"
  using real_nodes_member by blast

lemma real_nodes_contains_no_int[simp]: "int x \<notin> RealNode\<^sub>v"
  using real_nodes_member by blast

lemma real_nodes_contains_no_string[simp]: "string x \<notin> RealNode\<^sub>v"
  using real_nodes_member by blast

lemma real_nodes_typed_nodes_intersect[simp]: "RealNode\<^sub>v \<inter> Node\<^sub>t = {}"
  using typed_nodes_member by fastforce

lemma real_nodes_boolean_nodes_intersect[simp]: "RealNode\<^sub>v \<inter> BooleanNode\<^sub>v = {}"
  using boolean_nodes_member by fastforce

lemma real_nodes_integer_nodes_intersect[simp]: "RealNode\<^sub>v \<inter> IntegerNode\<^sub>v = {}"
  using integer_nodes_member by fastforce

lemma real_nodes_node_type[simp]: "x \<in> RealNode\<^sub>v \<Longrightarrow> nodeType x = LabDef.real"
  using real_nodes_member nodeType.simps(4) by blast

lemma real_nodes_not_invalid[simp]: "invalid \<notin> RealNode\<^sub>v"
  using real_nodes_member by blast

lemma real_nodes_value[simp]: "x \<in> RealNode\<^sub>v \<Longrightarrow> x = real y \<Longrightarrow> realValue x = y"
  by simp

subsubsection "String nodes"

inductive_set StringNode\<^sub>v :: "('nt, 'lt) NodeDef set"
  where
    rule_string_nodes: "\<And>s. string s \<in> StringNode\<^sub>v"

fun stringValue :: "('nt, 'lt) NodeDef \<Rightarrow> string" where
  "stringValue (string v) = v" |
  "stringValue _ = undefined"

lemma string_nodes_member[simp]: "x \<in> StringNode\<^sub>v \<Longrightarrow> \<exists>y. x = string y"
  using StringNode\<^sub>v.cases by blast

lemma string_nodes_contains_no_typed_node[simp]: "typed x y \<notin> StringNode\<^sub>v"
  using string_nodes_member by blast

lemma string_nodes_contains_no_bool[simp]: "bool x \<notin> StringNode\<^sub>v"
  using string_nodes_member by blast

lemma string_nodes_contains_no_int[simp]: "int x \<notin> StringNode\<^sub>v"
  using string_nodes_member by blast

lemma string_nodes_contains_no_real[simp]: "real x \<notin> StringNode\<^sub>v"
  using string_nodes_member by blast

lemma string_nodes_typed_nodes_intersect[simp]: "StringNode\<^sub>v \<inter> Node\<^sub>t = {}"
  using typed_nodes_member by fastforce

lemma string_nodes_boolean_nodes_intersect[simp]: "StringNode\<^sub>v \<inter> BooleanNode\<^sub>v = {}"
  using boolean_nodes_member by fastforce

lemma string_nodes_integer_nodes_intersect[simp]: "StringNode\<^sub>v \<inter> IntegerNode\<^sub>v = {}"
  using integer_nodes_member by fastforce

lemma string_nodes_real_nodes_intersect[simp]: "StringNode\<^sub>v \<inter> RealNode\<^sub>v = {}"
  using real_nodes_member by fastforce

lemma string_nodes_node_type[simp]: "x \<in> StringNode\<^sub>v \<Longrightarrow> nodeType x = LabDef.string"
  using string_nodes_member nodeType.simps(5) by blast

lemma string_nodes_not_invalid[simp]: "invalid \<notin> StringNode\<^sub>v"
  using string_nodes_member by blast

lemma string_nodes_value[simp]: "x \<in> StringNode\<^sub>v \<Longrightarrow> x = string y \<Longrightarrow> stringValue x = y"
  by simp

subsubsection "Value nodes"

definition Node\<^sub>v :: "('nt, 'lt) NodeDef set" where
  "Node\<^sub>v \<equiv> BooleanNode\<^sub>v \<union> IntegerNode\<^sub>v \<union> RealNode\<^sub>v \<union> StringNode\<^sub>v"

lemma value_nodes_member[simp]: "x \<in> Node\<^sub>v \<Longrightarrow> x = bool True \<or> x = bool False \<or> (\<exists>y. x = int y) \<or> (\<exists>y. x = real y) \<or> (\<exists>y. x = string y)"
  unfolding Node\<^sub>v_def
  using boolean_nodes_member integer_nodes_member real_nodes_member string_nodes_member
  by blast

lemma value_nodes_contains_no_typed_node[simp]: "typed x y \<notin> Node\<^sub>v"
  using value_nodes_member by blast

lemma value_nodes_typed_nodes_intersect[simp]: "Node\<^sub>v \<inter> Node\<^sub>t = {}"
  using typed_nodes_member by fastforce

lemma value_nodes_boolean_nodes_intersect[simp]: "Node\<^sub>v \<inter> BooleanNode\<^sub>v = BooleanNode\<^sub>v"
  using Node\<^sub>v_def by fastforce

lemma value_nodes_integer_nodes_intersect[simp]: "Node\<^sub>v \<inter> IntegerNode\<^sub>v = IntegerNode\<^sub>v"
  using Node\<^sub>v_def by fastforce

lemma value_nodes_real_nodes_intersect[simp]: "Node\<^sub>v \<inter> RealNode\<^sub>v = RealNode\<^sub>v"
  using Node\<^sub>v_def by fastforce

lemma value_nodes_string_nodes_intersect[simp]: "Node\<^sub>v \<inter> StringNode\<^sub>v = StringNode\<^sub>v"
  using Node\<^sub>v_def by fastforce

lemma value_nodes_contain_boolean_nodes[simp]: "BooleanNode\<^sub>v \<subseteq> Node\<^sub>v"
  using value_nodes_boolean_nodes_intersect by fastforce

lemma value_nodes_contain_integer_nodes[simp]: "IntegerNode\<^sub>v \<subseteq> Node\<^sub>v"
  using value_nodes_integer_nodes_intersect by fastforce

lemma value_nodes_contain_real_nodes[simp]: "RealNode\<^sub>v \<subseteq> Node\<^sub>v"
  using value_nodes_real_nodes_intersect by fastforce

lemma value_nodes_contain_string_nodes[simp]: "StringNode\<^sub>v \<subseteq> Node\<^sub>v"
  using value_nodes_string_nodes_intersect by fastforce

lemma value_nodes_node_type: "x \<in> Node\<^sub>v \<Longrightarrow> nodeType x \<in> Lab\<^sub>p"
  using Lab\<^sub>p_def value_nodes_member by fastforce

lemma value_nodes_not_invalid[simp]: "invalid \<notin> Node\<^sub>v"
  using value_nodes_member by blast

subsection "Nodes"

definition Node :: "('nt, 'lt) NodeDef set" where
  "Node \<equiv> Node\<^sub>t \<union> Node\<^sub>v"

lemma nodes_typed_nodes_intersect[simp]: "Node \<inter> Node\<^sub>t = Node\<^sub>t"
  using Node_def by fastforce

lemma nodes_value_nodes_intersect[simp]: "Node \<inter> Node\<^sub>v = Node\<^sub>v"
  using Node_def by fastforce

lemma nodes_boolean_nodes_intersect[simp]: "Node \<inter> BooleanNode\<^sub>v = BooleanNode\<^sub>v"
  using nodes_value_nodes_intersect value_nodes_boolean_nodes_intersect
  by blast

lemma nodes_integer_nodes_intersect[simp]: "Node \<inter> IntegerNode\<^sub>v = IntegerNode\<^sub>v"
  using nodes_value_nodes_intersect value_nodes_integer_nodes_intersect
  by blast

lemma nodes_real_nodes_intersect[simp]: "Node \<inter> RealNode\<^sub>v = RealNode\<^sub>v"
  using nodes_value_nodes_intersect value_nodes_real_nodes_intersect
  by blast

lemma nodes_string_nodes_intersect[simp]: "Node \<inter> StringNode\<^sub>v = StringNode\<^sub>v"
  using nodes_value_nodes_intersect value_nodes_string_nodes_intersect
  by blast

lemma nodes_contain_typed_nodes[simp]: "Node\<^sub>t \<subseteq> Node"
  using nodes_typed_nodes_intersect by fastforce

lemma nodes_contain_value_nodes[simp]: "Node\<^sub>v \<subseteq> Node"
  using nodes_value_nodes_intersect by fastforce

lemma nodes_contain_boolean_nodes[simp]: "BooleanNode\<^sub>v \<subseteq> Node"
  using nodes_boolean_nodes_intersect by fastforce

lemma nodes_contain_integer_nodes[simp]: "IntegerNode\<^sub>v \<subseteq> Node"
  using nodes_integer_nodes_intersect by fastforce

lemma nodes_contain_real_nodes[simp]: "RealNode\<^sub>v \<subseteq> Node"
  using nodes_real_nodes_intersect by fastforce

lemma nodes_contain_string_nodes[simp]: "StringNode\<^sub>v \<subseteq> Node"
  using nodes_string_nodes_intersect by fastforce

lemma nodes_node_type: "x \<in> Node \<Longrightarrow> nodeType x \<in> Lab\<^sub>t \<union> Lab\<^sub>p"
  using Node_def typed_nodes_node_type value_nodes_node_type by auto

lemma nodes_not_invalid[simp]: "invalid \<notin> Node"
  unfolding Node_def
  by simp

section "Instance graph tuple definition"

record ('nt, 'lt, 'id) instance_graph =
  TG :: "('lt) type_graph"
  Id :: "'id set"
  N :: "('nt, 'lt) NodeDef set"
  E :: "(('nt, 'lt) NodeDef \<times> ('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) \<times> ('nt, 'lt) NodeDef) set"
  ident :: "'id \<Rightarrow> ('nt, 'lt) NodeDef"

section "Types"

definition type\<^sub>n :: "('nt, 'lt) NodeDef \<Rightarrow> 'lt LabDef" where
  "type\<^sub>n \<equiv> nodeType"

declare type\<^sub>n_def[simp add]

definition type\<^sub>e :: "('nt, 'lt) NodeDef \<times> ('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) \<times> ('nt, 'lt) NodeDef \<Rightarrow> 'lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef" where
  "type\<^sub>e e \<equiv> fst (snd e)"

declare type\<^sub>e_def[simp add]

section "Graph theory projection"

definition instance_graph_proj :: "('nt, 'lt, 'id) instance_graph \<Rightarrow> (('nt, 'lt) NodeDef, ('nt, 'lt) NodeDef \<times> ('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) \<times> ('nt, 'lt) NodeDef) pre_digraph" where
  "instance_graph_proj IG = \<lparr> verts = N IG, arcs = E IG, tail = tgt, head = src \<rparr>"

declare [[coercion instance_graph_proj]]

definition instance_graph_containment_proj :: "('nt, 'lt, 'id) instance_graph \<Rightarrow> (('nt, 'lt) NodeDef, ('nt, 'lt) NodeDef \<times> ('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) \<times> ('nt, 'lt) NodeDef) pre_digraph" where
  "instance_graph_containment_proj IG = \<lparr> verts = N IG, arcs = { e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) }, tail = tgt, head = src \<rparr>"

section "Instance graph validity"

locale instance_graph = fixes IG :: "('nt, 'lt, 'id) instance_graph"
  assumes structure_nodes_wellformed[simp]: "\<And>n. n \<in> N IG \<Longrightarrow> n \<in> Node"
  assumes structure_edges_wellformed: "\<And>s l t. (s, l, t) \<in> E IG \<Longrightarrow> s \<in> N IG \<and> l \<in> ET (TG IG) \<and> t \<in> N IG"
  assumes structure_ident_wellformed: "\<And>i. i \<in> Id IG \<Longrightarrow> ident IG i \<in> N IG \<and> type\<^sub>n (ident IG i) \<in> Lab\<^sub>t"
  assumes structure_ident_domain[simp]: "\<And>i. i \<notin> Id IG \<Longrightarrow> ident IG i = undefined"
  assumes validity_type_graph[simp]: "type_graph (TG IG)"
  assumes validity_node_typed[simp]: "\<And>n. n \<in> N IG \<Longrightarrow> type\<^sub>n n \<in> NT (TG IG)"
  assumes validity_edge_src_typed[simp]: "\<And>e. e \<in> E IG \<Longrightarrow> (type\<^sub>n (src e), src (type\<^sub>e e)) \<in> inh (TG IG)"
  assumes validity_edge_tgt_typed[simp]: "\<And>e. e \<in> E IG \<Longrightarrow> (type\<^sub>n (tgt e), tgt (type\<^sub>e e)) \<in> inh (TG IG)"
  assumes validity_abs_no_instances[simp]: "\<And>n. n \<in> N IG \<Longrightarrow> type\<^sub>n n \<notin> abs (TG IG)"
  assumes validity_outgoing_mult[simp]: "\<And>et n. et \<in> ET (TG IG) \<Longrightarrow> n \<in> N IG \<Longrightarrow> (type\<^sub>n n, src et) \<in> inh (TG IG) \<Longrightarrow> card { e. e \<in> E IG \<and> src e = n \<and> type\<^sub>e e = et} in m_out (mult (TG IG) et)"
  assumes validity_ingoing_mult[simp]: "\<And>et n. et \<in> ET (TG IG) \<Longrightarrow> n \<in> N IG \<Longrightarrow> (type\<^sub>n n, tgt et) \<in> inh (TG IG) \<Longrightarrow> card { e. e \<in> E IG \<and> tgt e = n \<and> type\<^sub>e e = et} in m_in (mult (TG IG) et)"
  assumes validity_contained_node[simp]: "\<And>n. n \<in> N IG \<Longrightarrow> card { e. e \<in> E IG \<and> tgt e = n \<and> type\<^sub>e e \<in> contains (TG IG) } \<le> 1"
  assumes validity_containment[simp]: "\<And>p. \<not>pre_digraph.cycle (instance_graph_containment_proj IG) p"

context instance_graph
begin

lemma structure_edges_wellformed_src_node[simp]: "\<And>s. (s, l, t) \<in> E IG \<Longrightarrow> s \<in> N IG"
  by (simp add: structure_edges_wellformed)

lemma structure_edges_wellformed_edge_type[simp]: "\<And>l. (s, l, t) \<in> E IG \<Longrightarrow> l \<in> ET (TG IG)"
  by (simp add: structure_edges_wellformed)

lemma structure_edges_wellformed_tgt_node[simp]: "\<And>t. (s, l, t) \<in> E IG \<Longrightarrow> t \<in> N IG"
  by (simp add: structure_edges_wellformed)

lemma structure_edges_wellformed_alt: "\<And>e. e \<in> E IG \<Longrightarrow> src e \<in> N IG \<and> type\<^sub>e e \<in> ET (TG IG) \<and> tgt e \<in> N IG"
  by auto

lemma structure_edges_wellformed_src_node_alt[simp]: "\<And>e. e \<in> E IG \<Longrightarrow> src e \<in> N IG"
  by auto

lemma structure_edges_wellformed_edge_type_alt[simp]: "\<And>e. e \<in> E IG \<Longrightarrow> type\<^sub>e e \<in> ET (TG IG)"
  by auto

lemma structure_edges_wellformed_tgt_node_alt[simp]: "\<And>e. e \<in> E IG \<Longrightarrow> tgt e \<in> N IG"
  by auto

lemma structure_ident_wellformed_node[simp]: "\<And>i. i \<in> Id IG \<Longrightarrow> ident IG i \<in> N IG"
  using structure_ident_wellformed
  by blast

lemma structure_ident_wellformed_node_type[simp]: "\<And>i. i \<in> Id IG \<Longrightarrow> type\<^sub>n (ident IG i) \<in> Lab\<^sub>t"
  using structure_ident_wellformed
  by blast

lemma validity_edge_src_typed_alt[simp]: "\<And>s l t. (s, l, t) \<in> E IG \<Longrightarrow> (type\<^sub>n s, src l) \<in> inh (TG IG)"
proof-
  fix s l t
  assume "(s, l, t) \<in> E IG"
  then have "(type\<^sub>n (src (s, l, t)), src (type\<^sub>e (s, l, t))) \<in> inh (TG IG)"
    by (fact validity_edge_src_typed)
  then show "(type\<^sub>n s, src l) \<in> inh (TG IG)"
    by simp
qed

lemma validity_edge_tgt_typed_alt[simp]: "\<And>s l t. (s, l, t) \<in> E IG \<Longrightarrow> (type\<^sub>n t, tgt l) \<in> inh (TG IG)"
proof-
  fix s l t
  assume "(s, l, t) \<in> E IG"
  then have "(type\<^sub>n (tgt (s, l, t)), tgt (type\<^sub>e (s, l, t))) \<in> inh (TG IG)"
    by (fact validity_edge_tgt_typed)
  then show "(type\<^sub>n t, tgt l) \<in> inh (TG IG)"
    by simp
qed

lemma validity_contained_node_alt[simp]: "\<And>n. n \<in> N IG \<Longrightarrow> card { (s, l, t). (s, l, t) \<in> E IG \<and> t = n \<and> l \<in> contains (TG IG) } \<le> 1"
proof-
  fix n
  assume n_in_nodes: "n \<in> N IG"
  have "{ e. e \<in> E IG \<and> tgt e = n \<and> type\<^sub>e e \<in> contains (TG IG) } = { (s, l, t). (s, l, t) \<in> E IG \<and> tgt (s, l, t) = n \<and> type\<^sub>e (s, l, t) \<in> contains (TG IG) }"
    by blast
  then have "card { (s, l, t). (s, l, t) \<in> E IG \<and> tgt (s, l, t) = n \<and> type\<^sub>e (s, l, t) \<in> contains (TG IG) } \<le> 1"
    using n_in_nodes validity_contained_node by fastforce
  then show "card { (s, l, t). (s, l, t) \<in> E IG \<and> t = n \<and> l \<in> contains (TG IG) } \<le> 1"
    by simp
qed

end

section "Graph theory compatibility"

sublocale instance_graph \<subseteq> pre_digraph "instance_graph_proj IG"
  rewrites "verts IG = N IG" and "arcs IG = E IG" and "tail IG = tgt" and "head IG = src"
  by unfold_locales (simp_all add: instance_graph_proj_def)

sublocale instance_graph \<subseteq> wf_digraph IG
proof
  have verts_are_nodes: "verts (instance_graph_proj IG) = N IG"
    by (simp add: instance_graph_proj_def)
  have head_is_src: "head (instance_graph_proj IG) = src"
    by (simp add: instance_graph_proj_def)
  have tail_is_tgt: "tail (instance_graph_proj IG) = tgt"
    by (simp add: instance_graph_proj_def)
  fix e
  assume "e \<in> arcs (instance_graph_proj IG)"
  then have e_in_edges: "e \<in> E IG"
    by (simp add: instance_graph_proj_def)
  show "tail (instance_graph_proj IG) e \<in> verts (instance_graph_proj IG)"
    using e_in_edges verts_are_nodes tail_is_tgt structure_edges_wellformed_tgt_node_alt
    by auto
  show "head (instance_graph_proj IG) e \<in> verts (instance_graph_proj IG)"
    using e_in_edges verts_are_nodes head_is_src structure_edges_wellformed_src_node_alt
    by auto
qed

lemma validity_containment_alt:
  assumes structure_edges_wellformed: "\<And>e. e \<in> E IG \<Longrightarrow> type\<^sub>e e \<in> contains (TG IG) \<Longrightarrow> src e \<in> N IG \<and> tgt e \<in> N IG"
  assumes validity_containment: "\<And>p. \<not>pre_digraph.cycle (instance_graph_containment_proj IG) p"
  shows "irrefl ((edge_to_tuple ` { e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) })\<^sup>+)"
proof-
  have "irrefl ((pre_digraph.arc_to_tuple (instance_graph_containment_proj IG) ` arcs (instance_graph_containment_proj IG))\<^sup>+)"
  proof (intro wf_digraph.acyclic_impl_irrefl_trancl)
    show "wf_digraph (instance_graph_containment_proj IG)"
    proof (intro wf_digraph.intro)
      fix e
      assume "e \<in> arcs (instance_graph_containment_proj IG)"
      then have "e \<in> { e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) }"
        unfolding instance_graph_containment_proj_def
        by simp
      then show "tail (instance_graph_containment_proj IG) e \<in> verts (instance_graph_containment_proj IG)"
        unfolding instance_graph_containment_proj_def
        using structure_edges_wellformed
        by simp
    next
      fix e
      assume "e \<in> arcs (instance_graph_containment_proj IG)"
      then have "e \<in> { e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) }"
        unfolding instance_graph_containment_proj_def
        by simp
      then show "head (instance_graph_containment_proj IG) e \<in> verts (instance_graph_containment_proj IG)"
        unfolding instance_graph_containment_proj_def
        using structure_edges_wellformed
        by simp
    qed
  next
    show "\<And>p. \<not>pre_digraph.cycle (instance_graph_containment_proj IG) p"
      by (fact validity_containment)
  qed
  then show "irrefl ((edge_to_tuple ` { e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) })\<^sup>+)"
    unfolding pre_digraph.arc_to_tuple_def edge_to_tuple_def instance_graph_containment_proj_def
    by simp
qed

lemma (in instance_graph) validity_containment_alt':
  shows "irrefl ((edge_to_tuple ` { e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) })\<^sup>+)"
proof (intro validity_containment_alt)
  show "\<And>e. e \<in> E IG \<Longrightarrow> type\<^sub>e e \<in> contains (TG IG) \<Longrightarrow> src e \<in> N IG \<and> tgt e \<in> N IG"
    by fastforce
next
  show "\<And>p. \<not>pre_digraph.cycle (instance_graph_containment_proj IG) p"
    by simp
qed

lemma validity_containmentI[intro]:
  assumes structure_edges_wellformed: "\<And>e. e \<in> E IG \<Longrightarrow> type\<^sub>e e \<in> contains (TG IG) \<Longrightarrow> src e \<in> N IG \<and> tgt e \<in> N IG"
  assumes irrefl_contains_edges: "irrefl ((edge_to_tuple ` { e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) })\<^sup>+)"
  shows "\<not>pre_digraph.cycle (instance_graph_containment_proj IG) p"
proof (intro wf_digraph.irrefl_trancl_impl_acyclic)
  show "wf_digraph (instance_graph_containment_proj IG)"
  proof (intro wf_digraph.intro)
    fix e
    assume "e \<in> arcs (instance_graph_containment_proj IG)"
    then have "e \<in> { e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) }"
      unfolding instance_graph_containment_proj_def
      by simp
    then show "tail (instance_graph_containment_proj IG) e \<in> verts (instance_graph_containment_proj IG)"
      unfolding instance_graph_containment_proj_def
      using structure_edges_wellformed
      by simp
  next
    fix e
    assume "e \<in> arcs (instance_graph_containment_proj IG)"
    then have "e \<in> { e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) }"
      unfolding instance_graph_containment_proj_def
      by simp
    then show "head (instance_graph_containment_proj IG) e \<in> verts (instance_graph_containment_proj IG)"
      unfolding instance_graph_containment_proj_def
      using structure_edges_wellformed
      by simp
  qed
next
  have "pre_digraph.arc_to_tuple (instance_graph_containment_proj IG) ` arcs (instance_graph_containment_proj IG) =
    edge_to_tuple ` { e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) }"
  proof
    show "pre_digraph.arc_to_tuple (instance_graph_containment_proj IG) ` arcs (instance_graph_containment_proj IG)
      \<subseteq> edge_to_tuple ` {e \<in> E IG. type\<^sub>e e \<in> contains (TG IG)}"
    proof
      fix x
      assume "x \<in> pre_digraph.arc_to_tuple (instance_graph_containment_proj IG) ` arcs (instance_graph_containment_proj IG)"
      then show "x \<in> edge_to_tuple ` {e \<in> E IG. type\<^sub>e e \<in> contains (TG IG)}"
      proof
        fix xa
        assume x_is_xa: "x = pre_digraph.arc_to_tuple (instance_graph_containment_proj IG) xa"
        assume "xa \<in> arcs (instance_graph_containment_proj IG)"
        then have "pre_digraph.arc_to_tuple (instance_graph_containment_proj IG) xa
          \<in> edge_to_tuple ` {e \<in> E IG. type\<^sub>e e \<in> contains (TG IG)}"
          unfolding instance_graph_containment_proj_def pre_digraph.arc_to_tuple_def
          by simp
        then show "x \<in> edge_to_tuple ` {e \<in> E IG. type\<^sub>e e \<in> contains (TG IG)}"
          by (simp add: x_is_xa)
      qed
    qed
  next
    show "edge_to_tuple ` {e \<in> E IG. type\<^sub>e e \<in> contains (TG IG)}
      \<subseteq> pre_digraph.arc_to_tuple (instance_graph_containment_proj IG) ` arcs (instance_graph_containment_proj IG)"
    proof
      fix x
      assume "x \<in> edge_to_tuple ` {e \<in> E IG. type\<^sub>e e \<in> contains (TG IG)}"
      then show "x \<in> pre_digraph.arc_to_tuple (instance_graph_containment_proj IG) ` arcs (instance_graph_containment_proj IG)"
        unfolding instance_graph_containment_proj_def pre_digraph.arc_to_tuple_def edge_to_tuple_def
        by simp
    qed
  qed
  then show "irrefl ((pre_digraph.arc_to_tuple (instance_graph_containment_proj IG) ` arcs (instance_graph_containment_proj IG))\<^sup>+)"
    using irrefl_contains_edges
    by simp
qed

section "Validity of trivial instance graphs"

definition ig_empty :: "('nt, 'lt, 'id) instance_graph" where
  [simp]: "ig_empty = \<lparr>
    TG = tg_empty,
    Id = {},
    N = {},
    E = {},
    ident = (\<lambda>x. undefined)
  \<rparr>"

lemma ig_empty_correct[simp]: "instance_graph ig_empty"
proof (intro instance_graph.intro)
  show "type_graph (TG ig_empty)"
    unfolding ig_empty_def
    using tg_empty_correct
    by simp
next
  fix p :: "(('nt, 'lt) NodeDef \<times> ('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) \<times> ('nt, 'lt) NodeDef) awalk"
  show "\<not>pre_digraph.cycle (instance_graph_containment_proj ig_empty) p"
    unfolding instance_graph_containment_proj_def pre_digraph.cycle_def pre_digraph.awalk_def
    by simp
qed (simp_all)

lemma ig_empty_any_type_graph_correct[simp]:
  assumes instance_graph_type_graph: "type_graph (TG IG)"
  assumes instance_graph_id: "Id IG = {}"
  assumes instance_graph_nodes: "N IG = {}"
  assumes instance_graph_edges: "E IG = {}"
  assumes instance_graph_ident: "ident IG = (\<lambda>x. undefined)"
  shows "instance_graph IG"
proof (intro instance_graph.intro)
  fix p
  show "\<not>pre_digraph.cycle (instance_graph_containment_proj IG) p"
    unfolding instance_graph_containment_proj_def pre_digraph.cycle_def pre_digraph.awalk_def
    by (simp add: instance_graph_nodes)
qed (simp_all add: assms)

end


theory RTMax_RT
  imports RT
begin

section \<open>Mapping from RTMax to RT\<close>

definition mkRT1 :: "'a rtprocess \<Rightarrow> 'a rtprocess" where
  "mkRT1 P = {x. \<exists>y\<in>P. x \<le>\<^sub>\<R>\<^sub>\<T> y}"

lemma subset_mkRT1:
  "P \<subseteq> mkRT1 P"
  unfolding mkRT1_def using leq_rttrace_refl by blast

lemma mkRT1_wf:
  assumes "\<forall>x\<in>P. rtWF x"
  shows "\<forall> x \<in> mkRT1 P. rtWF x"
  using assms unfolding mkRT1_def
proof auto
  fix x xa :: "'a rttrace"
  have "rtWF xa \<Longrightarrow> x \<le>\<^sub>\<R>\<^sub>\<T> xa \<Longrightarrow> rtWF x"
    by (induct x xa rule:leq_rttrace.induct, auto)
  then show "\<forall>x\<in>P. rtWF x \<Longrightarrow> xa \<in> P \<Longrightarrow> x \<le>\<^sub>\<R>\<^sub>\<T> xa \<Longrightarrow> rtWF x"
    by auto
qed

lemma RT1_mkRT1:
  "RT1 (mkRT1 P)"
  unfolding RT1_def mkRT1_def using leq_rttrace_trans by blast

lemma RT2_mkRT1:
  assumes "RTM1 P" "RTM2 P"
  shows "RT2 (mkRT1 P)"
  using assms unfolding RTM1_def RTM2_def RT2_def mkRT1_def
proof auto
  fix \<rho> \<sigma> X Y x
  assume RTM1_P: "\<forall>\<rho>. (\<exists>\<sigma>. \<sigma> \<in> P \<and> \<rho> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<sigma>) \<longrightarrow> \<rho> \<in> P"
  assume RTM2_P: "\<forall>\<rho> X e. \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> RTEmptyTail \<in> P \<and> e \<notin> X \<longrightarrow> \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P"
  assume Y_assm: "\<forall>e\<in>Y. \<forall>x\<in>P. \<not> \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> x"
  assume x_assm: "\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma> \<le>\<^sub>\<R>\<^sub>\<T> x"
  assume x_in_P: "x \<in> P"

  have "\<exists> x\<rho> xX x\<sigma>. x = x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma> \<and> X \<subseteq> xX \<and> subset_rttrace_init \<rho> x\<rho>"
    using x_assm apply -
  proof (induct x \<rho> rule:leq_rttrace_rttrace_init_max.induct, auto)
    fix x
    assume "RTEmptyInit @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma> \<le>\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T>"
    then show "\<exists>x\<rho> xX. (\<exists>x\<sigma>. \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> = x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma>) \<and> X \<subseteq> xX \<and> subset_rttrace_init RTEmptyInit x\<rho>"
      apply (rule_tac x=RTEmptyInit in exI, auto, cases x, auto, cases \<sigma>, auto)
      by (rule_tac x=x2 in exI, auto, metis rttrace_with_refusal.simps(3), cases \<sigma>, auto)
  next
    fix v va vb
    assume "RTEmptyInit @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma> \<le>\<^sub>\<R>\<^sub>\<T> (v #\<^sub>\<R>\<^sub>\<T> va #\<^sub>\<R>\<^sub>\<T> vb)"
    then show "\<exists>x\<rho> xX. (\<exists>x\<sigma>. (v #\<^sub>\<R>\<^sub>\<T> va #\<^sub>\<R>\<^sub>\<T> vb) = x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma>) \<and> X \<subseteq> xX \<and> subset_rttrace_init RTEmptyInit x\<rho>"
      apply (rule_tac x=RTEmptyInit in exI, auto, cases v, auto, cases \<sigma>, auto)
      by (rule_tac x=x2 in exI, auto, metis rttrace_with_refusal.simps(2), cases \<sigma>, auto)
  next
    fix v va vb vc vd ve
    assume ind_hyp: "ve @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma> \<le>\<^sub>\<R>\<^sub>\<T> vb \<Longrightarrow>
        \<exists>x\<rho> xX. (\<exists>x\<sigma>. vb = x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma>) \<and> X \<subseteq> xX \<and> subset_rttrace_init ve x\<rho>"
    assume case_assm: "(vc #\<^sub>\<R>\<^sub>\<T> vd #\<^sub>\<R>\<^sub>\<T> (ve @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma>)) \<le>\<^sub>\<R>\<^sub>\<T> (v #\<^sub>\<R>\<^sub>\<T> va #\<^sub>\<R>\<^sub>\<T> vb)"
    then have "(ve @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma>) \<le>\<^sub>\<R>\<^sub>\<T> vb"
      by (cases vc, auto, (cases v, auto)+)
    then obtain x\<rho> xX x\<sigma> where "vb = x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma> \<and> X \<subseteq> xX \<and> subset_rttrace_init ve x\<rho>"
      using ind_hyp by auto
    then show "\<exists>x\<rho> xX. (\<exists>x\<sigma>. (v #\<^sub>\<R>\<^sub>\<T> va #\<^sub>\<R>\<^sub>\<T> vb) = x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma>) \<and> X \<subseteq> xX \<and> subset_rttrace_init (RTEventInit vc vd ve) x\<rho>"
      using case_assm apply (rule_tac x="RTEventInit v va x\<rho>" in exI, auto, cases v, auto)
      apply (metis leq_rttrace.simps(6) leq_rttrace.simps(9) rtrefusal.exhaust subset_rttrace_init.simps(2))
      by (rule_tac x=xX in exI, auto, cases vc, auto)
  qed
  then obtain x\<rho> xX x\<sigma> where x_def: "x = x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma> \<and> X \<subseteq> xX \<and> subset_rttrace_init \<rho> x\<rho>"
    by auto
  then have "x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> RTEmptyTail \<in> P"
    using x_in_P
  proof auto
    assume "x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma> \<in> P"
    also have "x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> RTEmptyTail \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma>"
      by (induct x\<rho>, auto, cases x\<sigma>, auto, case_tac x1, auto)
    then show "x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> RTEmptyTail \<in> P"
      using RTM1_P calculation by blast
  qed
  then have "Y \<subseteq> xX"
    apply (auto)
  proof (rule ccontr)
    fix e
    assume inner_assms: "x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> RTEmptyTail \<in> P" "e \<in> Y" "e \<notin> xX"
    then have "x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P"
      using RTM2_P by auto
    then have "\<not> \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>"
      using Y_assm inner_assms(2) by blast
    also have "subset_rttrace_init \<rho> x\<rho> \<and> X \<subseteq> xX"
      using x_def by auto
    then have "\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>"
      by (induct \<rho> x\<rho> rule:subset_rttrace_init.induct, auto, case_tac Y, auto)
    then show False
      using calculation by auto
  qed
  then have "X \<union> Y \<subseteq> xX \<and> subset_rttrace_init \<rho> x\<rho> \<and> \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma> \<le>\<^sub>\<R>\<^sub>\<T> x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma>"
    using x_assm x_def by blast
  then have "\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X \<union> Y]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma> \<le>\<^sub>\<R>\<^sub>\<T> x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma>"
    apply (induct \<rho> x\<rho> rule:subset_rttrace_init.induct, auto)
    by (cases \<sigma>, auto, cases x\<sigma>, auto, cases x\<sigma>, auto, case_tac Ya, auto)
  then show "\<exists>x\<in>P. \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X \<union> Y]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma> \<le>\<^sub>\<R>\<^sub>\<T> x"
    using x_def x_in_P by (rule_tac x="x\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[xX]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> x\<sigma>" in bexI, auto)
qed

lemma leq_rttrace_leq_rttrace_max:
  "\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> xa \<Longrightarrow>
    \<exists> xa\<rho> X Y. xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> xa \<and> subset_rttrace_init \<rho> xa\<rho> \<and> x \<subseteq>\<^sub>\<R>\<^sub>\<T> X \<and> y \<subseteq>\<^sub>\<R>\<^sub>\<T> Y"
proof (induct xa \<rho> rule:leq_rttrace_rttrace_init_max.induct, auto)
  fix v va vb
  assume "x #\<^sub>\<R>\<^sub>\<T> e #\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> v #\<^sub>\<R>\<^sub>\<T> va #\<^sub>\<R>\<^sub>\<T> vb"
  then show "\<exists>xa\<rho> X Y. xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> v #\<^sub>\<R>\<^sub>\<T> va #\<^sub>\<R>\<^sub>\<T> vb \<and> subset_rttrace_init RTEmptyInit xa\<rho> \<and> x \<subseteq>\<^sub>\<R>\<^sub>\<T> X \<and> y \<subseteq>\<^sub>\<R>\<^sub>\<T> Y"
    apply (cases "(x #\<^sub>\<R>\<^sub>\<T> e #\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T>, v #\<^sub>\<R>\<^sub>\<T> va #\<^sub>\<R>\<^sub>\<T> vb)" rule:leq_rttrace.cases, auto)
    apply (cases vb, auto, rule_tac x="RTEmptyInit" in exI, auto)
    apply (metis leq_rttrace.simps(2) leq_rttrace.simps(3) leq_rttrace_max_refl subset_refusal.elims(3))
    apply (cases vb, auto, rule_tac x="RTEmptyInit" in exI, auto, case_tac "(y, x21)" rule:rtrefusal_cases2, auto)
    apply (metis (mono_tags) leq_rttrace_max.simps(1) leq_rttrace_max.simps(6))+
    apply (metis leq_rttrace_max.simps(4) leq_rttrace_max.simps(6) subset_refusal.simps(3))
    apply (cases vb, auto, rule_tac x="RTEmptyInit" in exI, auto, case_tac "(y, x1)" rule:rtrefusal_cases2, auto)
    apply (metis (mono_tags) leq_rttrace_max_refl)+
    apply (metis leq_rttrace_max_refl subset_refusal.simps(3))
    apply (cases vb, auto, rule_tac x="RTEmptyInit" in exI, auto, case_tac "(y, x21)" rule:rtrefusal_cases2, auto)
    apply (metis leq_rttrace_max.simps(1) leq_rttrace_max.simps(8))
    apply (metis leq_rttrace_max.simps(1) leq_rttrace_max.simps(7))
    apply (metis leq_rttrace_max.simps(4) leq_rttrace_max.simps(8) subset_refusal.simps(3))
    apply (cases vb, auto, rule_tac x="RTEmptyInit" in exI, auto, case_tac "(y, x1)" rule:rtrefusal_cases2, auto)
    apply (metis (mono_tags) leq_rttrace_max_refl subset_refusal.simps(3))+
    apply (case_tac "(y, x21)" rule:rtrefusal_cases2, auto)
    apply (metis (mono_tags) leq_rttrace_max.simps(1) leq_rttrace_max.simps(8) rttrace_with_refusal.simps(2) subset_refusal.simps(3) subset_rttrace_init.simps(1))+
    by (metis leq_rttrace_max.simps(4) leq_rttrace_max.simps(8) rttrace_with_refusal.simps(2) subset_refusal.simps(3) subset_rttrace_init.simps(1))
next
  fix v va vb vc vd ve
  assume ind_hyp: "ve @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> vb \<Longrightarrow>
      \<exists>xa\<rho> X Y. xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> vb \<and> subset_rttrace_init ve xa\<rho> \<and> x \<subseteq>\<^sub>\<R>\<^sub>\<T> X \<and> y \<subseteq>\<^sub>\<R>\<^sub>\<T> Y"
  assume case_assm: "vc #\<^sub>\<R>\<^sub>\<T> vd #\<^sub>\<R>\<^sub>\<T> (ve @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T>) \<le>\<^sub>\<R>\<^sub>\<T> v #\<^sub>\<R>\<^sub>\<T> va #\<^sub>\<R>\<^sub>\<T> vb"
  then have "ve @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> vb"
    by (cases "(vc,v)" rule:rtrefusal_cases2, auto)
  then obtain xa\<rho> X Y where "xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> vb \<and> subset_rttrace_init ve xa\<rho> \<and> x \<subseteq>\<^sub>\<R>\<^sub>\<T> X \<and> y \<subseteq>\<^sub>\<R>\<^sub>\<T> Y"
    by (metis ind_hyp)
  then show "\<exists>xa\<rho> X Y.
        xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> v #\<^sub>\<R>\<^sub>\<T> va #\<^sub>\<R>\<^sub>\<T> vb \<and> subset_rttrace_init (RTEventInit vc vd ve) xa\<rho> \<and> x \<subseteq>\<^sub>\<R>\<^sub>\<T> X \<and> y \<subseteq>\<^sub>\<R>\<^sub>\<T> Y"
    using case_assm apply (cases "(vc,v)" rule:rtrefusal_cases2, auto)
    apply (metis leq_rttrace_max.simps(6) rttrace_with_refusal.simps(1) subset_rttrace_init.simps(2))
    apply (metis leq_rttrace_max.simps(7) rttrace_with_refusal.simps(1) subset_rttrace_init.simps(2))
    apply (metis leq_rttrace_max.simps(8) rttrace_with_refusal.simps(1) subset_rttrace_init.simps(4))
    done
qed

lemma RT3_mkRT1:
  assumes "RTM1 P" "RT3 P"
  shows "RT3 (mkRT1 P)"
  using assms unfolding RTM1_def RT3_def mkRT1_def
proof auto
  fix \<rho> x y e xa
  assume RTM1_P: "\<forall>\<rho>. (\<exists>\<sigma>. \<sigma> \<in> P \<and> \<rho> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<sigma>) \<longrightarrow> \<rho> \<in> P"
  assume RT3_P: "\<forall>\<rho>. (\<exists>x y e. \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P) \<longrightarrow> no_tick \<rho>"
  assume xa_in_P: "xa \<in> P"
  assume xa_assm: "\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> xa"

  obtain xa\<rho> X Y where xa\<rho>_assms: "xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> xa \<and> subset_rttrace_init \<rho> xa\<rho> \<and> x \<subseteq>\<^sub>\<R>\<^sub>\<T> X \<and> y \<subseteq>\<^sub>\<R>\<^sub>\<T> Y"
    by (metis leq_rttrace_leq_rttrace_max xa_assm)
  then have "xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P"
    by (metis RTM1_P xa_in_P)
  then have "no_tick xa\<rho>"
    by (metis RT3_P)
  then show "no_tick \<rho>"
    by (metis subset_rttrace_init_no_tick2 xa\<rho>_assms)
qed

thm RT4_def

lemma RT4_mkRT1:
  assumes "RTM1 P" "RT4 P"
  shows "RT4 (mkRT1 P)"
  using assms unfolding RTM1_def RT4_def mkRT1_def
proof (clarsimp)
  fix \<rho> x y xa
  assume RTM1_P: "\<forall>\<rho>. (\<exists>\<sigma>. \<sigma> \<in> P \<and> \<rho> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<sigma>) \<longrightarrow> \<rho> \<in> P"
  assume RT3_P: "\<forall>\<rho> x. (\<exists>y. \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P) \<longrightarrow> x = \<bullet>\<^sub>\<R>\<^sub>\<T> \<and> \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>[UNIV]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P"
  assume xa_in_P: "xa \<in> P"
  assume xa_assm: "\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> xa"

  obtain xa\<rho> X Y where xa\<rho>_assms: "xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> xa \<and> subset_rttrace_init \<rho> xa\<rho> \<and> x \<subseteq>\<^sub>\<R>\<^sub>\<T> X \<and> y \<subseteq>\<^sub>\<R>\<^sub>\<T> Y"
    by (metis leq_rttrace_leq_rttrace_max xa_assm)
  then have "xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P"
    by (metis RTM1_P xa_in_P)
  then have "x = \<bullet>\<^sub>\<R>\<^sub>\<T> \<and> xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>[UNIV]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P \<and> subset_rttrace_init \<rho> xa\<rho>"
    by (metis RT3_P rtrefusal.exhaust subset_refusal.simps(2) xa\<rho>_assms)
  then have "x = \<bullet>\<^sub>\<R>\<^sub>\<T> \<and> xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>[UNIV]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P
    \<and> \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>[UNIV]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>[UNIV]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>"
  proof auto
    show "subset_rttrace_init \<rho> xa\<rho> \<Longrightarrow>
      \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>[UNIV]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> xa\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>[UNIV]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>"
      by (induct \<rho> xa\<rho> rule:subset_rttrace_init.induct, auto, case_tac Y, auto)
  qed
  then show "x = \<bullet>\<^sub>\<R>\<^sub>\<T> \<and> (\<exists>x\<in>P. \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>[UNIV]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<le>\<^sub>\<R>\<^sub>\<T> x)"
    by (auto)
qed

lemma RT_mkRT1:
  assumes "RTM P"
  shows "RT (mkRT1 P)"
  using assms unfolding RTM_def RT_def
  by (metis (mono_tags, lifting) CollectI MRT0_def RT1_mkRT1 RT2_mkRT1 RT3_mkRT1 RT4_mkRT1 leq_rttrace.simps(1) mkRT1_def mkRT1_wf)

lemma mkRT1_mono:
  "P \<sqsubseteq>\<^sub>\<R>\<^sub>\<T> Q \<Longrightarrow> mkRT1 P \<sqsubseteq>\<^sub>\<R>\<^sub>\<T> mkRT1 Q"
  unfolding mkRT1_def refinesRT_def by auto

section \<open>Mapping from RT to RTMax\<close>

definition unRT1 :: "'a rtevent rtprocess \<Rightarrow> 'a rtevent rtprocess" where
  "unRT1 P = \<Union>{x. RTM1 x \<and> RTM2 x \<and> RT4 x \<and> (mkRT1 x) \<subseteq> P}"

lemma unRT1_subset:
  "unRT1 P \<subseteq> P"
  unfolding unRT1_def mkRT1_def
proof auto
  fix x :: "'a rtevent rttrace" and X
  assume x_in_X: "x \<in> X"
  assume P_subset: "{x. \<exists>xa\<in>X. x \<le>\<^sub>\<R>\<^sub>\<T> xa} \<subseteq> P"

  have "x \<in> {x. \<exists>xa\<in>X. x \<le>\<^sub>\<R>\<^sub>\<T> xa}"
    by (metis (no_types, lifting) CollectI leq_rttrace_refl x_in_X)
  then show "x \<in> P"
    by (metis (no_types, lifting) P_subset rev_subsetD)
qed

lemma unRT1_wf:
  assumes "\<forall>x\<in>P. rtWF x"
  shows "\<forall>x\<in>(unRT1 P). rtWF x"
  using assms unRT1_subset by auto

lemma MRT0_unRT1:
  assumes "MRT0 P" "RT1 P"
  shows "MRT0 (unRT1 P)"
  using assms unfolding unRT1_def MRT0_def
proof auto
  assume MRT0_P: "\<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P"
  assume RT1_P: "RT1 P"

  show "\<exists>x. RTM1 x \<and> RTM2 x \<and> RT4 x \<and> mkRT1 x \<subseteq> P \<and> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> x"
    apply (rule_tac x="{\<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>}" in exI, auto)
    apply (metis RTM1_def leq_rttrace_max.simps(1) leq_rttrace_max_antisym singletonD)
    apply (metis RTM2_def leq_rttrace_max.simps(1) leq_rttrace_max.simps(3) rttrace.simps(4) rttrace_with_refusal.elims rttrace_with_refusal.simps(3) singletonD)
    apply (metis RT4_def rttrace.distinct(1) rttrace_with_refusal.elims rttrace_with_refusal.simps(2) singletonD)
    by (smt MRT0_P RT1_P RT1_def mem_Collect_eq mkRT1_def singletonD)
qed

lemma RTM1_unRT1: "RTM1 (unRT1 P)"
  unfolding unRT1_def RTM1_def by auto

lemma RTM2_unRT1: "RTM2 (unRT1 P)"
  unfolding unRT1_def RTM2_def by auto

lemma RT3_unRT1:
  assumes "RT3 P"
  shows "RT3 (unRT1 P)"
  using assms unfolding RT3_def by (auto, metis contra_subsetD unRT1_subset)

lemma RT4_unRT1: "RT4 (unRT1 P)"
  unfolding unRT1_def RT4_def by auto

lemma RTM_unRT1:
  assumes "RT P"
  shows "RTM (unRT1 P)"
  using assms unfolding RT_def RTM_def
  by (metis MRT0_unRT1 RT3_unRT1 RT4_unRT1 RTM1_unRT1 RTM2_unRT1 unRT1_wf)

lemma unRT1_mono:
  "P \<sqsubseteq>\<^sub>\<R>\<^sub>\<T> Q \<Longrightarrow> unRT1 P \<sqsubseteq>\<^sub>\<R>\<^sub>\<T> unRT1 Q"
  unfolding refinesRT_def unRT1_def by auto

section \<open>Galois connection between RTMax and RT\<close>

lemma unRT1_mkRT1_Galois:
  assumes RT1_P: "RT1 P"
  assumes RTM1_Q: "RTM1 Q" and RTM2_Q: "RTM2 Q" and RT4_Q: "RT4 Q"
  shows "(unRT1 P \<sqsubseteq>\<^sub>\<R>\<^sub>\<T> Q) = (P \<sqsubseteq>\<^sub>\<R>\<^sub>\<T> mkRT1 Q)"
  unfolding mkRT1_def refinesRT_def
proof auto
  fix x xa
  assume Q_subset_unRT1_P: "Q \<subseteq> unRT1 P"
  assume xa_in_Q: "xa \<in> Q"
  assume x_leqRT_xa: "x \<le>\<^sub>\<R>\<^sub>\<T> xa"

  have "Q \<subseteq> P"
    using Q_subset_unRT1_P unRT1_subset by blast
  then have "xa \<in> P"
    using xa_in_Q by blast
  then show "x \<in> P"
    using RT1_P x_leqRT_xa unfolding RT1_def by blast
next
  fix x
  assume "{x. \<exists>xa\<in>Q. x \<le>\<^sub>\<R>\<^sub>\<T> xa} \<subseteq> P" "x \<in> Q"
  then show "x \<in> unRT1 P"
    unfolding unRT1_def mkRT1_def by (auto, rule_tac x=Q in exI, auto simp add: assms)
qed

end


(*  Title:       variants/b_fwdrreps/Quality_Increases.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
*)

section "The quality increases predicate"

theory B_Quality_Increases
imports B_Aodv_Predicates B_Fresher
begin

definition quality_increases :: "state \<Rightarrow> state \<Rightarrow> bool"
where "quality_increases \<xi> \<xi>' \<equiv> (\<forall>dip\<in>kD(rt \<xi>). dip \<in> kD(rt \<xi>') \<and> rt \<xi> \<sqsubseteq>\<^bsub>dip\<^esub> rt \<xi>')
                                               \<and> (\<forall>dip. sqn (rt \<xi>) dip \<le> sqn (rt \<xi>') dip)"

lemma quality_increasesI [intro!]:
  assumes "\<And>dip. dip \<in> kD(rt \<xi>) \<Longrightarrow> dip \<in> kD(rt \<xi>')"
      and "\<And>dip. \<lbrakk> dip \<in> kD(rt \<xi>); dip \<in> kD(rt \<xi>') \<rbrakk> \<Longrightarrow> rt \<xi> \<sqsubseteq>\<^bsub>dip\<^esub> rt \<xi>'"
      and "\<And>dip. sqn (rt \<xi>) dip \<le> sqn (rt \<xi>') dip"
    shows "quality_increases \<xi> \<xi>'"
  unfolding quality_increases_def using assms by clarsimp

lemma quality_increasesE [elim]:
    fixes dip
  assumes "quality_increases \<xi> \<xi>'"
      and "dip\<in>kD(rt \<xi>)"
      and "\<lbrakk> dip \<in> kD(rt \<xi>'); rt \<xi> \<sqsubseteq>\<^bsub>dip\<^esub> rt \<xi>'; sqn (rt \<xi>) dip \<le> sqn (rt \<xi>') dip \<rbrakk> \<Longrightarrow> R dip \<xi> \<xi>'"
    shows "R dip \<xi> \<xi>'"
  using assms unfolding quality_increases_def by clarsimp

lemma quality_increases_rt_fresherD [dest]:
    fixes ip
  assumes "quality_increases \<xi> \<xi>'"
      and "ip\<in>kD(rt \<xi>)"
    shows "rt \<xi> \<sqsubseteq>\<^bsub>ip\<^esub> rt \<xi>'"
  using assms by auto

lemma quality_increases_sqnE [elim]:
    fixes dip
  assumes "quality_increases \<xi> \<xi>'"
      and "sqn (rt \<xi>) dip \<le> sqn (rt \<xi>') dip \<Longrightarrow> R dip \<xi> \<xi>'"
    shows "R dip \<xi> \<xi>'"
  using assms unfolding quality_increases_def by clarsimp

lemma quality_increases_refl [intro, simp]: "quality_increases \<xi> \<xi>"
  by rule simp_all

lemma strictly_fresher_quality_increases_right [elim]:
    fixes \<sigma> \<sigma>' dip
  assumes "rt (\<sigma> i) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)"
      and qinc: "quality_increases (\<sigma> nhip) (\<sigma>' nhip)"
      and "dip\<in>kD(rt (\<sigma> nhip))"
    shows "rt (\<sigma> i) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma>' nhip)"
  proof -
    from qinc have "rt (\<sigma> nhip) \<sqsubseteq>\<^bsub>dip\<^esub> rt (\<sigma>' nhip)" using \<open>dip\<in>kD(rt (\<sigma> nhip))\<close>
      by auto
    with \<open>rt (\<sigma> i) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)\<close> show ?thesis ..
  qed

lemma kD_quality_increases [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
    shows "i\<in>kD(rt \<xi>')"
  using assms by auto

lemma kD_nsqn_quality_increases [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
    shows "i\<in>kD(rt \<xi>') \<and> nsqn (rt \<xi>) i \<le> nsqn (rt \<xi>') i"
  proof -
    from assms have "i\<in>kD(rt \<xi>')" ..
    moreover with assms have "rt \<xi> \<sqsubseteq>\<^bsub>i\<^esub> rt \<xi>'" by auto
    ultimately have "nsqn (rt \<xi>) i \<le> nsqn (rt \<xi>') i"
      using \<open>i\<in>kD(rt \<xi>)\<close> by - (erule(2) rt_fresher_imp_nsqn_le)
    with \<open>i\<in>kD(rt \<xi>')\<close> show ?thesis ..
  qed

lemma nsqn_quality_increases [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
    shows "nsqn (rt \<xi>) i \<le> nsqn (rt \<xi>') i"
  using assms by (rule kD_nsqn_quality_increases [THEN conjunct2])

lemma kD_nsqn_quality_increases_trans [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "s \<le> nsqn (rt \<xi>) i"
      and "quality_increases \<xi> \<xi>'"
    shows "i\<in>kD(rt \<xi>') \<and> s \<le> nsqn (rt \<xi>') i"
  proof
    from \<open>i\<in>kD(rt \<xi>)\<close> and \<open>quality_increases \<xi> \<xi>'\<close> show "i\<in>kD(rt \<xi>')" ..
  next
    from \<open>i\<in>kD(rt \<xi>)\<close> and \<open>quality_increases \<xi> \<xi>'\<close> have "nsqn (rt \<xi>) i \<le> nsqn (rt \<xi>') i" ..
    with \<open>s \<le> nsqn (rt \<xi>) i\<close> show "s \<le> nsqn (rt \<xi>') i" by (rule le_trans)
  qed

lemma nsqn_quality_increases_nsqn_lt_lt [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
     and "s < nsqn (rt \<xi>) i"
    shows "s < nsqn (rt \<xi>') i"
  proof -
    from assms(1-2) have "nsqn (rt \<xi>) i \<le> nsqn (rt \<xi>') i" ..
    with \<open>s < nsqn (rt \<xi>) i\<close> show "s < nsqn (rt \<xi>') i" by simp
  qed

lemma nsqn_quality_increases_dhops [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
      and "nsqn (rt \<xi>) i = nsqn (rt \<xi>') i"
    shows "the (dhops (rt \<xi>) i) \<ge> the (dhops (rt \<xi>') i)"
  using assms unfolding quality_increases_def
  by (clarsimp) (drule(1) bspec, clarsimp simp: rt_fresher_def2)

lemma nsqn_quality_increases_nsqn_eq_le [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
      and "s = nsqn (rt \<xi>) i"
    shows "s < nsqn (rt \<xi>') i \<or> (s = nsqn (rt \<xi>') i \<and> the (dhops (rt \<xi>) i) \<ge> the (dhops (rt \<xi>') i))"
  using assms by (metis nat_less_le nsqn_quality_increases nsqn_quality_increases_dhops)

lemma quality_increases_rreq_rrep_props [elim]:
    fixes sn ip hops sip
  assumes qinc: "quality_increases (\<sigma> sip) (\<sigma>' sip)"
      and "1 \<le> sn"
      and *: "ip\<in>kD(rt (\<sigma> sip)) \<and> sn \<le> nsqn (rt (\<sigma> sip)) ip
                                \<and> (nsqn (rt (\<sigma> sip)) ip = sn
                                    \<longrightarrow> (the (dhops (rt (\<sigma> sip)) ip) \<le> hops
                                          \<or> the (flag (rt (\<sigma> sip)) ip) = inv))"
    shows "ip\<in>kD(rt (\<sigma>' sip)) \<and> sn \<le> nsqn (rt (\<sigma>' sip)) ip
                              \<and> (nsqn (rt (\<sigma>' sip)) ip = sn
                                  \<longrightarrow> (the (dhops (rt (\<sigma>' sip)) ip) \<le> hops
                                        \<or> the (flag (rt (\<sigma>' sip)) ip) = inv))"
      (is "_ \<and> ?nsqnafter")
  proof -
    from *  obtain "ip\<in>kD(rt (\<sigma> sip))" and "sn \<le> nsqn (rt (\<sigma> sip)) ip" by auto

    from \<open>quality_increases (\<sigma> sip) (\<sigma>' sip)\<close>
       have "sqn (rt (\<sigma> sip)) ip \<le> sqn (rt (\<sigma>' sip)) ip" ..
    from \<open>quality_increases (\<sigma> sip) (\<sigma>' sip)\<close> and \<open>ip\<in>kD (rt (\<sigma> sip))\<close>
      have "ip\<in>kD (rt (\<sigma>' sip))" ..

    from \<open>sn \<le> nsqn (rt (\<sigma> sip)) ip\<close> have ?nsqnafter
    proof
      assume "sn < nsqn (rt (\<sigma> sip)) ip"
      also from \<open>ip\<in>kD(rt (\<sigma> sip))\<close> and \<open>quality_increases (\<sigma> sip) (\<sigma>' sip)\<close>
        have "... \<le> nsqn (rt (\<sigma>' sip)) ip" ..
      finally have "sn < nsqn (rt (\<sigma>' sip)) ip" .
      thus ?thesis by simp
    next
      assume "sn = nsqn (rt (\<sigma> sip)) ip"
      with \<open>ip\<in>kD(rt (\<sigma> sip))\<close> and \<open>quality_increases (\<sigma> sip) (\<sigma>' sip)\<close>
        have "sn < nsqn (rt (\<sigma>' sip)) ip
              \<or> (sn = nsqn (rt (\<sigma>' sip)) ip
                 \<and> the (dhops (rt (\<sigma>' sip)) ip) \<le> the (dhops (rt (\<sigma> sip)) ip))" ..
      hence "sn < nsqn (rt (\<sigma>' sip)) ip
              \<or> (nsqn (rt (\<sigma>' sip)) ip = sn \<and> (the (dhops (rt (\<sigma>' sip)) ip) \<le> hops
                                                 \<or> the (flag (rt (\<sigma>' sip)) ip) = inv))"
      proof
        assume "sn < nsqn (rt (\<sigma>' sip)) ip" thus ?thesis ..
      next
        assume "sn = nsqn (rt (\<sigma>' sip)) ip
                \<and> the (dhops (rt (\<sigma> sip)) ip) \<ge> the (dhops (rt (\<sigma>' sip)) ip)"
        hence "sn = nsqn (rt (\<sigma>' sip)) ip"
          and "the (dhops (rt (\<sigma>' sip)) ip) \<le> the (dhops (rt (\<sigma> sip)) ip)" by auto

        from * and \<open>sn = nsqn (rt (\<sigma> sip)) ip\<close> have "the (dhops (rt (\<sigma> sip)) ip) \<le> hops
                                                       \<or> the (flag (rt (\<sigma> sip)) ip) = inv"
          by simp
        thus ?thesis
        proof
          assume "the (dhops (rt (\<sigma> sip)) ip) \<le> hops"
          with  \<open>the (dhops (rt (\<sigma>' sip)) ip) \<le> the (dhops (rt (\<sigma> sip)) ip)\<close>
           have "the (dhops (rt (\<sigma>' sip)) ip) \<le> hops" by simp
          with \<open>sn = nsqn (rt (\<sigma>' sip)) ip\<close> show ?thesis by simp
        next
          assume "the (flag (rt (\<sigma> sip)) ip) = inv"
          with \<open>ip\<in>kD(rt (\<sigma> sip))\<close> have "nsqn (rt (\<sigma> sip)) ip = sqn (rt (\<sigma> sip)) ip - 1" ..

          with \<open>sn \<ge> 1\<close> and \<open>sn = nsqn (rt (\<sigma> sip)) ip\<close>
            have "sqn (rt (\<sigma> sip)) ip > 1" by simp

          from \<open>ip\<in>kD(rt (\<sigma>' sip))\<close> show ?thesis
          proof (rule vD_or_iD)
            assume "ip\<in>iD(rt (\<sigma>' sip))"
            hence "the (flag (rt (\<sigma>' sip)) ip) = inv" ..
            with \<open>sn = nsqn (rt (\<sigma>' sip)) ip\<close> show ?thesis
              by simp
          next
            (* the tricky case: sn = nsqn (rt (\<sigma>' sip)) ip
                                \<and> ip\<in>iD(rt (\<sigma> sip))
                                \<and> ip\<in>vD(rt (\<sigma>' sip)) *)
            assume "ip\<in>vD(rt (\<sigma>' sip))"
            hence "nsqn (rt (\<sigma>' sip)) ip = sqn (rt (\<sigma>' sip)) ip" ..
            with \<open>sqn (rt (\<sigma> sip)) ip \<le> sqn (rt (\<sigma>' sip)) ip\<close>
              have "nsqn (rt (\<sigma>' sip)) ip \<ge> sqn (rt (\<sigma> sip)) ip" by simp

            with \<open>sqn (rt (\<sigma> sip)) ip > 1\<close>
              have "nsqn (rt (\<sigma>' sip)) ip > sqn (rt (\<sigma> sip)) ip - 1" by simp
            with \<open>nsqn (rt (\<sigma> sip)) ip = sqn (rt (\<sigma> sip)) ip - 1\<close>
              have "nsqn (rt (\<sigma>' sip)) ip > nsqn (rt (\<sigma> sip)) ip" by simp
            with \<open>sn = nsqn (rt (\<sigma> sip)) ip\<close> have "nsqn (rt (\<sigma>' sip)) ip > sn"
              by simp
            thus ?thesis ..
          qed
        qed
      qed
      thus ?thesis by (metis (mono_tags) le_cases not_le)
    qed
    with \<open>ip\<in>kD (rt (\<sigma>' sip))\<close> show "ip\<in>kD (rt (\<sigma>' sip)) \<and> ?nsqnafter" ..
  qed

lemma quality_increases_rreq_rrep_props':
    fixes sn ip hops sip
  assumes "\<forall>j. quality_increases (\<sigma> j) (\<sigma>' j)"
      and "1 \<le> sn"
      and *: "ip\<in>kD(rt (\<sigma> sip)) \<and> sn \<le> nsqn (rt (\<sigma> sip)) ip
                                \<and> (nsqn (rt (\<sigma> sip)) ip = sn
                                    \<longrightarrow> (the (dhops (rt (\<sigma> sip)) ip) \<le> hops
                                          \<or> the (flag (rt (\<sigma> sip)) ip) = inv))"
    shows "ip\<in>kD(rt (\<sigma>' sip)) \<and> sn \<le> nsqn (rt (\<sigma>' sip)) ip
                              \<and> (nsqn (rt (\<sigma>' sip)) ip = sn
                                  \<longrightarrow> (the (dhops (rt (\<sigma>' sip)) ip) \<le> hops
                                        \<or> the (flag (rt (\<sigma>' sip)) ip) = inv))"
  proof -
    from assms(1) have "quality_increases (\<sigma> sip) (\<sigma>' sip)" ..
    thus ?thesis using assms(2-3) by (rule quality_increases_rreq_rrep_props)
  qed

lemma rteq_quality_increases:
  assumes "\<forall>j. j \<noteq> i \<longrightarrow> quality_increases (\<sigma> j) (\<sigma>' j)"
      and "rt (\<sigma>' i) = rt (\<sigma> i)"
    shows "\<forall>j. quality_increases (\<sigma> j) (\<sigma>' j)"
  using assms by clarsimp (metis order_refl quality_increasesI rt_fresher_refl)

definition msg_fresh :: "(ip \<Rightarrow> state) \<Rightarrow> msg \<Rightarrow> bool"
where "msg_fresh \<sigma> m \<equiv>
         case m of Rreq hopsc _ _ _ _ oipc osnc sipc \<Rightarrow> osnc \<ge> 1 \<and> (sipc \<noteq> oipc \<longrightarrow>
                       oipc\<in>kD(rt (\<sigma> sipc)) \<and> nsqn (rt (\<sigma> sipc)) oipc \<ge> osnc
                       \<and> (nsqn (rt (\<sigma> sipc)) oipc = osnc
                             \<longrightarrow> (hopsc \<ge> the (dhops (rt (\<sigma> sipc)) oipc)
                                  \<or> the (flag (rt (\<sigma> sipc)) oipc) = inv)))
                   | Rrep hopsc dipc dsnc _ sipc \<Rightarrow> dsnc \<ge> 1 \<and> (sipc \<noteq> dipc \<longrightarrow>
                       dipc\<in>kD(rt (\<sigma> sipc)) \<and> nsqn (rt (\<sigma> sipc)) dipc \<ge> dsnc
                       \<and> (nsqn (rt (\<sigma> sipc)) dipc = dsnc
                             \<longrightarrow> (hopsc \<ge> the (dhops (rt (\<sigma> sipc)) dipc)
                                   \<or> the (flag (rt (\<sigma> sipc)) dipc) = inv)))
                   | Rerr destsc sipc \<Rightarrow> (\<forall>ripc\<in>dom(destsc). (ripc\<in>kD(rt (\<sigma> sipc))
                                         \<and> the (destsc ripc) - 1 \<le> nsqn (rt (\<sigma> sipc)) ripc))
                   | _ \<Rightarrow> True"

lemma msg_fresh [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
           msg_fresh \<sigma> (Rreq hops rreqid dip dsn dsk oip osn sip) =
                            (osn \<ge> 1 \<and> (sip \<noteq> oip \<longrightarrow> oip\<in>kD(rt (\<sigma> sip))
                                     \<and> nsqn (rt (\<sigma> sip)) oip \<ge> osn
                                     \<and> (nsqn (rt (\<sigma> sip)) oip = osn
                                           \<longrightarrow> (hops \<ge> the (dhops (rt (\<sigma> sip)) oip)
                                                \<or> the (flag (rt (\<sigma> sip)) oip) = inv))))"
  "\<And>hops dip dsn oip sip. msg_fresh \<sigma> (Rrep hops dip dsn oip sip) =
                            (dsn \<ge> 1 \<and> (sip \<noteq> dip \<longrightarrow> dip\<in>kD(rt (\<sigma> sip))
                                     \<and> nsqn (rt (\<sigma> sip)) dip \<ge> dsn
                                     \<and> (nsqn (rt (\<sigma> sip)) dip = dsn
                                           \<longrightarrow> (hops \<ge> the (dhops (rt (\<sigma> sip)) dip))
                                                 \<or> the (flag (rt (\<sigma> sip)) dip) = inv)))"
  "\<And>dests sip.            msg_fresh \<sigma> (Rerr dests sip) =
                            (\<forall>ripc\<in>dom(dests). (ripc\<in>kD(rt (\<sigma> sip))
                                     \<and> the (dests ripc) - 1 \<le> nsqn (rt (\<sigma> sip)) ripc))"
  "\<And>d dip.                msg_fresh \<sigma> (Newpkt d dip)   = True"
  "\<And>d dip sip.            msg_fresh \<sigma> (Pkt d dip sip)  = True"
  unfolding msg_fresh_def by simp_all

lemma msg_fresh_inc_sn [simp, elim]:
  "msg_fresh \<sigma> m \<Longrightarrow> rreq_rrep_sn m"
  by (cases m) simp_all

lemma recv_msg_fresh_inc_sn [simp, elim]:
  "orecvmsg (msg_fresh) \<sigma> m \<Longrightarrow> recvmsg rreq_rrep_sn m"
  by (cases m) simp_all

lemma rrep_nsqn_is_fresh [simp]:
  fixes \<sigma> msg hops dip dsn oip sip
  assumes "rreq_rrep_fresh (rt (\<sigma> sip)) (Rrep hops dip dsn oip sip)"
      and "rreq_rrep_sn (Rrep hops dip dsn oip sip)"
  shows "msg_fresh \<sigma> (Rrep hops dip dsn oip sip)"
        (is "msg_fresh \<sigma> ?msg")
  proof -
    let ?rt = "rt (\<sigma> sip)"
    from assms have "sip \<noteq> dip \<longrightarrow> dip\<in>kD(?rt) \<and> sqn ?rt dip = dsn \<and> the (flag ?rt dip) = val"
      by simp
    hence "sip \<noteq> dip \<longrightarrow> dip\<in>kD(?rt) \<and> nsqn ?rt dip \<ge> dsn"
    by clarsimp
    with assms show "msg_fresh \<sigma> ?msg"
      by clarsimp
  qed

lemma rerr_nsqn_is_fresh [simp]:
  fixes \<sigma> msg dests sip
  assumes "rerr_invalid (rt (\<sigma> sip)) (Rerr dests sip)"
  shows "msg_fresh \<sigma> (Rerr dests sip)"
        (is "msg_fresh \<sigma> ?msg")
  proof -
    let ?rt = "rt (\<sigma> sip)"
    from assms have *: "(\<forall>rip\<in>dom(dests). (rip\<in>iD(rt (\<sigma> sip))
                                     \<and> the (dests rip) = sqn (rt (\<sigma> sip)) rip))"
      by clarsimp
    have "(\<forall>rip\<in>dom(dests). (rip\<in>kD(rt (\<sigma> sip))
                                     \<and> the (dests rip) - 1 \<le> nsqn (rt (\<sigma> sip)) rip))"
    proof
      fix rip
      assume "rip \<in> dom dests"
      with * have "rip\<in>iD(rt (\<sigma> sip))" and "the (dests rip) = sqn (rt (\<sigma> sip)) rip"
        by auto

      from this(2) have "the (dests rip) - 1 = sqn (rt (\<sigma> sip)) rip - 1" by simp
      also have "... \<le> nsqn (rt (\<sigma> sip)) rip" by (rule sqn_nsqn)
      finally have "the (dests rip) - 1 \<le> nsqn (rt (\<sigma> sip)) rip" .

      with \<open>rip\<in>iD(rt (\<sigma> sip))\<close>
        show "rip\<in>kD(rt (\<sigma> sip)) \<and> the (dests rip) - 1 \<le> nsqn (rt (\<sigma> sip)) rip"
          by clarsimp
    qed
    thus "msg_fresh \<sigma> ?msg"
      by simp
  qed

lemma quality_increases_msg_fresh [elim]:
  assumes qinc: "\<forall>j. quality_increases (\<sigma> j) (\<sigma>' j)"
      and "msg_fresh \<sigma> m"
    shows "msg_fresh \<sigma>' m"
  using assms(2)
  proof (cases m)
    fix hops rreqid dip dsn dsk oip osn sip
    assume [simp]: "m = Rreq hops rreqid dip dsn dsk oip osn sip"
       and "msg_fresh \<sigma> m"
    then have "osn \<ge> 1" and "sip = oip \<or> (oip\<in>kD(rt (\<sigma> sip)) \<and> osn \<le> nsqn (rt (\<sigma> sip)) oip
                                           \<and> (nsqn (rt (\<sigma> sip)) oip = osn
                                                 \<longrightarrow> (the (dhops (rt (\<sigma> sip)) oip) \<le> hops
                                                      \<or> the (flag (rt (\<sigma> sip)) oip) = inv)))"
      by auto
    from this(2) show ?thesis
    proof
      assume "sip = oip" with \<open>osn \<ge> 1\<close> show ?thesis by simp
    next
      assume "oip\<in>kD(rt (\<sigma> sip)) \<and> osn \<le> nsqn (rt (\<sigma> sip)) oip
                                  \<and> (nsqn (rt (\<sigma> sip)) oip = osn
                                      \<longrightarrow> (the (dhops (rt (\<sigma> sip)) oip) \<le> hops
                                           \<or> the (flag (rt (\<sigma> sip)) oip) = inv))"
      moreover from qinc have "quality_increases (\<sigma> sip) (\<sigma>' sip)" ..
      ultimately have "oip\<in>kD(rt (\<sigma>' sip)) \<and> osn \<le> nsqn (rt (\<sigma>' sip)) oip
                                           \<and> (nsqn (rt (\<sigma>' sip)) oip = osn
                                              \<longrightarrow> (the (dhops (rt (\<sigma>' sip)) oip) \<le> hops
                                                    \<or> the (flag (rt (\<sigma>' sip)) oip) = inv))"
       using \<open>osn \<ge> 1\<close> by (rule quality_increases_rreq_rrep_props [rotated 2])
      with \<open>osn \<ge> 1\<close> show "msg_fresh \<sigma>' m"
        by (clarsimp)
    qed
  next
    fix hops dip dsn oip sip
    assume [simp]: "m = Rrep hops dip dsn oip sip"
       and "msg_fresh \<sigma> m"
    then have "dsn \<ge> 1" and "sip = dip \<or> (dip\<in>kD(rt (\<sigma> sip)) \<and> dsn \<le> nsqn (rt (\<sigma> sip)) dip
                                           \<and> (nsqn (rt (\<sigma> sip)) dip = dsn
                                                 \<longrightarrow> (the (dhops (rt (\<sigma> sip)) dip) \<le> hops
                                                      \<or> the (flag (rt (\<sigma> sip)) dip) = inv)))"
      by auto
    from this(2) show "?thesis"
    proof
      assume "sip = dip" with \<open>dsn \<ge> 1\<close> show ?thesis by simp
    next
      assume "dip\<in>kD(rt (\<sigma> sip)) \<and> dsn \<le> nsqn (rt (\<sigma> sip)) dip
                                  \<and> (nsqn (rt (\<sigma> sip)) dip = dsn
                                      \<longrightarrow> (the (dhops (rt (\<sigma> sip)) dip) \<le> hops
                                           \<or> the (flag (rt (\<sigma> sip)) dip) = inv))"
      moreover from qinc have "quality_increases (\<sigma> sip) (\<sigma>' sip)" ..
      ultimately have "dip\<in>kD(rt (\<sigma>' sip)) \<and> dsn \<le> nsqn (rt (\<sigma>' sip)) dip
                                           \<and> (nsqn (rt (\<sigma>' sip)) dip = dsn
                                              \<longrightarrow> (the (dhops (rt (\<sigma>' sip)) dip) \<le> hops
                                                    \<or> the (flag (rt (\<sigma>' sip)) dip) = inv))"
        using \<open>dsn \<ge> 1\<close> by (rule quality_increases_rreq_rrep_props [rotated 2])
      with \<open>dsn \<ge> 1\<close> show "msg_fresh \<sigma>' m"
        by clarsimp
    qed
  next
    fix dests sip
    assume [simp]: "m = Rerr dests sip"
       and "msg_fresh \<sigma> m"
    then have *: "\<forall>rip\<in>dom(dests). rip\<in>kD(rt (\<sigma> sip))
                              \<and> the (dests rip) - 1 \<le> nsqn (rt (\<sigma> sip)) rip"
      by simp
    have "\<forall>rip\<in>dom(dests). rip\<in>kD(rt (\<sigma>' sip))
                         \<and> the (dests rip) - 1 \<le> nsqn (rt (\<sigma>' sip)) rip"
      proof
        fix rip
        assume "rip\<in>dom(dests)"
        with * have "rip\<in>kD(rt (\<sigma> sip))" and "the (dests rip) - 1 \<le> nsqn (rt (\<sigma> sip)) rip"
          by - (drule(1) bspec, clarsimp)+
        moreover from qinc have "quality_increases (\<sigma> sip) (\<sigma>' sip)" by simp
        ultimately show "rip\<in>kD(rt (\<sigma>' sip)) \<and> the (dests rip) - 1 \<le> nsqn (rt (\<sigma>' sip)) rip" ..
      qed
    thus ?thesis by simp
  qed simp_all

end


theory prop_14
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter x (Nil2) = Nil2"
  | "filter x (Cons2 z xs) =
       (if x z then Cons2 z (filter x xs) else filter x xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster filter append *)
  theorem x0 :
    "(filter p (append xs ys)) = (append (filter p xs) (filter p ys))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


section\<open>Study on knowledge equivalence --- results to relate the knowledge of an agent to that of another's\<close>

theory Knowledge
imports NS_Public_Bad_GA
begin

(*Protocol independent study*)

(*Whatever A knows, which is neither static-private nor dynamic-private for
  her, then also B knows that*)
theorem knowledge_equiv:
 "\<lbrakk> X \<in> knows A evs; Notes A X \<notin> set evs;
   X \<notin> {Key (priEK A), Key (priSK A), Key (shrK A)} \<rbrakk>
 \<Longrightarrow> X \<in> knows B evs"
apply (erule rev_mp, erule rev_mp, erule rev_mp)
apply (induct_tac "A", induct_tac "B", induct_tac "evs")
apply (induct_tac [2] "a") apply auto
done

lemma knowledge_equiv_bis:
 "\<lbrakk> X \<in> knows A evs; Notes A X \<notin> set evs \<rbrakk>
 \<Longrightarrow> X \<in> {Key (priEK A), Key (priSK A), Key (shrK A)} \<union> knows B evs"
apply (blast dest: knowledge_equiv)
done

lemma knowledge_equiv_ter:
 "\<lbrakk> X \<in> knows A evs; X \<notin> {Key (priEK A), Key (priSK A), Key (shrK A)} \<rbrakk>
\<Longrightarrow> X \<in> knows B evs \<or> Notes A X \<in> set evs"
apply (blast dest: knowledge_equiv)
done

lemma knowledge_equiv_quater:
 " X \<in> knows A evs
\<Longrightarrow> X \<in> knows B evs \<or> Notes A X \<in> set evs \<or>
   X \<in> {Key (priEK A), Key (priSK A), Key (shrK A)}"
apply (blast dest: knowledge_equiv)
done

lemma setdiff_diff_insert: "A-B-C=D-E-F \<Longrightarrow> insert m (A-B-C) = insert m (D-E-F)"
by simp
(*IMPORTANT NOTE TO PREVIOUS LEMMA: removing parentheses from rhs falsifies
the lemma because set insertion seems to have higher priority than set
difference, hence insert m A-B-C \<noteq> insert m (A-B-C)!
Seen such operand priority, it can be understood why the lemma wouldn't hold
without parentheses*)
lemma "A-B-C=D-E-F \<Longrightarrow> insert m A-B-C = insert m D-E-F"
oops

lemma knowledge_equiv_eq_setdiff:
 "knows A evs  -
   {Key (priEK A), Key (priSK A), Key (shrK A)} -
     {X. Notes A X \<in> set evs}
  =
  knows B evs -
   {Key (priEK B), Key (priSK B), Key (shrK B)} -
     {X. Notes B X \<in> set evs}"
apply (induct_tac "evs", induct_tac "A", induct_tac "B")
apply force
apply (induct_tac "a")

(*Gets case solves because this event doesn't touch any agent knowledge*)
apply simp_all

(*Says case fails because both agents extract the said message, plus
discussion on lemma setdiff_diff_insert*)

(*Notes case solves in case neither of the two agents is the agent of the
  current step, because no notes are extracted and inductive premise applies;
  it fails in the two subcases when either of them is the agent of the current
  step, because a note would be extracted i.e. inserted in his knowledge, and
  hence falsification by discussion on lemma setdiff_diff_insert*)

oops (*So we have clear counterexamples of why this theorem CANNOT be proved inductively. Alternative stretegy using symbolic evaluation introduces clear counterexamples such as when an agent says A's shared key: it would be in the rhs but not in the lhs!*)

(* Old proof*)
lemma knowledge_equiv_eq_old:
 "knows A evs  \<union>
   {Key (priEK B), Key (priSK B), Key (shrK B)} \<union>
     {X. Notes B X \<in> set evs}
  =
  knows B evs \<union>
   {Key (priEK A), Key (priSK A), Key (shrK A)} \<union>
     {X. Notes A X \<in> set evs}"
apply (induct_tac "evs", induct_tac "A", induct_tac "B")
apply force
apply (induct_tac "a")
txt\<open>Gets case solves because this event doesn't touch any agent knowledge\<close>
apply simp_all
apply safe txt\<open>speeds up subsequent blasting\<close>
apply blast+  txt\<open>very very slow\<close>
done

(* New proof*)

theorem knowledge_eval: "knows A evs =
       {Key (priEK A), Key (priSK A), Key (shrK A)} \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK) \<union>
       {X. \<exists> S R. Says S R X \<in> set evs} \<union>
       {X. Notes A X \<in> set evs}"
apply (induct_tac "A", induct_tac "evs")
apply (induct_tac [2] "a")
apply auto
done

lemma knowledge_eval_setdiff:
 "knows A evs  -
   {Key (priEK A), Key (priSK A), Key (shrK A)} -
     {X. Notes A X \<in> set evs}
  =
       (Key ` range pubEK) \<union> (Key ` range pubSK) \<union>
       {X. \<exists> S R. Says S R X \<in> set evs}"
apply (simp only: knowledge_eval) apply auto
oops(*here are clear counterexamples!*)

theorem knowledge_equiv_eq: "knows A evs  \<union>
   {Key (priEK B), Key (priSK B), Key (shrK B)} \<union>
     {X. Notes B X \<in> set evs}
  =
  knows B evs \<union>
   {Key (priEK A), Key (priSK A), Key (shrK A)} \<union>
     {X. Notes A X \<in> set evs}"
apply (force simp only: knowledge_eval)
done

lemma "knows A evs  \<union>
   {Key (priEK B), Key (priSK B), Key (shrK B)} \<union>
     {X. Notes B X \<in> set evs} -
(  {Key (priEK B), Key (priSK B), Key (shrK B)} \<union>
     {X. Notes B X \<in> set evs} ) = knows A evs"
apply auto
oops
(*Here the prover tells you why this fails*)

theorem parts_knowledge_equiv_eq: "
parts(knows A evs)  \<union>
   {Key (priEK B), Key (priSK B), Key (shrK B)} \<union>
     parts({X. Notes B X \<in> set evs})
  =
parts(knows B evs) \<union>
   {Key (priEK A), Key (priSK A), Key (shrK A)} \<union>
     parts({X. Notes A X \<in> set evs})"
apply (simp only: knowledge_eval parts_Un) apply force
done

lemmas parts_knowledge_equiv = parts_knowledge_equiv_eq [THEN equalityD1, THEN subsetD]
thm parts_knowledge_equiv

(*Protocol-dependent study*)

lemma knowledge_equiv_eq_NS: "
  evs \<in> ns_public \<Longrightarrow>
  knows A evs  \<union> {Key (priEK B), Key (priSK B), Key (shrK B)}  =
  knows B evs \<union> {Key (priEK A), Key (priSK A), Key (shrK A)}"
apply (force simp only: knowledge_eval NS_no_Notes)
done

lemma parts_knowledge_equiv_eq_NS: "
  evs \<in> ns_public \<Longrightarrow>
  parts(knows A evs) \<union> {Key (priEK B), Key (priSK B), Key (shrK B)}  =
  parts(knows B evs) \<union> {Key (priEK A), Key (priSK A), Key (shrK A)}"
apply (simp only: knowledge_eval NS_no_Notes parts_Un) apply force
done

theorem noprishr_parts_knowledge_equiv_NS: "
\<lbrakk> X \<notin> {Key (priEK A), Key (priSK A), Key (shrK A)};
  X \<in> parts(knows A evs); evs \<in> ns_public \<rbrakk>
\<Longrightarrow>  X \<in> parts(knows B evs)"
apply (drule noprishr_parts_knowledge_equiv, simp)
apply (simp add: NS_no_Notes)
done

theorem Agent_not_analz_N:
"\<lbrakk> Nonce N \<notin> parts(knows A evs); evs \<in> ns_public \<rbrakk>
 \<Longrightarrow> Nonce N \<notin> analz(knows B evs)"
apply (force intro: noprishr_parts_knowledge_equiv_NS analz_into_parts)
done
(*Conclusion in terms of analz because we are more used to it. It would have been a stronger law in terms of parts, though*)

end


section \<open>Reference Monitors\<close>

theory Reference_Monitor
imports "../Noninterference/Noninterference"
begin

text \<open>We now consider a special class of automata with structured state: there is a type
@{text "'var"} of variable names, and a state stores a value for each variable.\<close>

subsection \<open>Definition\<close>

text \<open>We formalize this with a function @{text contents}, which takes a state and a variable name,
and returns the value stored under that variable name in the state.\<close>

locale Structured_State =
  Automaton s0 step out
  for s0 :: "'state"
  and step :: "'state \<Rightarrow> 'act \<Rightarrow> 'state"
  and out :: "'state \<Rightarrow> 'act \<Rightarrow> 'out"
+ fixes contents :: "'state \<Rightarrow> 'var \<Rightarrow> 'val"

subsection \<open>Verification\<close>

text \<open>We implement a flow policy for an automaton with structured state by specifying which
variables can be read and written in a domain: @{text "observe u"} gives the set of variables that
may be read in the domain @{text u}, and @{text "alter u"} gives the set of variables that may be
written by @{text u}.

These functions have to be consistent with the flow policy in the following sense:
\<^item> if information is allowed to flow from domain @{text u} to domain @{text v}, then all variables
that may be read by @{text u} may also be read by @{text v} (condition @{text FP_impl1} below), and
\<^item> if a variable may be written by @{text u} and read by @{text v}, then information must be allowed
to flow from @{text u} to @{text v}  (condition @{text FP_impl2} below.)\<close>

locale FP_Implementation =
  Structured_State s0 step out contents
+ NI s0 step out FP dom
  for s0 :: "'state"
  and step :: "'state \<Rightarrow> 'act \<Rightarrow> 'state"
  and out :: "'state \<Rightarrow> 'act \<Rightarrow> 'out"
  and contents :: "'state \<Rightarrow> 'var \<Rightarrow> 'val"
  and FP :: "'dom rel"
  and dom :: "'act \<Rightarrow> 'dom"
+
fixes observe :: "'dom \<Rightarrow> 'var set"
  and alter :: "'dom \<Rightarrow> 'var set"
assumes FP_impl1: "(u \<leadsto> v) \<Longrightarrow> observe u \<subseteq> observe v"
    and FP_impl2: "n \<in> alter u \<Longrightarrow> n \<in> observe v \<Longrightarrow> (u \<leadsto> v)"
begin

text \<open>We will prove the security of the automaton using the unwinding theorem. For this purpose,
we define a view partitioning where two states are equivalent for a domain @{text u} iff they
coincide on the variables that are observable for @{text u}.\<close>

definition view :: "'dom \<Rightarrow> 'state rel" where
  "view u \<equiv> {(s, t). \<forall>n \<in> observe u. contents s n = contents t n}"

abbreviation view'' :: "'state \<Rightarrow> 'dom \<Rightarrow> 'state \<Rightarrow> bool" ("_ \<sim>\<^bsub>_\<^esub> _")
where "(s \<sim>\<^bsub>u\<^esub> t) \<equiv> (s, t) \<in> view u"

lemma viewI:
  assumes "\<And>n. n \<in> observe u \<Longrightarrow> contents s n = contents t n"
  shows "s \<sim>\<^bsub>u\<^esub> t"
using assms unfolding view_def by auto

text \<open>This is indeed a view partitioning: for all domains @{text u}, the relation @{text "\<sim>\<^bsub>u\<^esub>"}
is an equivalence relation.\<close>

sublocale View_Partitioning s0 step out FP dom view
proof
  show "\<forall>u. equiv UNIV (view u)"
    unfolding view_def
    by (auto intro!: equivI symI refl_onI transI)
qed

text \<open>As a helper lemma for the proof below, we note that, if information is allowed to flow from
@{text u} to @{text v}, then two states are equivalent for @{text u} if they are equivalent for
@{text v}, i.e.\ @{text "\<sim>\<^bsub>v\<^esub>"} is a @{emph \<open>finer\<close>} equivalence relation than @{text "\<sim>\<^bsub>u\<^esub>"}.\<close>

lemma view_spec:
  assumes "u \<leadsto> v"
      and "s \<sim>\<^bsub>v\<^esub> t"
  shows "s \<sim>\<^bsub>u\<^esub> t"
using assms FP_impl1
unfolding view_def
by auto

end

text \<open>In order to prove the unwinding conditions, we require that the implementation of the flow
policy satisfies three additional assumptions:
\<^item> output consistency has to hold (RMA1),
\<^item> if a visible action is performed on two equivalent states and changes the value of a variable
in one of them, then it has to be changed to the same value in the other state (RMA2), and
\<^item> if an action @{text a} changes the value of a variable, then that variable must be writable by
the domain of @{text a} (RMA3).\<close>

locale Reference_Monitor = FP_Implementation
+ assumes RMA1: "(s \<sim>\<^bsub>dom a\<^esub> t) \<Longrightarrow> out s a = out t a"
      and RMA2: "(s \<sim>\<^bsub>dom a\<^esub> t)
                 \<Longrightarrow> (contents (step s a) n \<noteq> contents s n)
                   \<or> (contents (step t a) n \<noteq> contents t n)
                 \<Longrightarrow> contents (step s a) n = contents (step t a) n"
      and RMA3: "contents (step s a) n \<noteq> contents s n \<Longrightarrow> n \<in> alter (dom a)"
begin

text \<open>Together with the assumptions on the consistency of implementation and flow policy
(@{text "FP_impl1"} and @{text "FP_impl2"}), this is sufficient to prove the unwinding conditions.\<close>

theorem monitor_secure: "NI_secure"
proof (intro unwinding_theorem)
  show "output_consistent"
    using RMA1
    unfolding output_consistent_def
    by auto
next
  show "step_consistent"
    unfolding step_consistent_def
  proof (intro allI impI, elim conjE)
    fix s t u a
    assume "(dom a) \<leadsto> u"
       and "s \<sim>\<^bsub>u\<^esub> t"
    then have "s \<sim>\<^bsub>dom a\<^esub> t" by (rule view_spec)
    show "(step s a) \<sim>\<^bsub>u\<^esub> (step t a)"
    proof (intro viewI)
      fix n
      assume n: "n \<in> observe u"
      show "contents (step s a) n = contents (step t a) n"
      proof (cases "contents (step s a) n = contents s n
                  \<and> contents (step t a) n = contents t n")
        case True
          then show ?thesis using `s \<sim>\<^bsub>u\<^esub> t` n unfolding view_def by auto
      next
        case False
          then show ?thesis using `s \<sim>\<^bsub>dom a\<^esub> t` RMA2 by auto
      qed
    qed
  qed
next
  show "locally_respects_FP"
    unfolding locally_respects_FP_def
  proof (intro allI impI)
    fix s u a
    assume noflow: "\<not>((dom a) \<leadsto> u)"
    then have not_alter_observe: "\<forall>n. n \<notin> alter (dom a) \<or> n \<notin> observe u"
      using FP_impl2 by auto
    show "s \<sim>\<^bsub>u\<^esub> (step s a)"
    proof (intro viewI)
      fix n
      assume "n \<in> observe u"
      with not_alter_observe have "n \<notin> alter (dom a)" by auto
      with RMA3 have "contents (step s a) n = contents s n" by auto
      then show "contents s n = contents (step s a) n" ..
    qed
  qed
qed

end

end