(* Author: Andreas Lochbihler, ETH Zurich *)

subsection \<open>Tree relabelling\<close>

theory Tree_Relabelling imports
  Applicative_State
  Applicative_Option
  Applicative_PMF
  "HOL-Library.Stream"
begin

unbundle applicative_syntax
adhoc_overloading Applicative.pure pure_option
adhoc_overloading Applicative.pure State_Monad.return
adhoc_overloading Applicative.ap State_Monad.ap

text \<open> Hutton and Fulger \<^cite>\<open>"HuttonFulger2008TFP"\<close> suggested the following tree relabelling problem
  as an example for reasoning about effects. Given a binary tree with labels at the leaves, the
  relabelling assigns a unique number to every leaf.  Their correctness property states that the
  list of labels in the obtained tree is distinct.  As observed by Gibbons and Bird \<^cite>\<open>"backwards"\<close>,
  this breaks the abstraction of the state monad, because the relabeling function must be run.
  Although Hutton and Fulger are careful to reason in point-free style, they nevertheless unfold
  the implementation of the state monad operations.  Gibbons and Hinze \<^cite>\<open>"GibbonsHinze2011ICFP"\<close>
  suggest to state the correctness in an effectful way using an exception-state monad.  Thereby, they
  lose the applicative structure and have to resort to a full monad.

  Here, we model the tree relabelling function three times. First, we state correctness in pure
  terms following Hutton and Fulger.  Second, we take Gibbons' and Bird's approach of considering
  traversals. Third, we state correctness effectfully, but only using the applicative functors.
\<close>

datatype 'a tree = Leaf 'a | Node "'a tree" "'a tree"

primrec fold_tree :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a tree \<Rightarrow> 'b"
where
  "fold_tree f g (Leaf a) = f a"
| "fold_tree f g (Node l r) = g (fold_tree f g l) (fold_tree f g r)"

definition leaves :: "'a tree \<Rightarrow> nat"
where "leaves = fold_tree (\<lambda>_. 1) (+)"

lemma leaves_simps [simp]:
  "leaves (Leaf x) = Suc 0"
  "leaves (Node l r) = leaves l + leaves r"
by(simp_all add: leaves_def)

subsubsection \<open>Pure correctness statement\<close>

definition labels :: "'a tree \<Rightarrow> 'a list"
where "labels = fold_tree (\<lambda>x. [x]) append"

lemma labels_simps [simp]:
  "labels (Leaf x) = [x]"
  "labels (Node l r) = labels l @ labels r"
by(simp_all add: labels_def)

locale labelling =
  fixes fresh :: "('s, 'x) state"
begin

declare [[show_variants]]

definition label_tree :: "'a tree \<Rightarrow> ('s, 'x tree) state"
where "label_tree = fold_tree (\<lambda>_ :: 'a. pure Leaf \<diamondop> fresh) (\<lambda>l r. pure Node \<diamondop> l \<diamondop> r)"

lemma label_tree_simps [simp]:
  "label_tree (Leaf x) = pure Leaf \<diamondop> fresh"
  "label_tree (Node l r) = pure Node \<diamondop> label_tree l \<diamondop> label_tree r"
by(simp_all add: label_tree_def)

primrec label_list :: "'a list \<Rightarrow> ('s, 'x list) state"
where
    "label_list [] = pure []"
  | "label_list (x # xs) = pure (#) \<diamondop> fresh \<diamondop> label_list xs"

lemma label_append: "label_list (a @ b) = pure (@) \<diamondop> label_list a \<diamondop> label_list b"
  \<comment> \<open>The proof lifts the defining equations of @{const append} to the state monad.\<close>
proof (induction a)
  case Nil
  show ?case
    unfolding append.simps label_list.simps
    by applicative_nf simp
next
  case (Cons a1 a2)
  show ?case
    unfolding append.simps label_list.simps Cons.IH
    by applicative_nf simp
qed

lemma label_tree_list: "pure labels \<diamondop> label_tree t = label_list (labels t)"
proof (induction t)
  case Leaf show ?case unfolding label_tree_simps labels_simps label_list.simps
    by applicative_nf simp
next
  case Node show ?case unfolding label_tree_simps labels_simps label_append Node.IH[symmetric]
    by applicative_nf simp
qed

text \<open>We directly show correctness without going via streams like Hutton and Fulger \<^cite>\<open>"HuttonFulger2008TFP"\<close>. \<close>

lemma correctness_pure:
  fixes t :: "'a tree"
  assumes distinct: "\<And>xs :: 'a list. distinct (fst (run_state (label_list xs) s))"
  shows "distinct (labels (fst (run_state (label_tree t) s)))"
using label_tree_list[of t, THEN arg_cong, of "\<lambda>f. run_state f s"] assms[of "labels t"]
by(cases "run_state (label_list (labels t)) s")(simp add: State_Monad.ap_def split_beta)

end

subsubsection \<open>Correctness via monadic traversals\<close>

text \<open>Dual version of an applicative functor with effects composed in the opposite order\<close>

typedef 'a dual = "UNIV :: 'a set" morphisms un_B B by blast
setup_lifting type_definition_dual

lift_definition pure_dual :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b dual"
is "\<lambda>pure. pure" .

lift_definition ap_dual :: "(('a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b) \<Rightarrow> 'af1) \<Rightarrow> ('af1 \<Rightarrow> 'af3 \<Rightarrow> 'af13) \<Rightarrow> ('af13 \<Rightarrow> 'af2 \<Rightarrow> 'af) \<Rightarrow> 'af2 dual \<Rightarrow> 'af3 dual \<Rightarrow> 'af dual"
is "\<lambda>pure ap1 ap2 f x. ap2 (ap1 (pure (\<lambda>x f. f x)) x) f" .

type_synonym ('s, 'a) state_rev = "('s, 'a) state dual"

definition pure_state_rev :: "'a \<Rightarrow> ('s, 'a) state_rev"
where "pure_state_rev = pure_dual State_Monad.return"

definition ap_state_rev :: "('s, 'a \<Rightarrow> 'b) state_rev \<Rightarrow> ('s, 'a) state_rev \<Rightarrow> ('s, 'b) state_rev"
where "ap_state_rev = ap_dual State_Monad.return State_Monad.ap State_Monad.ap"

adhoc_overloading Applicative.pure pure_state_rev
adhoc_overloading Applicative.ap ap_state_rev

applicative state_rev
for
  pure: pure_state_rev
  ap: ap_state_rev
unfolding pure_state_rev_def ap_state_rev_def by(transfer, applicative_nf, rule refl)+

type_synonym ('s, 'a) state_rev_rev = "('s, 'a) state_rev dual"

definition pure_state_rev_rev :: "'a \<Rightarrow> ('s, 'a) state_rev_rev"
where "pure_state_rev_rev = pure_dual pure_state_rev"

definition ap_state_rev_rev :: "('s, 'a \<Rightarrow> 'b) state_rev_rev \<Rightarrow> ('s, 'a) state_rev_rev \<Rightarrow> ('s, 'b) state_rev_rev"
where "ap_state_rev_rev = ap_dual pure_state_rev ap_state_rev ap_state_rev"

adhoc_overloading Applicative.pure pure_state_rev_rev
adhoc_overloading Applicative.ap ap_state_rev_rev

applicative state_rev_rev
for
  pure: pure_state_rev_rev
  ap: ap_state_rev_rev
unfolding pure_state_rev_rev_def ap_state_rev_rev_def by(transfer, applicative_nf, rule refl)+

lemma ap_state_rev_B: "B f \<diamondop> B x = B (State_Monad.return (\<lambda>x f. f x) \<diamondop> x \<diamondop> f)"
unfolding ap_state_rev_def by(fact ap_dual.abs_eq)

lemma ap_state_rev_pure_B: "pure f \<diamondop> B x = B (State_Monad.return f \<diamondop> x)"
unfolding ap_state_rev_def pure_state_rev_def
by transfer(applicative_nf, rule refl)

lemma ap_state_rev_rev_B: "B f \<diamondop> B x = B (pure_state_rev (\<lambda>x f. f x) \<diamondop> x \<diamondop> f)"
unfolding ap_state_rev_rev_def by(fact ap_dual.abs_eq)

lemma ap_state_rev_rev_pure_B: "pure f \<diamondop> B x = B (pure_state_rev f \<diamondop> x)"
unfolding ap_state_rev_rev_def pure_state_rev_rev_def
by transfer(applicative_nf, rule refl)

text \<open>
  The formulation by Gibbons and Bird \<^cite>\<open>"backwards"\<close> crucially depends on Kleisli composition,
  so we need the state monad rather than the applicative functor only.
\<close>

lemma ap_conv_bind_state: "State_Monad.ap f x = State_Monad.bind f (\<lambda>f. State_Monad.bind x (State_Monad.return \<circ> f))"
by(simp add: State_Monad.ap_def State_Monad.bind_def Let_def split_def o_def fun_eq_iff)

lemma ap_pure_bind_state: "pure x \<diamondop> State_Monad.bind y f = State_Monad.bind y ((\<diamondop>) (pure x) \<circ> f)"
by(simp add: ap_conv_bind_state o_def)

definition kleisli_state :: "('b \<Rightarrow> ('s, 'c) state) \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state) \<Rightarrow> 'a \<Rightarrow> ('s, 'c) state" (infixl "\<bullet>" 55)
where [simp]: "kleisli_state g f a = State_Monad.bind (f a) g"

definition fetch :: "('a stream, 'a) state"
where "fetch = State_Monad.bind State_Monad.get (\<lambda>s. State_Monad.bind (State_Monad.set (stl s)) (\<lambda>_. State_Monad.return (shd s)))"

primrec traverse :: "('a \<Rightarrow> ('s, 'b) state) \<Rightarrow> 'a tree \<Rightarrow> ('s, 'b tree) state"
where
  "traverse f (Leaf x) = pure Leaf \<diamondop> f x"
| "traverse f (Node l r) = pure Node \<diamondop> traverse f l \<diamondop> traverse f r"

text \<open>As we cannot abstract over the applicative functor in definitions, we define
  traversal on the transformed applicative function once again.\<close>

primrec traverse_rev :: "('a \<Rightarrow> ('s, 'b) state_rev) \<Rightarrow> 'a tree \<Rightarrow> ('s, 'b tree) state_rev"
where
  "traverse_rev f (Leaf x) = pure Leaf \<diamondop> f x"
| "traverse_rev f (Node l r) = pure Node \<diamondop> traverse_rev f l \<diamondop> traverse_rev f r"

definition recurse :: "('a \<Rightarrow> ('s, 'b) state) \<Rightarrow> 'a tree \<Rightarrow> ('s, 'b tree) state"
where "recurse f = un_B \<circ> traverse_rev (B \<circ> f)"

lemma recurse_Leaf: "recurse f (Leaf x) = pure Leaf \<diamondop> f x"
unfolding recurse_def traverse_rev.simps o_def ap_state_rev_pure_B
by(simp add: B_inverse)

lemma recurse_Node:
  "recurse f (Node l r) = pure (\<lambda>r l. Node l r) \<diamondop> recurse f r \<diamondop> recurse f l"
proof -
  have "recurse f (Node l r) = un_B (pure Node \<diamondop> traverse_rev (B \<circ> f) l \<diamondop> traverse_rev (B \<circ> f) r)"
    by(simp add: recurse_def)
  also have "\<dots> = un_B (B (pure Node) \<diamondop> B (recurse f l) \<diamondop> B (recurse f r))"
    by(simp add: un_B_inverse recurse_def pure_state_rev_def pure_dual_def)
  also have "\<dots> = pure (\<lambda>x f. f x) \<diamondop> recurse f r \<diamondop> (pure (\<lambda>x f. f x) \<diamondop> recurse f l \<diamondop> pure Node)"
    by(simp add: ap_state_rev_B B_inverse)
  also have "\<dots> = pure (\<lambda>r l. Node l r) \<diamondop> recurse f r \<diamondop> recurse f l"
    \<comment> \<open>This step expands to 13 steps in \cite{backwards}\<close>
    by(applicative_nf) simp
  finally show ?thesis .
qed

lemma traverse_pure: "traverse pure t = pure t"
proof(induction t)
  { case Leaf show ?case unfolding traverse.simps by applicative_nf simp }
  { case Node show ?case unfolding traverse.simps Node.IH by applicative_nf simp }
qed

text \<open>@{term "B \<circ> B"} is an idiom morphism\<close>

lemma B_pure: "pure x = B (State_Monad.return x)"
unfolding pure_state_rev_def by transfer simp

lemma BB_pure: "pure x = B (B (pure x))"
unfolding pure_state_rev_rev_def B_pure[symmetric] by transfer(rule refl)

lemma BB_ap: "B (B f) \<diamondop> B (B x) = B (B (f \<diamondop> x))"
proof -
  have "B (B f) \<diamondop> B (B x) = B (B (pure (\<lambda>x f. f x) \<diamondop> f \<diamondop> (pure (\<lambda>x f. f x) \<diamondop> x \<diamondop> pure (\<lambda>x f. f x))))"
    (is "_ = B (B ?exp)")
    unfolding ap_state_rev_rev_B B_pure ap_state_rev_B ..
  also have "?exp = f \<diamondop> x" \<comment> \<open>This step takes 15 steps in \cite{backwards}.\<close>
    by(applicative_nf)(rule refl)
  finally show ?thesis .
qed

primrec traverse_rev_rev :: "('a \<Rightarrow> ('s, 'b) state_rev_rev) \<Rightarrow> 'a tree \<Rightarrow> ('s, 'b tree) state_rev_rev"
where
  "traverse_rev_rev f (Leaf x) = pure Leaf \<diamondop> f x"
| "traverse_rev_rev f (Node l r) = pure Node \<diamondop> traverse_rev_rev f l \<diamondop> traverse_rev_rev f r"

definition recurse_rev :: "('a \<Rightarrow> ('s, 'b) state_rev) \<Rightarrow> 'a tree \<Rightarrow> ('s, 'b tree) state_rev"
where "recurse_rev f = un_B \<circ> traverse_rev_rev (B \<circ> f)"

lemma traverse_B_B: "traverse_rev_rev (B \<circ> B \<circ> f) = B \<circ> B \<circ> traverse f" (is "?lhs = ?rhs")
proof
  fix t
  show "?lhs t = ?rhs t" by(induction t)(simp_all add: BB_pure BB_ap)
qed

lemma traverse_recurse: "traverse f = un_B \<circ> recurse_rev (B \<circ> f)" (is "?lhs = ?rhs")
proof -
  have "?lhs = un_B \<circ> un_B \<circ> B \<circ> B \<circ> traverse f" by(simp add: o_def B_inverse)
  also have "\<dots> = un_B \<circ> un_B \<circ> traverse_rev_rev (B \<circ> B \<circ> f)" unfolding traverse_B_B by(simp add: o_assoc)
  also have "\<dots> = ?rhs" by(simp add: recurse_rev_def o_assoc)
  finally show ?thesis .
qed

lemma recurse_traverse:
  assumes "f \<bullet> g = pure"
  shows "recurse f \<bullet> traverse g = pure"
\<comment> \<open>Gibbons and Bird impose this as an additional requirement on traversals, but they write
  that they have not found a way to derive this fact from other axioms. So we prove it directly.\<close>
proof
  fix t
  from assms have *: "\<And>x. State_Monad.bind (g x) f = State_Monad.return x" by(simp add: fun_eq_iff)
  hence **: "\<And>x h. State_Monad.bind (g x) (\<lambda>x. State_Monad.bind (f x) h) = h x"
    by(fold State_Monad.bind_assoc)(simp)
  show "(recurse f \<bullet> traverse g) t = pure t" unfolding kleisli_state_def
  proof(induction t)
    case (Leaf x)
    show ?case
      by(simp add: ap_conv_bind_state recurse_Leaf **)
  next
    case (Node l r)
    show ?case
      by(simp add: ap_conv_bind_state recurse_Node)(simp add: State_Monad.bind_assoc[symmetric] Node.IH)
  qed
qed

text \<open>Apply traversals to labelling\<close>

definition strip :: "'a \<times> 'b \<Rightarrow> ('b stream, 'a) state"
where "strip = (\<lambda>(a, b). State_Monad.bind (State_Monad.update (SCons b)) (\<lambda>_. State_Monad.return a))"

definition adorn :: "'a \<Rightarrow> ('b stream, 'a \<times> 'b) state"
where "adorn a = pure (Pair a) \<diamondop> fetch"

abbreviation label :: "'a tree \<Rightarrow> ('b stream, ('a \<times> 'b) tree) state"
where "label \<equiv> traverse adorn"

abbreviation unlabel :: "('a \<times> 'b) tree \<Rightarrow> ('b stream, 'a tree) state"
where "unlabel \<equiv> recurse strip"

lemma strip_adorn: "strip \<bullet> adorn = pure"
by(simp add: strip_def adorn_def fun_eq_iff fetch_def[abs_def] ap_conv_bind_state)

lemma correctness_monadic: "unlabel \<bullet> label = pure"
by(rule recurse_traverse)(rule strip_adorn)

subsubsection \<open>Applicative correctness statement\<close>

text \<open>Repeating an effect\<close>

primrec repeatM :: "nat \<Rightarrow> ('s, 'x) state \<Rightarrow> ('s, 'x list) state"
where
  "repeatM 0 f = State_Monad.return []"
| "repeatM (Suc n) f = pure (#) \<diamondop> f \<diamondop> repeatM n f"

lemma repeatM_plus: "repeatM (n + m) f = pure append \<diamondop> repeatM n f \<diamondop> repeatM m f"
by(induction n)(simp; applicative_nf; simp)+

abbreviation (input) fail :: "'a option" where "fail \<equiv> None"

definition lift_state :: "('s, 'a) state \<Rightarrow> ('s, 'a option) state"
where [applicative_unfold]: "lift_state x = pure pure \<diamondop> x"

definition lift_option :: "'a option \<Rightarrow> ('s, 'a option) state"
where [applicative_unfold]: "lift_option x = pure x"

fun assert :: "('a \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> 'a option"
where
  assert_fail: "assert P fail = fail"
| assert_pure: "assert P (pure x) = (if P x then pure x else fail)"

context labelling begin

abbreviation symbols :: "nat \<Rightarrow> ('s, 'x list option) state"
where "symbols n \<equiv> lift_state (repeatM n fresh)"

abbreviation (input) disjoint :: "'x list \<Rightarrow> 'x list \<Rightarrow> bool"
where "disjoint xs ys \<equiv> set xs \<inter> set ys = {}"

definition dlabels :: "'x tree \<Rightarrow> 'x list option"
where "dlabels = fold_tree (\<lambda>x. pure [x])
     (\<lambda>l r. pure (case_prod append) \<diamondop> (assert (case_prod disjoint) (pure Pair \<diamondop> l \<diamondop> r)))"

lemma dlabels_simps [simp]:
  "dlabels (Leaf x) = pure [x]"
  "dlabels (Node l r) = pure (case_prod append) \<diamondop> (assert (case_prod disjoint) (pure Pair \<diamondop> dlabels l \<diamondop> dlabels r))"
by(simp_all add: dlabels_def)

lemma correctness_applicative:
  assumes distinct: "\<And>n. pure (assert distinct) \<diamondop> symbols n = symbols n"
  shows "State_Monad.return dlabels \<diamondop> label_tree t = symbols (leaves t)"
proof(induction t)
  show "pure dlabels \<diamondop> label_tree (Leaf x) = symbols (leaves (Leaf x))" for x :: 'a
    unfolding label_tree_simps leaves_simps repeatM.simps by applicative_nf simp
next
  fix l r :: "'a tree"
  assume IH: "pure dlabels \<diamondop> label_tree l = symbols (leaves l)" "pure dlabels \<diamondop> label_tree r = symbols (leaves r)"
  let ?cat = "case_prod append" and ?disj = "case_prod disjoint"
  let ?f = "\<lambda>l r. pure ?cat \<diamondop> (assert ?disj (pure Pair \<diamondop> l \<diamondop> r))"
  have "State_Monad.return dlabels \<diamondop> label_tree (Node l r) =
        pure ?f \<diamondop> (pure dlabels \<diamondop> label_tree l) \<diamondop> (pure dlabels \<diamondop> label_tree r)"
    unfolding label_tree_simps by applicative_nf simp
  also have "\<dots> = pure ?f \<diamondop> (pure (assert distinct) \<diamondop> symbols (leaves l)) \<diamondop> (pure (assert distinct) \<diamondop> symbols (leaves r))"
    unfolding IH distinct ..
  also have "\<dots> = pure (assert distinct) \<diamondop> symbols (leaves (Node l r))"
    unfolding leaves_simps repeatM_plus by applicative_nf simp
  also have "\<dots> = symbols (leaves (Node l r))" by(rule distinct)
  finally show "pure dlabels \<diamondop> label_tree (Node l r) = symbols (leaves (Node l r))" .
qed

end

subsubsection \<open>Probabilistic tree relabelling\<close>

primrec mirror :: "'a tree \<Rightarrow> 'a tree"
where
  "mirror (Leaf x) = Leaf x"
| "mirror (Node l r) = Node (mirror r) (mirror l)"

datatype dir = Left | Right

hide_const (open) path

function (sequential) subtree :: "dir list \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
where
  "subtree (Left # path)  (Node l r) = subtree path l"
| "subtree (Right # path) (Node l r) = subtree path r"
| "subtree _              (Leaf x)   = Leaf x"
| "subtree []             t          = t"
by pat_completeness auto
termination by lexicographic_order

adhoc_overloading Applicative.pure pure_pmf

context fixes p :: "'a \<Rightarrow> 'b pmf" begin

primrec plabel :: "'a tree \<Rightarrow> 'b tree pmf"
where
  "plabel (Leaf x)   = pure Leaf \<diamondop> p x"
| "plabel (Node l r) = pure Node \<diamondop> plabel l \<diamondop> plabel r"

lemma plabel_mirror: "plabel (mirror t) = pure mirror \<diamondop> plabel t"
proof(induction t)
  case (Leaf x)
  show ?case unfolding plabel.simps mirror.simps by(applicative_lifting) simp
next
  case (Node t1 t2)
  show ?case unfolding plabel.simps mirror.simps Node.IH by(applicative_lifting) simp
qed

lemma plabel_subtree: "plabel (subtree path t) = pure (subtree path) \<diamondop> plabel t"
proof(induction path t rule: subtree.induct)
  case Left: (1 path l r)
  show ?case unfolding plabel.simps subtree.simps Left.IH by(applicative_lifting) simp
next
  case Right: (2 path l r)
  show ?case unfolding plabel.simps subtree.simps Right.IH by(applicative_lifting) simp
next
  case (3 uu x)
  show ?case unfolding plabel.simps subtree.simps by(applicative_lifting) simp
next
  case (4 v va)
  show ?case unfolding plabel.simps subtree.simps by(applicative_lifting) simp
qed

end

end


section \<open>Unbounded Separation Logic\<close>

theory UnboundedLogic
  imports Main
begin

subsection \<open>Assertions and state model\<close>

text \<open>We define our assertion language as described in Section 2.3 of the paper~\<^cite>\<open>"UnboundedSL"\<close>.\<close>

datatype ('a, 'b, 'c, 'd) assertion =
  Sem "('d \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> bool"
  | Mult 'b "('a, 'b, 'c, 'd) assertion"
  | Star "('a, 'b, 'c, 'd) assertion" "('a, 'b, 'c, 'd) assertion"
  | Wand "('a, 'b, 'c, 'd) assertion" "('a, 'b, 'c, 'd) assertion"
  | Or "('a, 'b, 'c, 'd) assertion" "('a, 'b, 'c, 'd) assertion"
  | And "('a, 'b, 'c, 'd) assertion" "('a, 'b, 'c, 'd) assertion"
  | Imp "('a, 'b, 'c, 'd) assertion" "('a, 'b, 'c, 'd) assertion"
  | Exists 'd "('a, 'b, 'c, 'd) assertion"
  | Forall 'd "('a, 'b, 'c, 'd) assertion"
  | Pred
  | Bounded "('a, 'b, 'c, 'd) assertion"
  | Wildcard "('a, 'b, 'c, 'd) assertion"

type_synonym 'a command = "('a \<times> 'a option) set"

locale pre_logic =
    fixes plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a option" (infixl "\<oplus>" 63)

begin

definition compatible :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "##" 60) where
  "a ## b \<longleftrightarrow> a \<oplus> b \<noteq> None"

definition larger :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<succeq>" 55) where
  "a \<succeq> b \<longleftrightarrow> (\<exists>c. Some a = b \<oplus> c)"

end

type_synonym ('a, 'b, 'c) interp = "('a \<Rightarrow> 'b) \<Rightarrow> 'c set"

text \<open>The following locale captures the state model described in Section 2.2 of the paper~\<^cite>\<open>"UnboundedSL"\<close>.\<close>

locale logic = pre_logic +

  fixes mult :: "'b \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<odot>" 64)

  fixes smult :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
  fixes sadd :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
  fixes sinv :: "'b \<Rightarrow> 'b"

  fixes one :: 'b

  fixes valid :: "'a \<Rightarrow> bool"

  assumes commutative: "a \<oplus> b = b \<oplus> a"
      and asso1: "a \<oplus> b = Some ab \<and> b \<oplus> c = Some bc \<Longrightarrow> ab \<oplus> c = a \<oplus> bc"
      and asso2: "a \<oplus> b = Some ab \<and> \<not> b ## c \<Longrightarrow> \<not> ab ## c"

      and sinv_inverse: "smult p (sinv p) = one"
      and sone_neutral: "smult one p = p"
      and sadd_comm: "sadd p q = sadd q p"
      and smult_comm: "smult p q = smult q p"
      and smult_distrib: "smult p (sadd q r) = sadd (smult p q) (smult p r)"
      and smult_asso: "smult (smult p q) r = smult p (smult q r)"

      and double_mult: "p \<odot> (q \<odot> a) = (smult p q) \<odot> a"
      and plus_mult: "Some a = b \<oplus> c \<Longrightarrow> Some (p \<odot> a) = (p \<odot> b) \<oplus> (p \<odot> c)"
      and distrib_mult: "Some ((sadd p q) \<odot> x) = p \<odot> x \<oplus> q \<odot> x"
      and one_neutral: "one \<odot> a = a"

      and valid_mono: "valid a \<and> a \<succeq> b \<Longrightarrow> valid b"

begin

text \<open>The validity of assertions corresponds to Figure 3 of the paper~\<^cite>\<open>"UnboundedSL"\<close>.\<close>

fun sat :: "'a \<Rightarrow> ('d \<Rightarrow> 'c) \<Rightarrow> ('d, 'c, 'a) interp \<Rightarrow> ('a, 'b, 'c, 'd) assertion \<Rightarrow> bool" ("_, _, _ \<Turnstile> _" [51, 65, 68, 66] 50) where
  "\<sigma>, s, \<Delta> \<Turnstile> Mult p A \<longleftrightarrow> (\<exists>a. \<sigma> = p \<odot> a \<and> a, s, \<Delta> \<Turnstile> A)"
| "\<sigma>, s, \<Delta> \<Turnstile> Star A B \<longleftrightarrow> (\<exists>a b. Some \<sigma> = a \<oplus> b \<and> a, s, \<Delta> \<Turnstile> A \<and> b, s, \<Delta> \<Turnstile> B)"
| "\<sigma>, s, \<Delta> \<Turnstile> Wand A B \<longleftrightarrow> (\<forall>a \<sigma>'. a, s, \<Delta> \<Turnstile> A \<and> Some \<sigma>' = \<sigma> \<oplus> a \<longrightarrow> \<sigma>', s, \<Delta> \<Turnstile> B)"

| "\<sigma>, s, \<Delta> \<Turnstile> Sem b \<longleftrightarrow> b s \<sigma>"
| "\<sigma>, s, \<Delta> \<Turnstile> Imp A B \<longleftrightarrow> (\<sigma>, s, \<Delta> \<Turnstile> A \<longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> B)"
| "\<sigma>, s, \<Delta> \<Turnstile> Or A B \<longleftrightarrow> (\<sigma>, s, \<Delta> \<Turnstile> A \<or> \<sigma>, s, \<Delta> \<Turnstile> B)"
| "\<sigma>, s, \<Delta> \<Turnstile> And A B \<longleftrightarrow> (\<sigma>, s, \<Delta> \<Turnstile> A \<and> \<sigma>, s, \<Delta> \<Turnstile> B)"

| "\<sigma>, s, \<Delta> \<Turnstile> Exists x A \<longleftrightarrow> (\<exists>v. \<sigma>, s(x := v), \<Delta> \<Turnstile> A)"
| "\<sigma>, s, \<Delta> \<Turnstile> Forall x A \<longleftrightarrow> (\<forall>v. \<sigma>, s(x := v), \<Delta> \<Turnstile> A)"

| "\<sigma>, s, \<Delta> \<Turnstile> Pred \<longleftrightarrow> (\<sigma> \<in> \<Delta> s)"
| "\<sigma>, s, \<Delta> \<Turnstile> Bounded A \<longleftrightarrow> (valid \<sigma> \<longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> A)"
| "\<sigma>, s, \<Delta> \<Turnstile> Wildcard A \<longleftrightarrow> (\<exists>a p. \<sigma> = p \<odot> a \<and> a, s, \<Delta> \<Turnstile> A)"

definition intuitionistic :: "('d \<Rightarrow> 'c) \<Rightarrow> ('d, 'c, 'a) interp \<Rightarrow> ('a, 'b, 'c, 'd) assertion \<Rightarrow> bool" where
  "intuitionistic s \<Delta> A \<longleftrightarrow> (\<forall>a b. a \<succeq> b \<and> b, s, \<Delta> \<Turnstile> A \<longrightarrow> a, s, \<Delta> \<Turnstile> A)"

definition entails :: "('a, 'b, 'c, 'd) assertion \<Rightarrow> ('d, 'c, 'a) interp \<Rightarrow> ('a, 'b, 'c, 'd) assertion \<Rightarrow> bool" ("_, _ \<turnstile> _" [63, 66, 68] 52) where
  "A, \<Delta> \<turnstile> B \<longleftrightarrow> (\<forall>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> A \<longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> B)"

definition equivalent :: "('a, 'b, 'c, 'd) assertion \<Rightarrow> ('d, 'c, 'a) interp \<Rightarrow> ('a, 'b, 'c, 'd) assertion \<Rightarrow> bool" ("_, _ \<equiv> _" [63, 66, 68] 52) where
  "A, \<Delta> \<equiv> B \<longleftrightarrow> (A, \<Delta> \<turnstile> B \<and> B, \<Delta> \<turnstile> A)"

definition pure :: "('a, 'b, 'c, 'd) assertion \<Rightarrow> bool" where
  "pure A \<longleftrightarrow> (\<forall>\<sigma> \<sigma>' s \<Delta> \<Delta>'. \<sigma>, s, \<Delta> \<Turnstile> A \<longleftrightarrow> \<sigma>', s, \<Delta>' \<Turnstile> A)"

subsection \<open>Useful lemmas\<close>

lemma sat_forall:
  assumes "\<And>v. \<sigma>, s(x := v), \<Delta> \<Turnstile> A"
  shows "\<sigma>, s, \<Delta> \<Turnstile> Forall x A"
  by (simp add: assms)

lemma intuitionisticI:
  assumes "\<And>a b. a \<succeq> b \<and> b, s, \<Delta> \<Turnstile> A \<Longrightarrow> a, s, \<Delta> \<Turnstile> A"
  shows "intuitionistic s \<Delta> A"
  by (meson assms intuitionistic_def)

lemma can_divide:
  assumes "p \<odot> a = p \<odot> b"
  shows "a = b"
  by (metis assms double_mult logic.one_neutral logic_axioms sinv_inverse smult_comm)

lemma unique_inv:
  "a = p \<odot> b \<longleftrightarrow> b = (sinv p) \<odot> a"
  by (metis double_mult logic.can_divide logic_axioms sinv_inverse sone_neutral)

lemma entailsI:
  assumes "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> A \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> B"
  shows "A, \<Delta> \<turnstile> B"
  by (simp add: assms entails_def)

lemma equivalentI:
  assumes "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> A \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> B"
      and "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> B \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> A"
    shows "A, \<Delta> \<equiv> B"
  by (simp add: assms(1) assms(2) entailsI equivalent_def)

lemma compatible_imp:
  assumes "a ## b"
  shows "(p \<odot> a) ## (p \<odot> b)"
  by (metis assms compatible_def option.distinct(1) option.exhaust plus_mult)

lemma compatible_iff:
  "a ## b \<longleftrightarrow> (p \<odot> a) ## (p \<odot> b)"
  by (metis compatible_imp unique_inv)

lemma sat_wand:
  assumes "\<And>a \<sigma>'. a, s, \<Delta> \<Turnstile> A \<and> Some \<sigma>' = \<sigma> \<oplus> a \<Longrightarrow> \<sigma>', s, \<Delta> \<Turnstile> B"
  shows "\<sigma>, s, \<Delta> \<Turnstile> Wand A B"
  using assms by auto

lemma sat_imp:
  assumes "\<sigma>, s, \<Delta> \<Turnstile> A \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> B"
  shows "\<sigma>, s, \<Delta> \<Turnstile> Imp A B"
  using assms by auto

lemma sat_mult:
  assumes "\<And>a. \<sigma> = p \<odot> a \<Longrightarrow> a, s, \<Delta> \<Turnstile> A"
  shows "\<sigma>, s, \<Delta> \<Turnstile> Mult p A"
  by (metis assms logic.sat.simps(1) logic_axioms unique_inv)

lemma larger_same:
  "a \<succeq> b \<longleftrightarrow> p \<odot> a \<succeq> p \<odot> b"
proof -
  have "\<And>a b p. a \<succeq> b \<Longrightarrow> p \<odot> a \<succeq> p \<odot> b"
    by (meson larger_def plus_mult)
  then show ?thesis
    by (metis unique_inv)
qed

lemma asso3:
  assumes "\<not> a ## b"
      and "b \<oplus> c = Some bc"
    shows "\<not> a ## bc"
  by (metis (full_types) assms(1) assms(2) asso2 commutative compatible_def)

lemma compatible_smaller:
  assumes "a \<succeq> b"
      and "x ## a"
    shows "x ## b"
  by (metis assms(1) assms(2) asso3 larger_def)

lemma compatible_multiples:
  assumes "p \<odot> a ## q \<odot> b"
  shows "a ## b"
  by (metis (no_types, opaque_lifting) assms commutative compatible_def compatible_iff compatible_smaller distrib_mult larger_def one_neutral)

lemma move_sum:
  assumes "Some a = a1 \<oplus> a2"
      and "Some b = b1 \<oplus> b2"
      and "Some x = a \<oplus> b"
      and "Some x1 = a1 \<oplus> b1"
      and "Some x2 = a2 \<oplus> b2"
    shows "Some x = x1 \<oplus> x2"
proof -
  obtain ab1 where "Some ab1 = a \<oplus> b1"
    by (metis assms(2) assms(3) asso3 compatible_def not_Some_eq)
  then have "Some ab1 = x1 \<oplus> a2"
    by (metis assms(1) assms(4) asso1 commutative)
  then show ?thesis
    by (metis \<open>Some ab1 = a \<oplus> b1\<close> assms(2) assms(3) assms(5) asso1)
qed

lemma sum_both_larger:
  assumes "Some x' = a' \<oplus> b'"
      and "Some x = a \<oplus> b"
      and "a' \<succeq> a"
      and "b' \<succeq> b"
    shows "x' \<succeq> x"
proof -
  obtain ra rb where "Some a' = a \<oplus> ra" "Some b' = b \<oplus> rb"
    using assms(3) assms(4) larger_def by auto
  then obtain r where "Some r = ra \<oplus> rb"
    by (metis assms(1) asso3 commutative compatible_def option.collapse)
  then have "Some x' = x \<oplus> r"
    by (meson \<open>Some a' = a \<oplus> ra\<close> \<open>Some b' = b \<oplus> rb\<close> assms(1) assms(2) move_sum)
  then show ?thesis
    using larger_def by blast
qed

lemma larger_first_sum:
  assumes "Some y = a \<oplus> b"
      and "x \<succeq> y"
    shows "\<exists>a'. Some x = a' \<oplus> b \<and> a' \<succeq> a"
proof -
  obtain r where "Some x = y \<oplus> r"
    using assms(2) larger_def by auto
  then obtain a' where "Some a' = a \<oplus> r"
    by (metis assms(1) asso2 commutative compatible_def option.collapse)
  then show ?thesis
    by (metis \<open>Some x = y \<oplus> r\<close> assms(1) asso1 commutative larger_def)
qed

lemma larger_implies_compatible:
  assumes "x \<succeq> y"
  shows "x ## y"
  by (metis assms compatible_def compatible_smaller distrib_mult one_neutral option.distinct(1))

section \<open>Frame rule\<close>

text \<open>This section corresponds to Section 2.5 of the paper~\<^cite>\<open>"UnboundedSL"\<close>.\<close>

definition safe :: "('a \<times> ('d \<Rightarrow> 'c)) command \<Rightarrow> ('a \<times> ('d \<Rightarrow> 'c)) \<Rightarrow> bool" where
  "safe c \<sigma> \<longleftrightarrow> (\<sigma>, None) \<notin> c"

definition safety_monotonicity :: "('a \<times> ('d \<Rightarrow> 'c)) command \<Rightarrow> bool" where
  "safety_monotonicity c \<longleftrightarrow> (\<forall>\<sigma> \<sigma>' s. valid \<sigma>' \<and> \<sigma>' \<succeq> \<sigma> \<and> safe c (\<sigma>, s) \<longrightarrow> safe c (\<sigma>', s))"

definition frame_property :: "('a \<times> ('d \<Rightarrow> 'c)) command \<Rightarrow> bool" where
  "frame_property c \<longleftrightarrow> (\<forall>\<sigma> \<sigma>0 r \<sigma>' s s'. valid \<sigma> \<and> valid \<sigma>' \<and> safe c (\<sigma>0, s) \<and> Some \<sigma> = \<sigma>0 \<oplus> r \<and> ((\<sigma>, s), Some (\<sigma>', s')) \<in> c
  \<longrightarrow> (\<exists>\<sigma>0'. Some \<sigma>' = \<sigma>0' \<oplus> r \<and> ((\<sigma>0, s), Some (\<sigma>0', s')) \<in> c))"

definition valid_hoare_triple :: "('a, 'b, 'c, 'd) assertion \<Rightarrow> ('a \<times> ('d \<Rightarrow> 'c)) command \<Rightarrow> ('a, 'b, 'c, 'd) assertion \<Rightarrow> ('d, 'c, 'a) interp \<Rightarrow> bool" where
  "valid_hoare_triple P c Q \<Delta> \<longleftrightarrow> (\<forall>\<sigma> s. valid \<sigma> \<and> \<sigma>, s, \<Delta> \<Turnstile> P \<longrightarrow> safe c (\<sigma>, s) \<and> (\<forall>\<sigma>' s'. ((\<sigma>, s), Some (\<sigma>', s')) \<in> c \<longrightarrow> \<sigma>', s', \<Delta> \<Turnstile> Q))"

lemma valid_hoare_tripleI:
  assumes "\<And>\<sigma> s. valid \<sigma> \<and> \<sigma>, s, \<Delta> \<Turnstile> P \<Longrightarrow> safe c (\<sigma>, s)"
      and "\<And>\<sigma> s \<sigma>' s'. valid \<sigma> \<and> \<sigma>, s, \<Delta> \<Turnstile> P \<Longrightarrow> ((\<sigma>, s), Some (\<sigma>', s')) \<in> c \<Longrightarrow> \<sigma>', s', \<Delta> \<Turnstile> Q"
    shows "valid_hoare_triple P c Q \<Delta>"
  using assms(1) assms(2) valid_hoare_triple_def by blast

definition valid_command :: "('a \<times> ('d \<Rightarrow> 'c)) command \<Rightarrow> bool" where
  "valid_command c \<longleftrightarrow> (\<forall>a b sa sb. ((a, sa), Some (b, sb)) \<in> c \<and> valid a \<longrightarrow> valid b)"

definition modified :: "('a \<times> ('d \<Rightarrow> 'c)) command \<Rightarrow> 'd set" where
  "modified c = { x |x. \<exists>\<sigma> s \<sigma>' s'. ((\<sigma>, s), Some (\<sigma>', s')) \<in> c \<and> s x \<noteq> s' x }"

definition equal_outside :: "('d \<Rightarrow> 'c) \<Rightarrow> ('d \<Rightarrow> 'c) \<Rightarrow> 'd set \<Rightarrow> bool" where
  "equal_outside s s' S \<longleftrightarrow> (\<forall>x. x \<notin> S \<longrightarrow> s x = s' x)"

definition not_in_fv :: "('a, 'b, 'c, 'd) assertion \<Rightarrow> 'd set \<Rightarrow> bool" where
  "not_in_fv A S \<longleftrightarrow> (\<forall>\<sigma> s \<Delta> s'. equal_outside s s' S \<longrightarrow> (\<sigma>, s, \<Delta> \<Turnstile> A \<longleftrightarrow> \<sigma>, s', \<Delta> \<Turnstile> A))"

lemma not_in_fv_mod:
  assumes "not_in_fv A (modified c)"
  and "((\<sigma>, s), Some (\<sigma>', s')) \<in> c"
  shows "x, s, \<Delta> \<Turnstile> A \<longleftrightarrow> x, s', \<Delta> \<Turnstile> A"
proof -
  have "\<And>x. x \<notin> (modified c) \<Longrightarrow> s x = s' x"
  proof -
    fix x assume "x \<notin> (modified c)"
    then show "s x = s' x"
      by (metis (mono_tags, lifting) CollectI assms(2) modified_def)
  qed
  then have "equal_outside s s' (modified c)"
    by (simp add: equal_outside_def)
  then show ?thesis
    using assms(1) not_in_fv_def by blast
qed

text \<open>This theorem corresponds to Theorem 2 of the paper~\<^cite>\<open>"UnboundedSL"\<close>.\<close>

theorem frame_rule:
  assumes "valid_command c"
      and "safety_monotonicity c"
      and "frame_property c"
      and "valid_hoare_triple P c Q \<Delta>"
      and "not_in_fv R (modified c)"
    shows "valid_hoare_triple (Star P R) c (Star Q R) \<Delta>"
proof (rule valid_hoare_tripleI)
  fix \<sigma> s assume asm0: "valid \<sigma> \<and> \<sigma>, s, \<Delta> \<Turnstile> Star P R"
  then obtain p r where "Some \<sigma> = p \<oplus> r" "p, s, \<Delta> \<Turnstile> P" "r, s, \<Delta> \<Turnstile> R"
    by auto
  then have "safe c (p, s)"
    by (metis asm0 assms(4) larger_def logic.valid_mono logic_axioms valid_hoare_triple_def)
  then show "safe c (\<sigma>, s)"
    using \<open>Some \<sigma> = p \<oplus> r\<close> assms(2) larger_def safety_monotonicity_def asm0 by blast
  fix \<sigma>' s' assume asm1: "((\<sigma>, s), Some (\<sigma>', s')) \<in> c"
  then obtain q where "Some \<sigma>' = q \<oplus> r" "((p, s), Some (q, s')) \<in> c"
    using \<open>Some \<sigma> = p \<oplus> r\<close> \<open>safe c (p, s)\<close> asm0 assms(1) assms(3) frame_property_def valid_command_def by blast
  moreover have "r, s', \<Delta> \<Turnstile> R"
    by (meson \<open>r, s, \<Delta> \<Turnstile> R\<close> assms(5) calculation(2) logic.not_in_fv_mod logic_axioms)
  ultimately show "\<sigma>', s', \<Delta> \<Turnstile> Star Q R"
    by (meson \<open>Some \<sigma> = p \<oplus> r\<close> \<open>p, s, \<Delta> \<Turnstile> P\<close> \<open>r, s, \<Delta> \<Turnstile> R\<close> asm0 assms(4) larger_def sat.simps(2) valid_hoare_triple_def valid_mono)
qed

lemma hoare_triple_input:
  "valid_hoare_triple P c Q \<Delta> \<longleftrightarrow> valid_hoare_triple (Bounded P) c Q \<Delta>"
  using sat.simps(11) valid_hoare_triple_def by blast

lemma hoare_triple_output:
  assumes "valid_command c"
  shows "valid_hoare_triple P c Q \<Delta> \<longleftrightarrow> valid_hoare_triple P c (Bounded Q) \<Delta>"
  using assms valid_command_def valid_hoare_triple_def by fastforce

end

end


theory SINVAR_NoRefl
imports "../TopoS_Helper"
begin

subsection \<open>SecurityInvariant NoRefl\<close>

text\<open>Hosts are not allowed to communicate with themselves.\<close>

text \<open>This can be used to effectively lift hosts to roles.
        Just list all roles that are allowed to communicate with themselves.
        Otherwise, communication between hosts of the same role (group) is prohibited.
        Useful in conjunction with the security gateway.\<close>

datatype node_config = NoRefl | Refl

definition default_node_properties :: "node_config"
  where  "default_node_properties = NoRefl"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (s, r) \<in> edges G. s = r \<longrightarrow> nP s = Refl)"

definition receiver_violation :: "bool" where "receiver_violation = False"

subsubsection \<open>Preliminaries\<close>

 lemma NoRfl_ENRsr: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_sr sinvar (\<lambda> nP\<^sub>s s nP\<^sub>r r. s = r \<longrightarrow> nP\<^sub>s = Refl)"
    by(simp add: SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_sr_def)

  definition NoRefl_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> ('v \<times> 'v) set set" where
  "NoRefl_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> e1 = e2 \<and> nP e1 = NoRefl} })"

 thm SecurityInvariant_withOffendingFlows.ENFsr_offending_set[OF NoRfl_ENRsr]

  lemma NoRefl_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = NoRefl_offending_set"
    apply(simp only: fun_eq_iff NoRefl_offending_set_def)
    apply(intro allI, rename_tac G nP)
    apply(simp only: SecurityInvariant_withOffendingFlows.ENFsr_offending_set[OF NoRfl_ENRsr])
    apply(case_tac "sinvar G nP")
     apply(simp; fail)
    apply(simp)
    apply(rule)
     apply(rule)
     apply(clarsimp)
     using node_config.exhaust apply blast
    apply(rule)
    apply(rule)
    apply(clarsimp)
   done

  lemma NoRefl_unique_default:
    "\<forall>G f nP i. wf_graph G \<and> f \<in> set_offending_flows G nP \<and> i \<in> fst ` f \<longrightarrow> \<not> sinvar G (nP(i := otherbot)) \<Longrightarrow>
     otherbot = NoRefl"
   apply(erule default_uniqueness_by_counterexample_ACS)
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp add:graph_ops)
   apply (simp split: prod.split_asm prod.split)
   apply(rule_tac x="\<lparr> nodes={vertex_1}, edges = {(vertex_1,vertex_1)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(case_tac otherbot, simp_all)
   apply(rule_tac x="(\<lambda> x. NoRefl)(vertex_1 := NoRefl, vertex_2 := NoRefl)" in exI, simp)
   apply(rule_tac x="{(vertex_1,vertex_1)}" in exI, simp)
   done

interpretation NoRefl: SecurityInvariant_ACS
where default_node_properties = default_node_properties
and sinvar = sinvar
rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = NoRefl_offending_set"
  unfolding default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply(frule SINVAR_NoRefl.offending_notevalD)
    apply(simp only: SecurityInvariant_withOffendingFlows.ENFsr_offending_set[OF NoRfl_ENRsr])
    apply fastforce
   apply(fact NoRefl_unique_default)
  apply(fact NoRefl_offending_set)
  done

text\<open>It can also be interpreted as IFS\<close>
lemma NoRefl_SecurityInvariant_IFS: "SecurityInvariant_IFS sinvar default_node_properties"
  unfolding default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply(frule SINVAR_NoRefl.offending_notevalD)
    apply(simp only: SecurityInvariant_withOffendingFlows.ENFsr_offending_set[OF NoRfl_ENRsr])
    apply fastforce
   apply(erule default_uniqueness_by_counterexample_IFS)
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp add:graph_ops)
   apply (simp split: prod.split_asm prod.split)
   apply(rule_tac x="\<lparr> nodes={vertex_1}, edges = {(vertex_1,vertex_1)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(case_tac otherbot, simp_all)
   apply(rule_tac x="(\<lambda> x. NoRefl)(vertex_1 := NoRefl, vertex_2 := NoRefl)" in exI, simp)
   apply(rule_tac x="{(vertex_1,vertex_1)}" in exI, simp)
  done

  lemma TopoS_NoRefl: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_fact (open) sinvar_mono
hide_const (open) sinvar receiver_violation default_node_properties

end


theory Validity
imports LLEarleyParsing Derivations
begin

context LocalLexing begin

definition wellformed_token :: "token \<Rightarrow> bool"
where
  "wellformed_token t = is_terminal (terminal_of_token t)"

definition wellformed_tokens :: "tokens \<Rightarrow> bool"
where
  "wellformed_tokens ts = list_all wellformed_token ts"

definition doc_tokens :: "tokens \<Rightarrow> bool"
where
  "doc_tokens p = (wellformed_tokens p \<and> is_prefix (chars p) Doc)"

definition wellformed_item :: "item \<Rightarrow> bool"
where
  "wellformed_item x = (
    item_rule x \<in> \<RR> \<and>
    item_origin x \<le> item_end x \<and>
    item_end x \<le> length Doc \<and>
    item_dot x \<le> length (item_rhs x))"

definition wellformed_items :: "items \<Rightarrow> bool"
where
  "wellformed_items X = (\<forall> x \<in> X. wellformed_item x)"

lemma is_word_terminals: "wellformed_tokens p \<Longrightarrow> is_word (terminals p)"
by (simp add: is_word_def list_all_length terminals_def wellformed_token_def wellformed_tokens_def)

lemma is_word_subset: "is_word x \<Longrightarrow> set y \<subseteq> set x \<Longrightarrow> is_word y"
by (metis (mono_tags, hide_lams) in_set_conv_nth is_word_def list_all_length subsetCE)

lemma is_word_terminals_take: "wellformed_tokens p \<Longrightarrow> is_word(terminals (take n p))"
by (metis append_take_drop_id is_word_terminals list_all_append wellformed_tokens_def)

lemma is_word_terminals_drop: "wellformed_tokens p \<Longrightarrow> is_word(terminals (drop n p))"
by (metis append_take_drop_id is_word_terminals list_all_append wellformed_tokens_def)

definition pvalid :: "tokens \<Rightarrow> item \<Rightarrow> bool"
where
  "pvalid p x = (\<exists> u \<gamma>.
     wellformed_tokens p \<and>
     wellformed_item x \<and>
     u \<le> length p \<and>
     charslength p = item_end x \<and>
     charslength (take u p) = item_origin x \<and>
     is_derivation (terminals (take u p) @ [item_nonterminal x] @ \<gamma>) \<and>
     derives (item_\<alpha> x) (terminals (drop u p)))"

definition Gen :: "tokens set \<Rightarrow> items"
where
  "Gen P = { x | x p. p \<in> P \<and> pvalid p x }"

lemma "wellformed_items (Gen P)"
  by (auto simp add: Gen_def pvalid_def wellformed_items_def)

lemma "wellformed_items (Init)"
  by (auto simp add: wellformed_items_def Init_def init_item_def wellformed_item_def)

definition pvalid_left :: "tokens \<Rightarrow> item \<Rightarrow> bool"
where
  "pvalid_left p x = (\<exists> u \<gamma>.
     wellformed_tokens p \<and>
     wellformed_item x \<and>
     u \<le> length p \<and>
     charslength p = item_end x \<and>
     charslength (take u p) = item_origin x \<and>
     is_leftderivation (terminals (take u p) @ [item_nonterminal x] @ \<gamma>) \<and>
     leftderives (item_\<alpha> x) (terminals (drop u p)))"

lemma pvalid_left: "pvalid p x = pvalid_left p x"
proof -
  have right_imp_left: "pvalid_left p x \<Longrightarrow> pvalid p x"
    by (meson CFG.leftderives_implies_derives CFG_axioms LocalLexing.pvalid_def
        LocalLexing.pvalid_left_def LocalLexing_axioms leftderivation_implies_derivation)
  have left_imp_right: "pvalid p x \<Longrightarrow> pvalid_left p x"
  proof -
    assume "pvalid p x"
    then obtain u \<gamma> where
      "wellformed_tokens p \<and>
       wellformed_item x \<and>
       u \<le> length p \<and>
       charslength p = item_end x \<and>
       charslength (take u p) = item_origin x \<and>
       is_derivation (terminals (take u p) @ [item_nonterminal x] @ \<gamma>) \<and>
       derives (item_\<alpha> x) (terminals (drop u p))" by (simp add: pvalid_def, blast)
    thus ?thesis
      apply (auto simp add: pvalid_left_def)
      apply (rule_tac x=u in exI)
      apply auto
      apply (simp add: is_leftderivation_def)
      apply (rule_tac derives_implies_leftderives_cons[where b=\<gamma>])
      apply (erule is_word_terminals_take)
      apply (simp add: is_derivation_def)
      by (metis derives_implies_leftderives is_word_terminals_drop)
  qed
  show ?thesis by (metis left_imp_right right_imp_left)
qed

lemma \<L>\<^sub>P_wellformed_tokens: "terminals p \<in> \<L>\<^sub>P \<Longrightarrow> wellformed_tokens p"
by (metis (mono_tags, lifting) \<L>\<^sub>P_is_word is_word_def length_map list_all_length
    nth_map terminals_def wellformed_token_def wellformed_tokens_def)

end

end


(*  Title:      statecharts/HA/HASem.thy

    Author:     Steffen Helke and Florian Kammüller, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

section \<open>Semantics of Hierarchical Automata\<close>
theory HASem
imports HA
begin

subsection \<open>Definitions\<close>

definition
  RootExSem :: "[(('s,'e,'d)seqauto) set, 's \<rightharpoonup> ('s,'e,'d)seqauto set,
                 's set] => bool" where
  "RootExSem F G C == (\<exists>! S. S \<in> States (Root F G) \<and> S \<in> C)"

definition
  UniqueSucStates ::  "[(('s,'e,'d)seqauto) set, 's \<rightharpoonup> ('s,'e,'d)seqauto set,
                        's set] \<Rightarrow> bool" where
  "UniqueSucStates F G C  == \<forall> S \<in> (\<Union>(States ` F)).
                                   \<forall> A \<in> the (G S).
                                      if (S \<in> C) then
                                       \<exists>! S' . S' \<in>  States A \<and> S' \<in> C
                                     else
                                       \<forall> S \<in> States A. S \<notin> C"

definition
  IsConfSet :: "[(('s,'e,'d)seqauto) set, 's \<rightharpoonup> ('s,'e,'d)seqauto set,
                 's set] => bool" where
  "IsConfSet F G C ==
                C \<subseteq> (\<Union>(States ` F)) &
                RootExSem F G C &
                UniqueSucStates F G C"

definition
  Status :: "[('s,'e,'d)hierauto,
              's set,
              'e set,
              'd data] => bool" where
  "Status HA C E D == E \<subseteq> HAEvents HA \<and>
                      IsConfSet (SAs HA) (CompFun HA) C \<and>
                      Data.DataSpace (HAInitValue HA) = Data.DataSpace D"

subsubsection \<open>\<open>Status\<close>\<close>

lemma Status_EmptySet:
 "(Abs_hierauto ((@ x . True),
    {Abs_seqauto ({ @ x . True}, (@ x . True), {}, {})}, {}, Map.empty(@ x . True \<mapsto> {})),
  {@x. True},{}, @x. True) \<in>
  {(HA,C,E,D) | HA C E D. Status HA C E D}"
apply (unfold Status_def CompFun_def SAs_def)
apply auto
apply (subst Abs_hierauto_inverse)
apply (subst hierauto_def)
apply (rule HierAuto_EmptySet)
apply (subst Abs_hierauto_inverse)
apply (subst hierauto_def)
apply (rule HierAuto_EmptySet)
apply auto
apply (unfold IsConfSet_def UniqueSucStates_def RootExSem_def)
apply auto
apply (unfold States_def)
apply auto
apply (unfold Root_def)
apply (rule someI2)
apply (rule conjI)
apply fast
apply (simp add: ran_def)
apply simp
apply (subst Abs_seqauto_inverse)
apply (subst seqauto_def)
apply (rule SeqAuto_EmptySet)
apply simp
apply (unfold HAInitValue_def)
apply auto
apply (subst Abs_hierauto_inverse)
apply (subst hierauto_def)
apply (rule HierAuto_EmptySet)
apply simp
done

definition
  "status =
    {(HA,C,E,D) |
        (HA::('s,'e,'d)hierauto)
        (C::('s set))
        (E::('e set))
        (D::'d data). Status HA C E D}"

typedef ('s,'e,'d) status =
    "status :: (('s,'e,'d)hierauto * 's set * 'e set * 'd data) set"
  unfolding status_def
  apply (rule exI)
  apply (rule Status_EmptySet)
  done

definition
  HA :: "('s,'e,'d) status  => ('s,'e,'d) hierauto" where
  "HA == fst o Rep_status"

definition
  Conf :: "('s,'e,'d) status  => 's set" where
  "Conf == fst o snd o Rep_status"

definition
  Events :: "('s,'e,'d) status  => 'e set" where
  "Events == fst o snd o snd o Rep_status"

definition
  Value :: "('s,'e,'d) status  => 'd data" where
  "Value == snd o snd o snd o Rep_status"

definition
  RootState :: "('s,'e,'d) status  => 's" where
  "RootState ST == @ S. S \<in> Conf ST \<and> S \<in> States (HARoot (HA ST))"

(* -------------------------------------------------------------- *)
(* enabled transitions                                            *)
(* -------------------------------------------------------------- *)

definition
  EnabledTrans :: "(('s,'e,'d)status * ('s,'e,'d)seqauto *
                    ('s,'e,'d)trans) set" where
  "EnabledTrans == {(ST,SA,T) .
                       SA \<in> SAs (HA ST) \<and>
                       T \<in> Delta SA \<and>
                       source T \<in> Conf ST \<and>
                       (Conf ST, Events ST, Value ST) |= (label T) }"

definition
  ET :: "('s,'e,'d) status => (('s,'e,'d) trans) set" where
  "ET ST == \<Union> SA \<in> SAs (HA ST). (EnabledTrans `` {ST}) `` {SA}"

(* -------------------------------------------------------------- *)
(* maximal non conflicting set of transitions                     *)
(* -------------------------------------------------------------- *)

definition
  MaxNonConflict :: "[('s,'e,'d)status,
                      ('s,'e,'d)trans set] => bool" where
  "MaxNonConflict ST T ==
        (T \<subseteq> ET ST) \<and>
        (\<forall> A \<in> SAs (HA ST). card (T Int Delta A) \<le> 1)  \<and>
        (\<forall> t \<in> (ET ST). (t \<in> T) =  (\<not> (\<exists> t' \<in> ET ST. HigherPriority (HA ST) (t',t))))"

(* -------------------------------------------------------------- *)
(* resolving the occurrence of racing with interleaving semantic  *)
(* for one set of transitions                                     *)
(* -------------------------------------------------------------- *)

definition
 ResolveRacing :: "('s,'e,'d)trans set
                   => ('d update set)" where
 "ResolveRacing TS ==
            let
                U = PUpdate (Label TS)
            in
                SequentialRacing U"

(* -------------------------------------------------------------- *)
(* HPT is a set, there can be more than one! If there are         *)
(* nondeterministic transitions t1, t2 in one SA : SAs A, then    *)
(* they are not in conflict wt higher priority. We have to chose  *)
(* one and get different sets.                                    *)
(* -------------------------------------------------------------- *)

definition
 HPT :: "('s,'e,'d)status => (('s,'e,'d)trans set) set" where
 "HPT ST == { T. MaxNonConflict ST T}"

(* -------------------------------------------------------------- *)
(* The initials status can be defined now for a given automaton.  *)
(* -------------------------------------------------------------- *)

definition
 InitStatus :: "('s,'e,'d)hierauto => ('s,'e,'d)status" where
 "InitStatus A ==
    Abs_status (A,InitConf A,{}, HAInitValue A)"

(* -------------------------------------------------------------- *)
(* The next status for a given status can be defined now by a     *)
(* step.                                                          *)
(* -------------------------------------------------------------- *)

definition
  StepActEvent :: "('s,'e,'d)trans set => 'e set" where
  "StepActEvent TS == Union (Actevent (Label TS))"

definition
  StepStatus :: "[('s,'e,'d)status, ('s,'e,'d)trans set, 'd update]
                 => ('s,'e,'d)status" where
  "StepStatus ST TS U =
                (let
                   (A,C,E,D) = Rep_status ST;
                   C'        = StepConf A C TS;
                   E'        = StepActEvent TS;
                   D'        = U !!! D
                 in
                   Abs_status (A,C',E',D'))"

(* --------------------------------------------------------------- *)
(* The Relation StepRel defines semantic transitions on statuses   *)
(* for given hierarchical automaton.                               *)
(* --------------------------------------------------------------- *)

definition
  StepRelSem :: "('s,'e,'d)hierauto
              => (('s,'e,'d)status * ('s,'e,'d)status) set" where
  "StepRelSem A == {(ST,ST'). (HA ST) = A \<and>
                    ((HPT ST \<noteq> {}) \<longrightarrow>
                       (\<exists>TS \<in> HPT ST.
                           \<exists>U \<in> ResolveRacing TS.
                                  ST' = StepStatus ST TS U)) &
                    ((HPT ST = {}) \<longrightarrow>
                       (ST' = StepStatus ST {} DefaultUpdate))}"

(* --------------------------------------------------------------- *)
(* The Relation StepRel defines semantic transitions on statuses   *)
(* The set of all reachable stati can now be defined inductively   *)
(* as the set of statuses derived through applications of          *)
(* transitions starting from the initial status TInitStatus 0.     *)
(* --------------------------------------------------------------- *)

inductive_set
  ReachStati  :: "('s,'e,'d)hierauto => ('s,'e,'d) status set"
  for A ::  "('s,'e,'d)hierauto"
where
  Status0 : "InitStatus A \<in> ReachStati A"
| StatusStep :
     "\<lbrakk> ST \<in> ReachStati A;  TS \<in> HPT ST; U \<in> ResolveRacing TS \<rbrakk>
      \<Longrightarrow> StepStatus ST TS U \<in> ReachStati A"

subsection \<open>Lemmas\<close>

lemma Rep_status_tuple:
 "Rep_status ST = (HA ST, Conf ST, Events ST, Value ST)"
by (unfold HA_def Conf_def Events_def Value_def, simp)

lemma Rep_status_select:
 "(HA ST, Conf ST, Events ST, Value ST) \<in> status"
by (rule Rep_status_tuple [THEN subst], rule Rep_status)

lemma Status_select [simp]:
  "Status (HA ST) (Conf ST) (Events ST) (Value ST)"
apply (cut_tac Rep_status_select)
apply (unfold status_def)
apply simp
done

subsubsection \<open>\<open>IsConfSet\<close>\<close>

lemma IsConfSet_Status [simp]:
 "IsConfSet (SAs (HA ST)) (CompFun (HA ST)) (Conf ST)"
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def)
apply auto
done

subsubsection \<open>\<open>InitStatus\<close>\<close>

lemma IsConfSet_InitConf [simp]:
  "IsConfSet (SAs A) (CompFun A) (InitConf A)"
apply (unfold IsConfSet_def RootExSem_def UniqueSucStates_def, fold HARoot_def)
apply (rule conjI)
apply (fold HAStates_def, simp)
apply (rule conjI)
apply (rule_tac a="HAInitState A" in ex1I)
apply auto
apply (rename_tac S SA)
apply (case_tac "S \<in> InitConf A")
apply auto
apply (rule_tac x="InitState SA" in exI)
apply auto
apply (rule InitState_CompFun_InitConf)
apply auto
apply (rename_tac S SA T U)
apply (case_tac "U = InitState SA")
apply auto
apply (simp only:InitConf_CompFun_Ancestor HAStates_SA_mem, simp)+
done

lemma InitConf_status [simp]:
  "(A, InitConf A, {}, HAInitValue A) \<in>  status"
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def)
apply auto
done

lemma Conf_InitStatus_InitConf [simp]:
 "Conf (InitStatus A) = InitConf A"
apply (unfold Conf_def InitStatus_def)
apply simp
apply (subst Abs_status_inverse)
apply auto
done

lemma HAInitValue_Value_DataSpace_Status [simp]:
  "Data.DataSpace (HAInitValue (HA ST)) = Data.DataSpace (Value ST)"
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def)
apply fast
done

lemma Value_InitStatus_HAInitValue [simp]:
 "Value (InitStatus A) = HAInitValue A"
apply (unfold Value_def InitStatus_def)
apply simp
apply (subst Abs_status_inverse)
apply auto
done

lemma HA_InitStatus [simp]:
 "HA (InitStatus A) = A"
apply (unfold InitStatus_def HA_def)
apply auto
apply (subst Abs_status_inverse)
apply auto
done

subsubsection \<open>\<open>Events\<close>\<close>

lemma Events_HAEvents_Status:
  "(Events ST) \<subseteq> HAEvents (HA ST)"
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def)
apply fast
done

lemma TS_EventSet:
    "TS \<subseteq>  ET ST \<Longrightarrow> \<Union> (Actevent (Label TS)) \<subseteq> HAEvents (HA ST)"
apply (unfold Actevent_def actevent_def ET_def EnabledTrans_def Action_def Label_def)
apply (cut_tac HA="HA ST" in HAEvents_SAEvents_SAs)
apply auto
apply (rename_tac Event Source Trigger Guard Action Update Target)
apply (unfold SAEvents_def)
apply (erule subsetCE)
apply auto
apply (rename_tac SA)
apply (erule subsetCE)
apply auto
apply (erule_tac x=SA in ballE)
apply auto
apply (erule_tac x="(Trigger, Guard, Action, Update)" in ballE)
apply auto
apply (cut_tac SA=SA in Label_Delta_subset)
apply (erule subsetCE)
apply (unfold Label_def image_def)
apply auto
done

subsubsection \<open>\<open>StepStatus\<close>\<close>

lemma StepStatus_empty:
   "Abs_status (HA ST, Conf ST, {}, U !!! (Value ST)) = StepStatus ST {} U"
apply (unfold StepStatus_def Let_def)
apply auto
apply (subst Rep_status_tuple)
apply auto
apply (unfold StepActEvent_def)
apply auto
done

lemma status_empty_eventset [simp]:
      "(HA ST, Conf ST, {}, U !!! (Value ST)) \<in> status"
apply (unfold status_def Status_def)
apply auto
done

lemma HA_StepStatus_emptyTS [simp]:
  "HA (StepStatus ST {} U) = HA ST"
apply (subst StepStatus_empty [THEN sym])
apply (unfold HA_def)
apply auto
apply (subst Abs_status_inverse)
apply auto
apply (subst Rep_status_tuple)
apply auto
done

subsubsection \<open>Enabled Transitions \<open>ET\<close>\<close>

lemma HPT_ETI:
    "TS \<in> HPT ST \<Longrightarrow> TS \<subseteq> ET ST"
by (unfold HPT_def MaxNonConflict_def, auto)

lemma finite_ET [simp]:
 "finite (ET ST)"
by (unfold ET_def Image_def EnabledTrans_def, auto)

subsubsection \<open>Finite Transition Set\<close>

lemma finite_MaxNonConflict [simp]:
 "MaxNonConflict ST TS \<Longrightarrow> finite TS"
apply (unfold MaxNonConflict_def)
apply auto
apply (subst finite_subset)
apply auto
done

lemma finite_HPT [simp]:
  "TS \<in> HPT ST \<Longrightarrow> finite TS"
by (unfold HPT_def, auto)

subsubsection \<open>\<open>PUpdate\<close>\<close>

lemma finite_Update:
 "finite TS \<Longrightarrow> finite ((\<lambda> F. (Rep_pupdate F) (Value ST)) ` (PUpdate (Label TS)))"
by (rule finite_imageI, auto)

lemma finite_PUpdate:
 "TS \<in> HPT S \<Longrightarrow> finite (Expr.PUpdate (Label TS))"
apply auto
done

lemma HPT_ResolveRacing_Some [simp]:
  "TS \<in> HPT S \<Longrightarrow> (SOME u. u \<in> ResolveRacing TS) \<in> ResolveRacing TS"
apply (unfold ResolveRacing_def Let_def)
apply (rule finite_SequentialRacing)
apply auto
done

subsubsection \<open>Higher Priority Transitions \<open>HPT\<close>\<close>

lemma finite_HPT2 [simp]:
  "finite (HPT ST)"
apply (cut_tac ST=ST in finite_ET)
apply (unfold HPT_def MaxNonConflict_def)
apply (subst Collect_subset)
apply (frule finite_Collect_subsets)
apply auto
done

lemma HPT_target_StepConf [simp]:
  "\<lbrakk> TS \<in> HPT ST; T \<in> TS \<rbrakk> \<Longrightarrow> target T \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def)
apply auto
done

lemma HPT_target_StepConf2 [simp]:
  "\<lbrakk> TS \<in> HPT ST; (S,L,T) \<in> TS \<rbrakk> \<Longrightarrow> T \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def Target_def Source_def source_def target_def image_def)
apply auto
apply auto
done

subsubsection \<open>Delta Transition Set\<close>

lemma ET_Delta:
  "\<lbrakk> TS \<subseteq> ET ST; t \<in> TS; source t \<in> States A; A \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow> t \<in> Delta A"
apply (unfold ET_def EnabledTrans_def)
apply simp
apply (erule subsetCE)
apply auto
apply (rename_tac SA)
apply (case_tac "A = SA")
apply auto
apply (cut_tac HA="HA ST" in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply force
done

lemma ET_Delta_target:
  "\<lbrakk> TS \<subseteq> ET ST; t \<in> TS; target t \<in> States A; A \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> t \<in> Delta A"
apply (unfold ET_def EnabledTrans_def)
apply simp
apply (erule subsetCE)
apply auto
apply (rename_tac SA)
apply (case_tac "A = SA")
apply auto
apply (cut_tac HA="HA ST" in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply force
done

lemma ET_HADelta:
   " \<lbrakk> TS \<subseteq> ET ST; t \<in> TS \<rbrakk> \<Longrightarrow> t \<in> HADelta (HA ST)"
apply (unfold HADelta_def)
apply auto
apply (unfold ET_def EnabledTrans_def Image_def)
apply auto
done

lemma HPT_HADelta:
   " \<lbrakk> TS \<in> HPT ST; t \<in> TS \<rbrakk> \<Longrightarrow> t \<in> HADelta (HA ST)"
apply (rule ET_HADelta)
apply (unfold HPT_def MaxNonConflict_def)
apply auto
done

lemma HPT_Delta:
  "\<lbrakk> TS \<in> HPT ST; t \<in> TS; source t \<in> States A; A \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow> t \<in> Delta A"
apply (rule ET_Delta)
apply auto
apply (unfold HPT_def MaxNonConflict_def)
apply fast
done

lemma HPT_Delta_target:
  "\<lbrakk> TS \<in> HPT ST; t \<in> TS; target t \<in> States A; A \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow> t \<in> Delta A"
apply (rule ET_Delta_target)
apply auto
apply (unfold HPT_def MaxNonConflict_def)
apply fast
done

lemma OneTrans_HPT_SA:
  "\<lbrakk> TS \<in> HPT ST; T \<in> TS; source T \<in> States SA;
     U \<in> TS; source U \<in> States SA; SA \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> T = U"
apply (unfold HPT_def MaxNonConflict_def Source_def)
apply auto
apply (erule_tac x=SA in ballE)
apply (case_tac "finite (TS \<inter> Delta SA)")
apply (frule_tac t=T in OneElement_Card)
apply fast
apply (frule_tac t=T and A=SA in ET_Delta)
apply assumption+
apply fast
apply (frule_tac t=U in OneElement_Card)
apply fast
apply (frule_tac t=U and A=SA in ET_Delta)
apply auto
done

lemma OneTrans_HPT_SA2:
  "\<lbrakk> TS \<in> HPT ST; T \<in> TS; target T \<in> States SA;
     U \<in> TS; target U \<in> States SA; SA \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> T = U"
apply (unfold HPT_def MaxNonConflict_def Target_def)
apply auto
apply (erule_tac x=SA in ballE)
apply (case_tac "finite (TS \<inter> Delta SA)")
apply (frule_tac t=T in OneElement_Card)
apply fast
apply (frule_tac t=T and A=SA in ET_Delta_target)
apply assumption+
apply fast
apply (frule_tac t=U in OneElement_Card)
apply fast
apply (frule_tac t=U and A=SA in ET_Delta_target)
apply auto
done

subsubsection \<open>Target Transition Set\<close>

lemma ET_Target_HAStates:
    "TS \<subseteq> ET ST \<Longrightarrow> Target TS \<subseteq> HAStates (HA ST)"
apply (unfold HAStates_def Target_def target_def ET_def EnabledTrans_def Action_def Label_def)
apply (cut_tac HA="HA ST" in Target_SAs_Delta_States)
apply auto
apply (rename_tac Source Trigger Guard Action Update Target)
apply (unfold Target_def)
apply (erule subsetCE)
apply auto
apply (rename_tac SA)
apply (erule subsetCE)
apply auto
apply (unfold image_def)
apply auto
apply (metis target_select)
done

lemma HPT_Target_HAStates:
 "TS \<in> HPT ST \<Longrightarrow> Target TS \<subseteq> HAStates (HA ST)"
apply (rule HPT_ETI [THEN ET_Target_HAStates])
apply assumption
done

lemma HPT_Target_HAStates2 [simp]:
  "\<lbrakk>TS \<in> HPT ST; S \<in> Target TS\<rbrakk> \<Longrightarrow> S \<in> HAStates (HA ST)"
apply (cut_tac HPT_Target_HAStates)
apply fast+
done

lemma OneState_HPT_Target:
  "\<lbrakk> TS \<in> HPT ST; S \<in> Target TS;
     T \<in> Target TS; S \<in> States SA;
     T \<in> States SA; SA \<in> SAs (HA ST) \<rbrakk>
   \<Longrightarrow> S = T"
apply (unfold Target_def)
apply (auto dest: OneTrans_HPT_SA2[rotated -1])
done

subsubsection \<open>Source Transition Set\<close>

lemma ET_Source_Conf:
  "TS \<subseteq> ET ST \<Longrightarrow> (Source TS) \<subseteq> Conf ST"
apply (unfold Source_def ET_def EnabledTrans_def)
apply auto
done

lemma HPT_Source_Conf [simp]:
  "TS \<in> HPT ST \<Longrightarrow> (Source TS) \<subseteq> Conf ST"
apply (unfold HPT_def MaxNonConflict_def)
apply (rule ET_Source_Conf)
apply auto
done

lemma ET_Source_Target [simp]:
  "\<lbrakk> SA \<in> SAs (HA ST); TS \<subseteq> ET ST; States SA \<inter> Source TS = {} \<rbrakk> \<Longrightarrow> States SA \<inter> Target TS = {}"
apply (unfold ET_def EnabledTrans_def Source_def Target_def)
apply auto
apply (rename_tac Source Trigger Guard Action Update Target)
apply (erule subsetCE)
apply auto
apply (rename_tac SAA)
apply (unfold image_def source_def Int_def)
apply auto
apply (erule_tac x=Source in allE)
apply auto
apply (frule Delta_source_States)
apply (unfold source_def)
apply auto
apply (case_tac "SA=SAA")
apply auto
apply (cut_tac HA="HA ST" in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply (erule_tac x=SA in ballE)
apply (erule_tac x=SAA in ballE)
apply auto
apply (frule Delta_target_States)
apply (unfold target_def)
apply force
done

lemma HPT_Source_Target [simp]:
  "\<lbrakk> TS \<in> HPT ST; States SA \<inter> Source TS = {}; SA \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> States SA \<inter> Target TS = {}"
apply (unfold HPT_def MaxNonConflict_def)
apply auto
done

lemma ET_target_source:
  "\<lbrakk> TS \<subseteq> ET ST; t \<in> TS; target t \<in> States A; A \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> source t \<in> States A"
apply (frule ET_Delta_target)
apply auto
done

lemma ET_source_target:
  "\<lbrakk> TS \<subseteq> ET ST; t \<in> TS; source t \<in> States A; A \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> target t \<in> States A"
apply (frule ET_Delta)
apply auto
done

lemma HPT_target_source:
  "\<lbrakk> TS \<in> HPT ST; t \<in> TS; target t \<in> States A; A \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow> source t \<in> States A"
apply (rule ET_target_source)
apply auto
apply (unfold HPT_def MaxNonConflict_def)
apply fast
done

lemma HPT_source_target:
  "\<lbrakk> TS \<in> HPT ST; t \<in> TS; source t \<in> States A; A \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> target t \<in> States A"
apply (rule ET_source_target)
apply auto
apply (unfold HPT_def MaxNonConflict_def)
apply fast
done

lemma HPT_source_target2 [simp]:
  "\<lbrakk> TS \<in>HPT ST; (s,l,t) \<in> TS; s \<in> States A; A \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow>  t \<in>States A"
apply (cut_tac ST=ST and TS=TS and t="(s,l,t)" in HPT_source_target)
apply auto
done

lemma ChiRel_ChiStar_Source_notmem:
   "\<lbrakk> TS \<in> HPT ST; (S, T) \<in> ChiRel (HA ST); S \<in> Conf ST;
      T \<notin> ChiStar (HA ST) `` Source TS \<rbrakk> \<Longrightarrow>
      S \<notin> ChiStar (HA ST) `` Source TS"
apply auto
apply (rename_tac U)
apply (simp only: Image_def)
apply auto
apply (erule_tac x=U in ballE)
apply (fast intro: ChiRel_ChiStar_trans)+
done

lemma ChiRel_ChiStar_notmem:
  "\<lbrakk> TS \<in> HPT ST; (S,T) \<in> ChiRel (HA ST);
     S \<in> ChiStar (HA ST) `` Source TS \<rbrakk> \<Longrightarrow> T \<notin> Source TS"
using [[hypsubst_thin = true]]
apply (unfold HPT_def MaxNonConflict_def HigherPriority_def restrict_def)
apply auto
apply (rename_tac U)
apply (unfold Source_def image_def)
apply auto
apply (rename_tac SSource STrigger SGuard SAction SUpdate STarget
                  TSource TTrigger TGuard TAction TUpdate TTarget)
apply (erule_tac x="(SSource, (STrigger, SGuard, SAction, SUpdate), STarget)" in ballE)
apply auto
apply (erule_tac x="(TSource, (TTrigger, TGuard, TAction, TUpdate), TTarget)" in ballE)
apply auto
apply (simp add: ET_HADelta)
apply (case_tac "SSource=S")
apply auto
apply (frule ChiStar_ChiPlus_noteq)
apply fast
apply (fast intro: ChiRel_ChiPlus_trans)
done

subsubsection \<open>\<open>StepActEvents\<close>\<close>

lemma StepActEvent_empty [simp]:
  "StepActEvent {} = {}"
by (unfold StepActEvent_def, auto)

lemma StepActEvent_HAEvents:
 "TS \<in> HPT ST \<Longrightarrow> StepActEvent TS \<subseteq> HAEvents (HA ST)"
apply (unfold StepActEvent_def image_def)
apply (rule HPT_ETI [THEN TS_EventSet])
apply assumption
done

subsubsection \<open>\<open>UniqueSucStates\<close>\<close>

lemma UniqueSucStates_Status [simp]:
  "UniqueSucStates (SAs (HA ST)) (CompFun (HA ST)) (Conf ST)"
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def IsConfSet_def)
apply auto
done

subsubsection \<open>\<open>RootState\<close>\<close>

lemma RootExSem_Status [simp]:
  "RootExSem (SAs (HA ST)) (CompFun (HA ST)) (Conf ST)"
apply (cut_tac Rep_status_select)
apply (unfold status_def Status_def IsConfSet_def)
apply auto
done

lemma RootState_HARootState [simp]:
  "(RootState ST) \<in> States (HARoot (HA ST))"
apply (unfold RootState_def)
apply (cut_tac ST=ST in RootExSem_Status)
apply (unfold RootExSem_def HARoot_def HAStates_def)
apply auto
apply (subst some1_equality)
apply auto
done

lemma RootState_Conf [simp]:
  "(RootState ST) \<in> (Conf ST)"
apply (unfold RootState_def)
apply (cut_tac ST=ST in RootExSem_Status)
apply (unfold RootExSem_def HARoot_def HAStates_def)
apply auto
apply (subst some1_equality)
apply auto
done

lemma RootState_notmem_Chi [simp]:
  "S \<in> HAStates (HA ST) \<Longrightarrow> (RootState ST) \<notin> Chi (HA ST) S"
by auto

lemma RootState_notmem_Range_ChiRel [simp]:
  "RootState ST \<notin> Range (ChiRel (HA ST))"
by auto

lemma RootState_Range_ChiPlus [simp]:
  "RootState ST \<notin> Range (ChiPlus (HA ST))"
by auto

lemma RootState_Range_ChiStar [simp]:
  "\<lbrakk> x \<noteq> RootState ST \<rbrakk> \<Longrightarrow> (x,RootState ST) \<notin> (ChiStar (HA ST))"
by auto

lemma RootState_notmem_ChiRel [simp]:
  "(x,RootState ST) \<notin> (ChiRel (HA ST))"
by (unfold ChiRel_def, auto)

lemma RootState_notmem_ChiRel2 [simp]:
  "\<lbrakk> S \<in> States (HARoot (HA ST))  \<rbrakk> \<Longrightarrow> (x,S) \<notin> (ChiRel (HA ST))"
by (unfold ChiRel_def, auto)

lemma RootState_Conf_StepConf [simp]:
  "\<lbrakk> RootState ST \<notin> Source TS \<rbrakk> \<Longrightarrow> RootState ST \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def)
apply auto
apply (rename_tac S)
apply (case_tac "S=RootState ST")
apply fast
apply auto
apply (rename_tac S)
apply (case_tac "S=RootState ST")
apply fast
apply auto
done

lemma OneRootState_Conf [simp]:
  "\<lbrakk> S \<in> States (HARoot (HA ST)); S \<in> Conf ST \<rbrakk> \<Longrightarrow> S = RootState ST"
apply (cut_tac ST=ST in IsConfSet_Status)
apply (unfold IsConfSet_def RootExSem_def)
apply (fold HARoot_def)
apply auto
done

lemma OneRootState_Source:
  "\<lbrakk> TS \<in> HPT ST; S \<in> Source TS; S \<in> States (HARoot (HA ST)) \<rbrakk> \<Longrightarrow> S = RootState ST"
apply (cut_tac ST=ST and TS=TS in HPT_Source_Conf, assumption)
apply (cut_tac ST=ST in OneRootState_Conf)
apply fast+
done

lemma OneState_HPT_Target_Source:
  "\<lbrakk> TS \<in> HPT ST; S \<in> States SA; SA \<in> SAs (HA ST);
     States SA \<inter> Source TS = {} \<rbrakk>
   \<Longrightarrow> S \<notin> Target TS"
apply (unfold Target_def)
apply auto
apply (unfold Source_def Image_def Int_def)
apply auto
apply (frule HPT_target_source)
apply auto
done

lemma RootState_notmem_Target [simp]:
  "\<lbrakk> TS \<in> HPT ST; S \<in> States (HARoot (HA ST)); RootState ST \<notin> Source TS \<rbrakk> \<Longrightarrow> S \<notin> Target TS"
apply auto
apply (frule OneState_HPT_Target_Source)
prefer 4
apply fast+
apply simp
apply (unfold Int_def)
apply auto
apply (frule OneRootState_Source)
apply fast+
done

subsubsection \<open>Configuration \<open>Conf\<close>\<close>

lemma Conf_HAStates:
 "Conf ST \<subseteq> HAStates (HA ST)"
apply (cut_tac Rep_status_select)
apply (unfold IsConfSet_def status_def Status_def HAStates_def)
apply fast
done

lemma Conf_HAStates2 [simp]:
  "S \<in> Conf ST \<Longrightarrow> S \<in> HAStates (HA ST)"
apply (cut_tac ST="ST" in Conf_HAStates)
apply fast
done

lemma OneState_Conf [intro]:
  "\<lbrakk> S \<in> Conf ST; T \<in> Conf ST; S \<in> States SA; T \<in> States SA;
     SA \<in> SAs (HA ST)\<rbrakk> \<Longrightarrow> T = S"
apply (cut_tac ST=ST in IsConfSet_Status)
apply (unfold IsConfSet_def UniqueSucStates_def)
apply (case_tac "SA = HARoot (HA ST)")
apply (cut_tac ST=ST and S=S in OneRootState_Conf)
apply fast+
apply (simp only:OneRootState_Conf)
apply (erule conjE)+
apply (cut_tac HA="HA ST" in OneAncestor_HA)
apply (unfold OneAncestor_def)
apply (fold HARoot_def)
apply (erule_tac x=SA in ballE)
apply (drule ex1_implies_ex)
apply (erule exE)
apply (rename_tac U)
apply (erule_tac x=U in ballE)
apply (erule_tac x=SA in ballE)
apply (case_tac "U \<in> Conf ST")
apply simp
apply safe
apply fast+
apply simp
apply fast
done

lemma OneState_HPT_SA:
  "\<lbrakk> TS \<in> HPT ST; S \<in> Source TS; T \<in> Source TS;
     S \<in> States SA; T \<in> States SA;
     SA \<in> SAs (HA ST) \<rbrakk> \<Longrightarrow> S = T"
apply (rule OneState_Conf)
apply auto
apply (frule HPT_Source_Conf, fast)+
done

lemma HPT_SAStates_Target_Source:
   "\<lbrakk>TS \<in> HPT ST; A \<in> SAs (HA ST); S \<in> States A; T \<in> States A; S \<in> Conf ST;
     T \<in> Target TS \<rbrakk> \<Longrightarrow> S \<in> Source TS"
apply (case_tac "States A \<inter> Source TS ={}")
apply (frule OneState_HPT_Target_Source)
apply fast
back
apply simp+
apply auto
apply (rename_tac U)
apply (cut_tac ST=ST in HPT_Source_Conf)
apply fast
apply (frule_tac S=S and T=U in OneState_Conf)
apply fast+
done

lemma HPT_Conf_Target_Source:
   "\<lbrakk>TS \<in> HPT ST; S \<in> Conf ST;
     S \<in> Target TS \<rbrakk> \<Longrightarrow> S \<in> Source TS"
apply (frule Conf_HAStates2)
apply (unfold HAStates_def)
apply auto
apply (simp only:HPT_SAStates_Target_Source)
done

lemma Conf_SA:
  "S \<in> Conf ST \<Longrightarrow> \<exists> A \<in> SAs (HA ST). S \<in> States A"
apply (cut_tac ST=ST in IsConfSet_Status)
apply (unfold IsConfSet_def)
apply fast
done

lemma HPT_Source_HAStates [simp]:
   "\<lbrakk> TS \<in> HPT ST; S \<in> Source TS \<rbrakk> \<Longrightarrow> S \<in> HAStates (HA ST)"
apply (frule HPT_Source_Conf)
apply (rule Conf_HAStates2)
apply fast
done

lemma Conf_Ancestor:
  "\<lbrakk> S \<in> Conf ST;  A \<in> the (CompFun (HA ST) S) \<rbrakk> \<Longrightarrow> \<exists>! T \<in> States A. T \<in> Conf ST"
apply (cut_tac ST=ST in IsConfSet_Status)
apply (unfold IsConfSet_def UniqueSucStates_def)
apply safe
apply (erule_tac x=S in ballE)
prefer 2
apply blast
apply (erule_tac x=A in ballE)
prefer 2
apply fast
apply simp
apply (fast intro: HAStates_CompFun_SAs_mem Conf_HAStates2)+
done

lemma Conf_ChiRel:
   "\<lbrakk> (S,T) \<in> ChiRel (HA ST); T \<in> Conf ST \<rbrakk> \<Longrightarrow> S \<in> Conf ST"
apply (unfold ChiRel_def Chi_def restrict_def)
apply simp
apply safe
apply simp
apply safe
apply (rename_tac SA)
apply (unfold HAStates_def)
apply simp
apply safe
apply (rename_tac U)
apply (cut_tac ST=ST in UniqueSucStates_Status)
apply (unfold UniqueSucStates_def)
apply (erule_tac x=S in ballE)
apply (erule_tac x=SA in ballE)
apply auto
apply (case_tac "S \<in> Conf ST")
apply simp+
done

lemma Conf_ChiPlus:
   "\<lbrakk> (T,S) \<in> ChiPlus (HA ST) \<rbrakk> \<Longrightarrow>  S \<in> Conf ST \<longrightarrow> T \<in> Conf ST"
apply (unfold ChiPlus_def)
apply (rule_tac a="T" and b="S" and r="(ChiRel (HA ST))" in trancl_induct)
apply (fast intro: Conf_ChiRel)+
done

lemma HPT_Conf_Target_Source_ChiPlus:
  "\<lbrakk> TS \<in> HPT ST; S \<in> Conf ST; S \<in> ChiPlus (HA ST) `` Target TS \<rbrakk>
     \<Longrightarrow> S \<in> ChiStar (HA ST) `` Source TS"
apply auto
apply (rename_tac T)
apply (simp add: Image_def)
apply (frule HPT_Target_HAStates2)
apply fast
apply (unfold HAStates_def)
apply auto
apply (rename_tac SA)
apply (case_tac "States SA \<inter> Source TS = {}")
apply (simp only:OneState_HPT_Target_Source)
apply auto
apply (rename_tac U)
apply (erule_tac x=U in ballE)
apply auto
apply (case_tac "U=T")
apply auto
apply (frule Conf_ChiPlus)
apply simp
apply (frule HPT_Conf_Target_Source)
apply fast
back
apply fast
apply (simp add:OneState_HPT_SA)
done

lemma OneState_HPT_Target_ChiRel:
   "\<lbrakk> TS \<in> HPT ST; (U,T) \<in> ChiRel (HA ST);
      U \<in> Target TS; A \<in> SAs (HA ST); T \<in> States A;
      S \<in> States A \<rbrakk> \<Longrightarrow> S \<notin> Target TS"
using [[hypsubst_thin = true]]
apply auto
apply (unfold HigherPriority_def restrict_def HPT_def MaxNonConflict_def Target_def)
apply auto
apply (rename_tac SSource STrigger SGuard SAction SUpdate STarget
                  TSource TTrigger TGuard TAction TUpdate TTarget)
apply (cut_tac t="(TSource, (TTrigger, TGuard, TAction, TUpdate), TTarget)" and TS=TS and ST=ST and A=A in ET_target_source)
apply assumption+
apply simp
apply assumption
apply (frule ChiRel_HAStates)
apply (unfold HAStates_def)
apply safe
apply (cut_tac t="(SSource, (STrigger, SGuard, SAction, SUpdate), STarget)" and A=x and ST=ST and TS=TS in ET_target_source)
apply assumption+
apply simp
apply assumption
apply simp
apply (erule_tac x="(SSource, (STrigger, SGuard, SAction, SUpdate), STarget)" in ballE)
apply simp
apply (erule_tac x="(TSource, (TTrigger, TGuard, TAction, TUpdate), TTarget)" in ballE)
apply (simp add: ET_HADelta)
apply (cut_tac A="HA ST" and S=STarget and T=T and U=TSource in ChiRel_SA_OneAncestor)
apply fast+
apply (frule ET_Source_Conf)
apply (unfold Source_def image_def)
apply (case_tac "SSource \<in>Conf ST")
prefer 2
apply (erule subsetCE)
back
apply fast
back
apply simp
apply (case_tac "TSource \<in>Conf ST")
prefer 2
apply (erule subsetCE)
back
apply fast
apply simp
apply (case_tac "STarget=SSource")
apply simp
apply (fast intro:Conf_ChiRel)+
done

lemma OneState_HPT_Target_ChiPlus [rule_format]:
   "\<lbrakk> TS \<in> HPT ST; (U,T) \<in> ChiPlus (HA ST);
      S \<in> Target TS; A \<in> SAs (HA ST);
      S \<in> States A \<rbrakk> \<Longrightarrow> T \<in> States A \<longrightarrow> U \<notin> Target TS"
using [[hypsubst_thin = true]]
apply (unfold ChiPlus_def)
apply (rule_tac a="U" and b="T" and r="(ChiRel (HA ST))" in converse_trancl_induct)
apply auto
apply (simp only:OneState_HPT_Target_ChiRel)
apply (rename_tac V W)
apply (fold ChiPlus_def)
apply (unfold HPT_def MaxNonConflict_def Target_def HigherPriority_def restrict_def)
apply auto
apply (rename_tac SSource STrigger SGuard SAction SUpdate STarget
                  TSource TTrigger TGuard TAction TUpdate TTarget)
apply (cut_tac t="(SSource, (STrigger, SGuard, SAction, SUpdate), STarget)" and ST=ST and TS=TS and A=A in ET_target_source)
apply assumption+
apply simp
apply assumption
apply simp
apply (frule ChiRel_HAStates)
apply (unfold HAStates_def)
apply safe
apply (cut_tac t="(TSource, (TTrigger, TGuard, TAction, TUpdate), TTarget)" and A=x and TS=TS and ST=ST in ET_target_source)
apply assumption+
apply simp
apply assumption
apply simp
apply (erule_tac x="(TSource, (TTrigger, TGuard, TAction, TUpdate), TTarget)" in ballE)
apply simp
apply (erule_tac x="(SSource, (STrigger, SGuard, SAction, SUpdate), STarget)" in ballE)
apply (simp add: ET_HADelta)
apply (cut_tac A="HA ST" and S=TTarget and T=T and U=SSource in ChiPlus_SA_OneAncestor)
apply (fast intro: ChiRel_ChiPlus_trans2)
apply fast+
apply (frule ET_Source_Conf)
apply (unfold Source_def image_def)
apply (case_tac "SSource \<in>Conf ST")
prefer 2
apply (erule subsetCE)
back
apply fast
apply simp
apply (case_tac "TSource \<in>Conf ST")
prefer 2
apply (erule subsetCE)
back
apply fast
back
apply simp
apply (case_tac "TTarget=SSource")
apply simp
apply (frule_tac T=TTarget and S=SSource in Conf_ChiPlus)
apply simp
apply (frule_tac T=TSource and S=TTarget in OneState_Conf)
apply fast+
done

subsubsection \<open>\<open>RootExSem\<close>\<close>

lemma RootExSem_StepConf:
   "\<lbrakk> TS \<in> HPT ST \<rbrakk> \<Longrightarrow>
      RootExSem (SAs (HA ST)) (CompFun (HA ST)) (StepConf (HA ST) (Conf ST) TS)"
apply (unfold RootExSem_def)
apply (fold HARoot_def)
apply auto
apply (case_tac "RootState ST \<notin> Source TS")
apply (rule_tac x="RootState ST" in exI)
apply simp
apply simp
apply (unfold Source_def image_def)
apply simp
apply (erule bexE)
apply (rename_tac T)
apply (rule_tac x="target T" in exI)
apply simp
apply (rule HPT_source_target)
apply auto
apply (rename_tac S T)
apply (case_tac "S \<in> Conf ST")
apply (case_tac "T \<in> Conf ST")
apply (frule OneRootState_Conf)
apply auto
apply (frule OneRootState_Conf)
apply auto
apply (frule OneRootState_Conf)
apply auto
apply (case_tac "RootState ST \<in> Source TS")
apply (case_tac "T \<in> Source TS")
apply (frule HPT_Source_Conf)
apply fast
apply (unfold StepConf_def)
apply auto
apply (frule OneState_HPT_Target)
apply (frule_tac SA="HARoot (HA ST)" and TS=TS and S=T and T="RootState ST" in OneState_HPT_Target)
apply fast+
apply simp+
apply (frule trancl_Int_mem, fold ChiPlus_def, force)+
prefer 2
apply (frule OneState_HPT_Target)
apply fast+
back
apply simp+
apply (case_tac "RootState ST \<in> Source TS")
apply (case_tac "T = RootState ST")
apply auto
apply (frule trancl_Int_mem, fold ChiPlus_def, force)+
done

subsubsection \<open>\<open>StepConf\<close>\<close>

lemma Target_StepConf:
   "S \<in> Target TS \<Longrightarrow> S \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def)
apply auto
done

lemma Target_ChiRel_HAInit_StepConf:
   "\<lbrakk> S \<in> Target TS; (S,T) \<in> ChiRel A;
      T \<in> HAInitStates A \<rbrakk> \<Longrightarrow> T \<in> StepConf A C TS"
apply (unfold StepConf_def)
apply auto
done

lemma StepConf_HAStates:
 "TS \<in> HPT ST \<Longrightarrow> StepConf (HA ST) (Conf ST) TS \<subseteq> HAStates (HA ST)"
apply (unfold StepConf_def)
apply auto
apply (frule tranclD2)
apply auto
done

lemma RootState_Conf_StepConf2 [simp]:
  "\<lbrakk> source T = RootState ST; T \<in> TS \<rbrakk> \<Longrightarrow> target T \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def)
apply auto
done

lemma HPT_StepConf_HAStates [simp]:
   "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS \<rbrakk> \<Longrightarrow> S \<in> HAStates (HA ST)"
apply (unfold StepConf_def)
apply auto
apply (frule tranclD2)
apply auto
done

lemma StepConf_Target_HAInitStates:
  "\<lbrakk> S \<in> StepConf (HA ST) (Conf ST) TS; S \<notin> Target TS; S \<notin> Conf ST\<rbrakk> \<Longrightarrow> S \<in> HAInitStates (HA ST)"
apply (unfold StepConf_def)
apply auto
apply (frule tranclD2)
apply auto
done

lemma InitSucState_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<notin> Target TS; A \<in> the (CompFun (HA ST) S);
      S \<notin> Conf ST; S \<in> StepConf (HA ST) (Conf ST) TS \<rbrakk> \<Longrightarrow>
      InitState A \<in> StepConf (HA ST) (Conf ST) TS"
apply (frule StepConf_HAStates [THEN subsetD, THEN CompFun_HAInitStates_HAStates])
apply fast+
apply (subst (asm) StepConf_def)
apply safe
apply (unfold StepConf_def)
apply (fast intro: HAInitStates_InitState_trancl)
apply (frule trancl_Int_mem, fold ChiPlus_def)
apply (fast intro:ChiPlus_HAStates_Right [THEN HAInitStates_InitState_trancl2])
done

lemma InitSucState_Target_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> Target TS; A \<in> the (CompFun (HA ST) S)\<rbrakk> \<Longrightarrow>
      InitState A \<in> StepConf (HA ST) (Conf ST) TS"
apply (frule HPT_Target_HAStates2 [THEN CompFun_HAInitStates_HAStates])
apply fast+
apply (frule HPT_Target_HAStates2 [THEN CompFun_ChiRel])
apply (fast intro:InitState_States)+
apply (unfold StepConf_def)
apply auto
done

lemma InitSucState_Conf_StepConf:
  "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS;
     S \<notin> Target TS; A \<in> the (CompFun (HA ST) S);
     S \<in> Conf ST; S \<in> ChiStar (HA ST) `` (Source TS) \<rbrakk> \<Longrightarrow>
     InitState A \<in> StepConf (HA ST) (Conf ST) TS"
apply (frule Conf_HAStates2 [THEN CompFun_HAInitStates_HAStates])
apply fast
apply (subst (asm) StepConf_def)
apply safe
apply fast
apply (unfold StepConf_def)
apply (fast intro:HAInitStates_InitState_trancl)
apply (rename_tac T U V)
apply (frule trancl_Int_mem, fold ChiPlus_def, safe)
apply (subst (asm) Image_def, safe)
apply (rule_tac x=U in bexI)
apply (simp only: ChiPlus_HAStates_Right [THEN HAInitStates_InitState_trancl2])
apply fast
apply (subst (asm) Image_def, safe)
apply (rule_tac x=U in bexI)
apply (simp only: ChiPlus_HAStates_Right [THEN HAInitStates_InitState_trancl2])
apply fast
done

lemma SucState_Conf_StepConf:
  "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS;
     S \<notin> Target TS; A \<in> the (CompFun (HA ST) S);
     S \<in> Conf ST; States A \<inter> ChiStar (HA ST) `` (Source TS) = {} \<rbrakk> \<Longrightarrow>
     \<exists> x. x \<in> States A \<and> x \<in> StepConf (HA ST) (Conf ST) TS"
apply (unfold StepConf_def)
apply (cut_tac ST=ST in UniqueSucStates_Status)
apply (unfold UniqueSucStates_def)
apply (cut_tac ST=ST in Conf_HAStates2)
apply fast
apply (fold HAStates_def)
apply (erule_tac x=S in ballE)
apply (erule_tac x=A in ballE)
apply simp
apply fast+
done

lemma SucState_Conf_Source_StepConf:
  "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS;
     S \<notin> Target TS; A \<in> the (CompFun (HA ST) S);
     S \<in> Conf ST; States A \<inter> ChiStar (HA ST) `` (Source TS) \<noteq> {};
     S \<notin> ChiStar (HA ST) `` (Source TS)\<rbrakk> \<Longrightarrow>
     \<exists> x. x \<in> States A \<and> x \<in> StepConf (HA ST) (Conf ST) TS"
apply safe
apply (rename_tac T U)
apply (frule Conf_HAStates2 [THEN CompFun_ChiRel])
apply fast+
apply simp
apply (case_tac "U=T")
apply simp
apply (rotate_tac -5)
apply (simp only:Source_def Target_def image_def)
apply safe
apply (rename_tac Source Trigger Guard Action Update Target)
apply (erule_tac x=Target in allE)
apply simp
apply (frule HPT_source_target2)
apply fast+
apply (rule HAStates_CompFun_SAs_mem)
apply (rule Conf_HAStates2)
apply fast+
apply (frule ChiStar_ChiPlus_noteq)
apply fast
apply (case_tac "U=S")
apply (fast intro:ChiStar_Self ChiRel_ChiPlus_OneAncestor ChiPlus_ChiStar)+
done

lemma SucState_StepConf:
  "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS;
     A \<in> the (CompFun (HA ST) S) \<rbrakk> \<Longrightarrow>
     \<exists> x. x \<in> States A \<and> x \<in> StepConf (HA ST) (Conf ST) TS"
apply (case_tac "S \<in> Target TS")
apply (fast intro: InitSucState_Target_StepConf InitState_States)
apply (case_tac "S \<in> Conf ST")
prefer 2
apply (fast intro: InitSucState_StepConf InitState_States)
apply (case_tac "S \<in> ChiStar (HA ST) `` (Source TS)")
apply (fast intro: InitSucState_Conf_StepConf InitState_States)
apply (case_tac "States A \<inter> ChiStar (HA ST) `` (Source TS) = {}")
apply (fast intro: SucState_Conf_StepConf SucState_Conf_Source_StepConf)+
done

subsubsection \<open>\<open>StepStatus\<close>\<close>

lemma StepStatus_expand:
   "Abs_status (HA ST, StepConf (HA ST) (Conf ST) TS,
                StepActEvent TS, U !!! (Value ST))
    = (StepStatus ST TS U)"
apply (unfold StepStatus_def Let_def)
apply (subst Rep_status_tuple)
apply auto
done

lemma UniqueSucState_Conf_Source_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS; A \<in> SAs (HA ST);
      A \<in> the (CompFun (HA ST) S); T \<in> States A; U \<in> States A;
      T \<in> StepConf (HA ST) (Conf ST) TS; T \<noteq> U; U \<in> Conf ST \<rbrakk> \<Longrightarrow>
      U \<in> ChiStar (HA ST) `` Source TS"
apply (frule_tac ?S2.0=T in StepConf_HAStates [THEN subsetD, THEN CompFun_ChiRel])
apply fast+
apply (frule_tac ?S2.0=U in StepConf_HAStates [THEN subsetD, THEN CompFun_ChiRel])
apply fast+
apply (frule_tac S=S and T=U in Conf_ChiRel, fast)
apply (case_tac "S \<in> ChiStar (HA ST) `` Source TS")
apply (fast intro: ChiRel_ChiStar_trans)
apply (case_tac "U \<in> Source TS")
apply force
apply (unfold StepConf_def)
apply simp
apply safe
apply (fast intro: HPT_SAStates_Target_Source)+
apply (rename_tac V)
apply (case_tac "V=S")
apply (frule_tac S=S in HPT_Conf_Target_Source, fast+)
apply (fast intro: ChiStar_Image ChiRel_OneAncestor)+
apply (rename_tac V W)
apply (frule trancl_Int_mem, fold ChiPlus_def, safe)
apply (cut_tac ST=ST and S=S in HPT_Conf_Target_Source_ChiPlus)
apply fast+
apply (simp only:Image_def, safe)
apply (case_tac "(V, T) \<notin> ChiRel (HA ST)")
apply (frule_tac S=V and T=T in ChiPlus_ChiRel_Ex)
apply (fast, safe)
apply (rename_tac X)
apply (case_tac "X=S")
apply (rule_tac x=W in bexI)
prefer 4
apply (case_tac "V=S")
prefer 2
apply simp
apply (fast intro: ChiPlus_ChiRel ChiRel_ChiPlus_trans2 ChiRel_OneAncestor)+
done

lemma UniqueSucState_Target_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS; A \<in> SAs (HA ST);
      A \<in> the (CompFun (HA ST) S); T \<in> States A; U \<in> States A;
      T \<in> StepConf (HA ST) (Conf ST) TS; T \<noteq> U \<rbrakk> \<Longrightarrow>
      U \<notin> Target TS"
apply auto
apply (frule_tac ST=ST in Target_StepConf)
apply (subst (asm) (2) StepConf_def)
apply simp
apply safe
apply (cut_tac TS=TS and ST=ST and S=S and T=U in UniqueSucState_Conf_Source_StepConf)
apply fast+
apply (simp add: OneState_HPT_Target)
apply (simp only:OneState_HPT_Target_ChiRel)
apply (rename_tac V W)
apply (frule_tac U=W and S=V and T=T in ChiRel_ChiPlus_trans2)
apply (frule trancl_Int_mem, fold ChiPlus_def, force)
apply (simp only:OneState_HPT_Target_ChiPlus)
done

lemma UniqueSucState_Target_ChiRel_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS; A \<in> SAs (HA ST);
      A \<in> the (CompFun (HA ST) S); T \<in> States A; U \<in> States A;
      T \<in> StepConf (HA ST) (Conf ST) TS; T \<noteq> U; (V,U) \<in> ChiRel (HA ST);
      U \<in> HAInitStates (HA ST) \<rbrakk>
    \<Longrightarrow> V \<notin> Target TS"
apply auto
apply (frule_tac A="HA ST" and C="Conf ST" in Target_ChiRel_HAInit_StepConf)
apply fast+
apply (subst (asm) (2) StepConf_def, safe)
apply (fast intro:UniqueSucState_Conf_Source_StepConf)
apply (simp only:OneState_HPT_Target_ChiRel)
apply (fast intro:OneHAInitState_SAStates)
apply (frule trancl_Int_mem, fold ChiPlus_def)
apply (fast intro:OneHAInitState_SAStates)
done

lemma UniqueSucState_Target_ChiPlus_StepConf [rule_format]:
  "\<lbrakk> TS \<in> HPT ST; (S,T) \<in> ChiRel (HA ST); (S,U) \<in> ChiRel (HA ST);
     V \<in> Target TS; (V,W) \<in> ChiRel (HA ST); T \<notin> ChiStar (HA ST) `` Source TS;
     (W,U) \<in> (ChiRel (HA ST) \<inter> HAInitStates (HA ST) \<times> HAInitStates (HA ST))\<^sup>+;
     T \<in> Conf ST \<rbrakk> \<Longrightarrow> (S,U) \<in> ChiRel (HA ST) \<longrightarrow> T=U"
apply (frule_tac S=S and T=T in Conf_ChiRel)
apply fast
apply (rule_tac a="W" and b="U" and r="ChiRel (HA ST) \<inter> HAInitStates (HA ST) \<times> HAInitStates (HA ST)" in trancl_induct)
apply safe
apply (rename_tac X)
apply (case_tac "W=S")
apply simp
prefer 2
apply (simp add: ChiRel_OneAncestor)
prefer 2
apply (rename_tac X Y)
apply (case_tac "X=S")
apply simp
prefer 2
apply (simp add: ChiRel_OneAncestor)
prefer 2
apply (frule_tac a=V in ChiRel_HAStates)
apply (unfold HAStates_def)
apply (simp,safe)
apply (rename_tac Y)
apply (case_tac "States Y \<inter> Source TS = {}")
apply (simp add:OneState_HPT_Target_Source)
apply (subst (asm) Int_def, safe)
apply (rename_tac Z)
apply (frule_tac S=V and T=S in Conf_ChiRel)
apply fast
apply (frule HPT_Conf_Target_Source)
prefer 2
apply fast
apply fast
apply (frule_tac S=Z and T=V in  OneState_HPT_SA)
apply fast+
apply simp
apply (fast intro: ChiPlus_ChiRel ChiRel_ChiPlus_trans ChiPlus_ChiStar)
apply (simp add: Image_def)
apply (frule trancl_Int_mem, fold ChiPlus_def, simp, safe)
back
apply (frule_tac T=W and S=S in Conf_ChiPlus)
apply simp
apply (frule_tac S=V and T=W in Conf_ChiRel)
apply fast
apply (frule_tac a=V in ChiRel_HAStates)
apply (unfold HAStates_def)
apply (simp, safe)
apply (rename_tac Z)
apply (case_tac "States Z \<inter> Source TS = {}")
apply (simp add:OneState_HPT_Target_Source)
apply (subst (asm) Int_def, safe)
apply (frule_tac S=V in HPT_Conf_Target_Source)
apply fast+
apply (rename_tac P)
apply (frule_tac S=P and T=V in  OneState_HPT_SA)
apply fast+
apply (frule_tac U=V and S=W and T=S in ChiRel_ChiPlus_trans2)
apply fast+
apply (fast intro: ChiPlus_ChiRel ChiRel_ChiPlus_trans ChiPlus_ChiStar)
apply (case_tac "T=S")
apply (simp add: ChiRel_OneAncestor)+
done

lemma UniqueSucStates_SAStates_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> StepConf (HA ST) (Conf ST) TS; A \<in> SAs (HA ST);
      A \<in> the (CompFun (HA ST) S); T \<in> States A; U \<in> States A;
      T \<in> StepConf (HA ST) (Conf ST) TS; T \<noteq> U \<rbrakk> \<Longrightarrow>
      U \<notin> StepConf (HA ST) (Conf ST) TS"
apply (subst StepConf_def)
apply (simp, safe)
apply (rule UniqueSucState_Conf_Source_StepConf)
apply fast+
apply (frule_tac U=U in UniqueSucState_Target_StepConf)
apply fast+
apply (frule_tac U=U in UniqueSucState_Target_ChiRel_StepConf)
apply fast+
apply (rename_tac V W)
apply (frule trancl_Int_mem, fold ChiPlus_def)
apply (simp, safe)
apply (frule_tac ?S2.0=T in StepConf_HAStates [THEN subsetD, THEN CompFun_ChiRel])
apply fast+
apply (frule_tac ?S2.0=U in StepConf_HAStates [THEN subsetD, THEN CompFun_ChiRel])
apply fast+
apply (subst (asm) (2) StepConf_def)
apply (simp, safe)
apply (fast intro: UniqueSucState_Target_ChiPlus_StepConf)
apply (frule_tac U=W and T=U and S=T in OneState_HPT_Target_ChiPlus)
apply (fast intro: ChiPlus_ChiRel ChiRel_ChiPlus_trans2 OneHAInitState_SAStates)+
apply (frule trancl_Int_mem, fold ChiPlus_def, simp, safe)
apply (fast intro:OneHAInitState_SAStates)
done

lemma UniqueSucStates_Ancestor_StepConf:
   "\<lbrakk> TS \<in> HPT ST; S \<in> HAStates (HA ST); SA \<in> the (CompFun (HA ST) S);
      T \<in> States SA; T \<in> StepConf (HA ST) (Conf ST) TS \<rbrakk>
    \<Longrightarrow> S \<in> StepConf (HA ST) (Conf ST) TS"
apply (rule notnotD, rule notI)
apply (subst (asm) StepConf_def)
apply (simp, safe)
apply (frule  CompFun_ChiRel, fast+)
apply (frule Conf_ChiRel, fast)
apply (frule ChiRel_ChiStar_Source_notmem, fast+)
apply (subst (asm) StepConf_def)
apply force
apply (case_tac "States SA \<inter> Source TS = {}")
apply (simp add:OneState_HPT_Target_Source)
apply (subst (asm) Int_def)
apply (simp, safe)
apply (rename_tac U)
apply (frule_tac ?S2.0=U in CompFun_ChiRel, fast+)
apply (frule Conf_ChiRel)
apply (frule HPT_Source_Conf, fast)
apply (case_tac "S \<in> ChiStar (HA ST) `` Source TS")
apply (subst (asm) StepConf_def)
apply simp
apply (frule ChiRel_ChiStar_notmem)
apply fast+
apply (case_tac "U=S")
apply (subst (asm) StepConf_def)
apply force
apply (subst (asm) StepConf_def)
apply force
apply (rename_tac U)
apply (case_tac "U=S")
apply (subst (asm) StepConf_def)
apply force
apply (frule  CompFun_ChiRel, fast+)
apply (simp add: ChiRel_OneAncestor)
apply (rename_tac U V)
apply (frule trancl_Int_mem, fold ChiPlus_def, simp, safe)
apply (frule tranclD2)
apply safe
apply (rename_tac W)
apply (case_tac "W=S")
apply simp
prefer 2
apply (frule CompFun_ChiRel, fast+)
apply (simp only: ChiRel_OneAncestor)
apply (subst (asm) StepConf_def)
apply safe
apply (simp add: Image_def)
apply (erule_tac x=U in ballE)
apply (case_tac "U=S")
apply fast
apply (simp add: rtrancl_eq_or_trancl)
apply fast
apply (simp add: Image_def)
apply (rename_tac W)
apply (erule_tac x=U in ballE)
apply (simp add: rtrancl_eq_or_trancl)
apply fast+
done

lemma UniqueSucStates_StepConf:
   "\<lbrakk> TS \<in> HPT ST \<rbrakk> \<Longrightarrow>
      UniqueSucStates (SAs (HA ST)) (CompFun (HA ST)) (StepConf (HA ST) (Conf ST) TS)"
apply (unfold UniqueSucStates_def)
apply auto
apply (simp only: SucState_StepConf)
apply (rule notnotD, rule notI)
apply (frule UniqueSucStates_SAStates_StepConf)
apply fast
prefer 2
apply fast
apply (rule HAStates_CompFun_SAs_mem)
prefer 2
apply fast
apply (simp only: HAStates_def, fast)
apply fast+
back
apply (frule UniqueSucStates_Ancestor_StepConf)
prefer 2
apply fast
apply (simp only:HAStates_def, fast)
apply fast+
done

lemma Status_Step:
  "\<lbrakk> TS \<in> HPT ST; U \<in> ResolveRacing TS \<rbrakk> \<Longrightarrow>
    (HA ST, StepConf (HA ST) (Conf ST) TS, StepActEvent TS, U !!! (Value ST)) \<in> status"
apply (unfold status_def Status_def)
apply auto
apply (frule StepActEvent_HAEvents)
apply blast
apply (unfold IsConfSet_def)
apply (rule conjI, frule StepConf_HAStates, unfold HAStates_def,assumption)
apply (rule conjI, rule RootExSem_StepConf, assumption)
apply (rule UniqueSucStates_StepConf, assumption)
done

subsection \<open>Meta Theorem: Preservation for Statecharts\<close>

(* We prove, that the well-formedness of a Statecharts is preserved by the semantics
   (theorem "IsConfSet_StepConf") *)

lemma IsConfSet_StepConf:
       "TS \<in> HPT ST \<Longrightarrow> IsConfSet (SAs (HA ST)) (CompFun (HA ST))
                                  (StepConf (HA ST) (Conf ST) TS)"
apply (unfold IsConfSet_def)
apply auto
apply (frule StepConf_HAStates)
apply (unfold HAStates_def, fast)
apply (rule RootExSem_StepConf, assumption)
apply (rule UniqueSucStates_StepConf, assumption)
done

lemma HA_StepStatus_HPT_ResolveRacing [simp]:
  "\<lbrakk> TS \<in> HPT ST; U \<in> ResolveRacing TS \<rbrakk> \<Longrightarrow>
    HA (StepStatus ST TS U) = HA ST"
apply (subst StepStatus_expand [THEN sym])
apply (subst HA_def)
apply auto
apply (subst Abs_status_inverse)
apply auto
apply (rule Status_Step)
apply auto
done

end