theory RRLoopFour
(* Fourth instance of the RRLoop: here, we now introduce the ledger type
   and integrate it into a redefined infrastructure type. This should
   avoid the put attack but doesn't in the end since an insider could still
   overwrite the entry made by Bob. *)
imports hcKripkeThree
begin
type_synonym data = string
  (* Inspired by Myers DLM mode: first is the owner of a data item, second is the
     set of all actors that may access the data item *)
(* Here in this iteration of the RR-Loop the dlm needs to be refined replacing
   actors by identities since otherwise the uniqueness of the label imposed
   in the ledger typedef cannot be proved for actors (note that we intentionally
   didn't stipulate Actor to be injective to allow for insider attacks)
before:
type_synonym dlm = "actor * actor set"
now: *)
type_synonym dlm = "identity * identity set"

type_synonym acond = "(dlm * data) set"

typedef ledger = "{ ld :: dlm \<times> data \<Rightarrow> location set. \<forall> d. (\<forall> l. ld (l, d) = {}) \<or>
(\<exists>! l. ld (l, d) \<noteq> {})}"
  by auto
(*
typedef ledger = "{ ld :: dlm \<times> data \<Rightarrow> location set. \<forall> d. (\<forall> l. ld (l, d) = {}) \<or>
(\<exists>! dl. ld dl \<noteq> {})}"
  by auto
*)

datatype igraph = Lgraph "(location * location)set" "location \<Rightarrow> identity set"
                         "actor \<Rightarrow> (string set * string set)"  "location \<Rightarrow> string"
                         "ledger"
datatype infrastructure =
         Infrastructure "igraph"
                        "[igraph ,location] \<Rightarrow> policy set"
primrec loc :: "location \<Rightarrow> nat"
where  "loc(Location n) = n"
primrec gra :: "igraph \<Rightarrow> (location * location)set"
where  "gra(Lgraph g a c l ld) = g"
primrec agra :: "igraph \<Rightarrow> (location \<Rightarrow> identity set)"
where  "agra(Lgraph g a c l ld) = a"
primrec cgra :: "igraph \<Rightarrow> (actor \<Rightarrow> string set * string set)"
where  "cgra(Lgraph g a c l ld) = c"
primrec lgra :: "igraph \<Rightarrow> (location \<Rightarrow> string)"
  where  "lgra(Lgraph g a c l ld) = l"
primrec ledgra :: "igraph \<Rightarrow> ledger"
  where  "ledgra(Lgraph g a c l ld) = ld"

definition ledgra_upd :: "[ledger, dlm \<times> data, location set] \<Rightarrow> ledger" ("_ _ := _" 50)
  where
 "ledgra_upd ld dl L == Abs_ledger((Rep_ledger ld)(dl := L))"

definition ledgra_at :: "[ledger, dlm \<times> data] \<Rightarrow> location set" ("_ \<nabla> _" 50)
  where  "l \<nabla> dl \<equiv> (Rep_ledger l) dl"

lemma ledgra_at_fun: "(\<forall> d. (\<forall> l. (f :: dlm \<times> data \<Rightarrow> location set)(l, d) = {}) \<or>
(\<exists>! l. f (l, d) \<noteq> {})) \<Longrightarrow> (Rep_ledger (Abs_ledger f)) dl = f dl"
  by (simp add: Abs_ledger_inverse)

definition nodes :: "igraph \<Rightarrow> location set"
where "nodes g == { x. (? y. ((x,y): gra g) | ((y,x): gra g))}"

definition actors_graph :: "igraph \<Rightarrow> identity set"
where  "actors_graph g == {x. ? y. y : nodes g \<and> x \<in> (agra g y)}"

primrec graphI :: "infrastructure \<Rightarrow> igraph"
where "graphI (Infrastructure g d) = g"
primrec delta :: "[infrastructure, igraph, location] \<Rightarrow> policy set"
where "delta (Infrastructure g d) = d"
primrec tspace :: "[infrastructure, actor ] \<Rightarrow> string set * string set"
  where "tspace (Infrastructure g d) = cgra g"
primrec lspace :: "[infrastructure, location ] \<Rightarrow> string"
where "lspace (Infrastructure g d) = lgra g"
definition credentials :: "string set * string set \<Rightarrow> string set"
  where  "credentials lxl \<equiv> (fst lxl)"
definition has :: "[igraph, actor * string] \<Rightarrow> bool"
  where "has G ac \<equiv> snd ac \<in> credentials(cgra G (fst ac))"
definition roles :: "string set * string set \<Rightarrow> string set"
  where  "roles lxl \<equiv> (snd lxl)"
definition role :: "[igraph, actor * string] \<Rightarrow> bool"
  where "role G ac \<equiv> snd ac \<in> roles(cgra G (fst ac))"

definition isin :: "[igraph,location, string] \<Rightarrow> bool"
  where "isin G l s \<equiv> s = (lgra G l)"

(* types need to change because of new dlm labels *)
definition owner :: "dlm * data \<Rightarrow> identity" where "owner d \<equiv> fst(fst d)"

definition owns :: "[igraph, location, identity, dlm * data] \<Rightarrow> bool"
  where "owns G l a d \<equiv> owner d = a"

definition readers :: "dlm * data \<Rightarrow> identity set"
  where "readers d \<equiv> snd (fst d)"

definition has_access :: "[igraph, location, identity, dlm * data] \<Rightarrow> bool"
where "has_access G l a d \<equiv> owns G l a d \<or> a \<in> readers d"

definition atI :: "[identity, igraph, location] \<Rightarrow> bool" ("_ @\<^bsub>(_)\<^esub> _" 50)
where "a @\<^bsub>G\<^esub> l \<equiv> a \<in> (agra G l)"

definition enables :: "[infrastructure, location, actor, action] \<Rightarrow> bool"
where
"enables I l a a' \<equiv>  (\<exists> (p,e) \<in> delta I (graphI I) l. a' \<in> e \<and> p a)"

definition move_graph_a :: "[identity, location, location, igraph] \<Rightarrow> igraph"
where "move_graph_a n l l' g \<equiv> Lgraph (gra g)
                    (if n \<in> ((agra g) l) &  n \<notin> ((agra g) l') then
                     ((agra g)(l := (agra g l) - {n}))(l' := (insert n (agra g l')))
                     else (agra g))(cgra g)(lgra g)(ledgra g)"

(* type of functions that preserves the security labeling *)
typedef label_fun = "{f :: dlm * data \<Rightarrow> dlm * data.
                        \<forall> x:: dlm * data. fst x = fst (f x)}"
proof (auto)
  show "\<exists>x::(identity \<times> identity set) \<times> string \<Rightarrow> (identity \<times> identity set) \<times> string.
       \<forall>(a::identity) (b::identity set) ba::string. (a, b) = fst (x ((a, b), ba))"
  by (rule_tac x = id in exI, simp)
qed

definition secure_process :: "label_fun \<Rightarrow> dlm * data \<Rightarrow> dlm * data" ("_ \<Updown> _" 50)
  where "f  \<Updown> d \<equiv> (Rep_label_fun f) d"

lemma move_graph_eq: "move_graph_a a l l g = g"
proof (simp add: move_graph_a_def, case_tac g, force)
qed

inductive state_transition_in :: "[infrastructure, infrastructure] \<Rightarrow> bool" ("(_ \<rightarrow>\<^sub>n _)" 50)
where
  move: "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; l \<in> nodes G; l' \<in> nodes G;
          (a) \<in> actors_graph(graphI I); enables I l' (Actor a) move;
         I' = Infrastructure (move_graph_a a l l' (graphI I))(delta I) \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| get_data : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow> l \<in> nodes G \<Longrightarrow> l' \<in> nodes G \<Longrightarrow>
        enables I l (Actor a) get \<Longrightarrow>
        (ledgra G \<nabla> ((a', as), n)) = L \<Longrightarrow> l' \<in> L  \<Longrightarrow> a \<in> as \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)(lgra G)
                           ((ledgra G)((a', as), n) := (L \<union> {l})))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| process : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow>
        enables I l (Actor a) eval \<Longrightarrow>
        (ledgra G \<nabla> ((a', as), n)) = L \<Longrightarrow>
        a \<in> as \<or> a = a'\<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)(lgra G)
                                 ((ledgra G ((a', as), n) := {}
                                    (f :: label_fun) \<Updown> ((a', as), n) := L)))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| del_data : "G = graphI I \<Longrightarrow> a \<in> actors_graph G \<Longrightarrow> l \<in> nodes G \<Longrightarrow> l \<in> L \<Longrightarrow>
             (ledgra G \<nabla> ((a, as), n)) = L \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)(lgra G)
                    (ledgra G ((a, as),n) := L - {l}))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| put : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow> enables I l (Actor a) put \<Longrightarrow>
        I' = Infrastructure
                  (Lgraph (gra G)(agra G)(cgra G)(lgra G)
                          (ledgra G ((a, as),n) := {l}))
                   (delta I)
          \<Longrightarrow> I \<rightarrow>\<^sub>n I'"

instantiation "infrastructure" :: state
begin

definition
   state_transition_infra_def: "(i \<rightarrow>\<^sub>i i') =  (i \<rightarrow>\<^sub>n (i' :: infrastructure))"

instance
  by (rule MC.class.MC.state.of_class.intro)

definition state_transition_in_refl ("(_ \<rightarrow>\<^sub>n* _)" 50)
where "s \<rightarrow>\<^sub>n* s' \<equiv> ((s,s') \<in> {(x,y). state_transition_in x y}\<^sup>*)"

end

thm Finite_Set.fold_def

definition dlm_to_dlm:: "RRLoopFour.dlm \<Rightarrow> RRLoopThree.dlm"
  where
  "dlm_to_dlm  \<equiv> (\<lambda> ((s :: string), (sl :: string set)). (Actor s, Actor ` sl))"

definition data_trans :: "RRLoopFour.dlm \<times> data \<Rightarrow> RRLoopThree.dlm \<times> data"
  where "data_trans  \<equiv> (\<lambda> (l :: (string *  string set),d :: string). (dlm_to_dlm l, d))"

definition ledger_to_loc:: "[ledger, location] \<Rightarrow> RRLoopThree.acond" (* acond is abbrev for (dlm \<times> data) set *)
  where
   "ledger_to_loc ld l \<equiv> if l \<in> \<Union> (range(Rep_ledger ld))
                          then fmap data_trans {dl. l \<in> (ld \<nabla> dl)} else {}"

lemma ledger_to_loc_data_unique: "Rep_ledger ld (dl,d) \<noteq> {} \<Longrightarrow>
                                  Rep_ledger ld (dl',d) \<noteq> {} \<Longrightarrow> dl = dl'"
  apply (subgoal_tac "Rep_ledger (ld)
    \<in> {ld::(char list \<times> char list set) \<times> char list \<Rightarrow> location set.
        \<forall>d::char list.
           (\<forall>l::char list \<times> char list set. ld (l, d) = {}) \<or>
           (\<exists>! l:: (char list \<times> char list set). ld (l,d) \<noteq> {})}")
   apply simp
   apply (drule_tac x = d in spec)
   apply (erule disjE)
    apply (drule_tac x = "fst dl" in spec)
    apply (drule_tac x = "snd dl" in spec)
    apply simp
   apply (erule ex1E)
  apply (frule_tac x = dl in spec)
   apply (drule mp, assumption)
  apply (frule_tac x = dl' in spec)
   apply (drule mp, assumption)
   apply (erule ssubst)+
  apply (rule refl)
by (rule Rep_ledger)

lemma ledger_to_loc_data_unique0: "Rep_ledger ld dld \<noteq> {} \<Longrightarrow>
                                  \<forall> dld'. Rep_ledger ld dld' \<noteq> {} \<Longrightarrow> fst dld = fst dld'"
  apply (simp add: ledger_to_loc_data_unique)
  oops

lemma ledgra_ledger_to_loc:
      "finite {dl::(char list \<times> char list set) \<times> char list. l \<in> Rep_ledger (ledgra G) dl} \<Longrightarrow>
       l \<in> (ledgra G \<nabla> ((a, as), n)) \<Longrightarrow>
        ((Actor a, Actor ` as), n) \<in> ledger_to_loc (ledgra G) l"
  apply (simp add: ledgra_at_def ledger_to_loc_def)
  apply (rule conjI)
   apply (rule impI)
   apply (subgoal_tac "((Actor a, Actor ` as), n) = data_trans ((a, as), n)")
  apply (erule ssubst)
    apply (rule fmap_lem_map, assumption)
    apply (simp add: Rep_ledger)
  apply (simp add: data_trans_def dlm_to_dlm_def)
  apply (rule exI)+
  by assumption

(*  lemma for ledgra_upd *)
lemma ledgra_update_lem: "(L = {} \<or> (Rep_ledger lg x \<noteq> {})) \<Longrightarrow>
                          Rep_ledger (Abs_ledger ((Rep_ledger lg)(x := L))) =
                            ((Rep_ledger lg)(x := L))"
  apply (subgoal_tac "((Rep_ledger lg)(x := L)) \<in> {ld::(char list \<times> char list set) \<times> char list \<Rightarrow> location set.
      \<forall>d::char list.
         (\<forall>l::char list \<times> char list set. ld (l, d) = {}) \<or>
         (\<exists>!l::char list \<times> char list set. ld (l, d) \<noteq> {})}")
   apply (erule Abs_ledger_inverse)
  apply simp
  apply (erule disjE)
(* L = {} *)
   apply simp
  apply (subgoal_tac "Rep_ledger lg \<in> {ld::(char list \<times> char list set) \<times> char list \<Rightarrow> location set.
      \<forall>d::char list.
         (\<forall>l::char list \<times> char list set. ld (l, d) = {}) \<or>
         (\<exists>!l::char list \<times> char list set. ld (l, d) \<noteq> {})}")
    apply simp
  apply blast
   apply (rule Rep_ledger)
(* *)
  apply (case_tac "L = {}")
   apply simp
  apply (subgoal_tac "Rep_ledger lg \<in> {ld::(char list \<times> char list set) \<times> char list \<Rightarrow> location set.
      \<forall>d::char list.
         (\<forall>l::char list \<times> char list set. ld (l, d) = {}) \<or>
         (\<exists>!l::char list \<times> char list set. ld (l, d) \<noteq> {})}")
    apply simp
  apply blast
   apply (rule Rep_ledger)
(* L \<noteq> {} *)
  apply (rule allI)
  apply (case_tac "snd x = d")
  apply (rule disjI2)
   apply simp
   apply (rule_tac a = "fst x" in ex1I)
    apply (rule impI)
    apply (erule subst)
  apply simp
    apply (subgoal_tac "Rep_ledger lg \<in> {ld::(char list \<times> char list set) \<times> char list \<Rightarrow> location set.
      \<forall>d::char list.
         (\<forall>l::char list \<times> char list set. ld (l, d) = {}) \<or>
         (\<exists>!l::char list \<times> char list set. ld (l, d) \<noteq> {})}")
  apply simp
   apply (drule_tac x = d in spec)
   apply (erule disjE)
     apply (drule_tac x = "fst(fst x)" in spec)
     apply (drule_tac x = "snd(fst x)" in spec)
     apply (erule notE)
     apply force
    apply (erule ex1E)
    apply (case_tac "(xa, d) = x")
     apply simp
  apply (rotate_tac -1)
     apply (erule subst)
  apply simp
    apply (drule mp, assumption)
    apply (frule_tac x = "fst x" in spec)
    apply (drule mp)
  apply (erule subst)
     apply simp
    apply (drule_tac x = xa in spec)
    apply (drule mp, assumption)
    apply simp
   apply (rule Rep_ledger)
(* snd x \<noteq> d *)
  apply simp
  apply (subgoal_tac "Rep_ledger lg \<in> {ld::(char list \<times> char list set) \<times> char list \<Rightarrow> location set.
      \<forall>d::char list.
         (\<forall>l::char list \<times> char list set. ld (l, d) = {}) \<or>
         (\<exists>!l::char list \<times> char list set. ld (l, d) \<noteq> {})}")
  apply simp
   apply (drule_tac x = d in spec)
   apply (erule disjE)
    apply (rule disjI1)
    apply blast
   apply (rule disjI2)
   apply blast
by (rule Rep_ledger)

lemma ledgra_insert0: "(Rep_ledger lg)((a, as), n) = L \<Longrightarrow> l \<noteq> la \<Longrightarrow> l' \<in> L \<Longrightarrow>
         {dl::(char list \<times> char list set) \<times> char list.
           l \<in> Rep_ledger (lg ((a, as), n) := insert la L) dl} =
         {dl::(char list \<times> char list set) \<times> char list.
           l \<in> Rep_ledger lg dl}"
  apply (simp add: ledgra_upd_def)
  apply (subgoal_tac "insert la L = {} \<or> (Rep_ledger lg)((a, as), n) \<noteq> {}")
  prefer 2
   apply blast
  apply (drule ledgra_update_lem)
  apply (rotate_tac -1)
  apply (erule ssubst)
by force

lemma ledgra_insert: "(Rep_ledger lg)((a, as), n) = L \<Longrightarrow> l' \<in> L \<Longrightarrow>
        {dl::(char list \<times> char list set) \<times> char list.
         l \<in> Rep_ledger (lg ((a, as), n) := insert l L) dl} =
          insert ((a, as), n) {dl::(char list \<times> char list set) \<times> char list.
         l \<in> Rep_ledger lg dl}"
  apply (simp add: ledgra_upd_def)
  apply (subgoal_tac "insert l L = {} \<or> (Rep_ledger lg)((a, as), n) \<noteq> {}")
  prefer 2
   apply blast
  apply (drule ledgra_update_lem)
  apply (rotate_tac -1)
  apply (erule ssubst)
  by force

lemma ledger_to_loc_insert:
  assumes a: "\<forall> l. finite {dl::(char list \<times> char list set) \<times> char list. l \<in> Rep_ledger lg dl}"
  shows "(lg \<nabla> ((a, as), n)) = L \<Longrightarrow> l' \<in> L \<Longrightarrow>
           ledger_to_loc ((lg ((a, as), n) := insert l L)) =
          (ledger_to_loc lg)(l := insert ((Actor a, Actor ` as), n) (ledger_to_loc lg l))"
 proof (unfold ledger_to_loc_def, rule ext, case_tac "l = la")
  show \<open>\<And>la::location.
       (lg \<nabla> ((a, as), n)) = L \<Longrightarrow>
       l' \<in> L \<Longrightarrow>
       l = la \<Longrightarrow>
       (if la \<in> \<Union> (range (Rep_ledger (lg ((a, as), n) := insert l L)))
        then fmap data_trans {dl::(char list \<times> char list set) \<times> char list. la \<in> (lg ((a, as), n) := insert l L \<nabla> dl)}
        else {}) =
       ((\<lambda>l::location.
            if l \<in> \<Union> (range (Rep_ledger lg))
            then fmap data_trans {dl::(char list \<times> char list set) \<times> char list. l \<in> (lg \<nabla> dl)} else {})
        (l := insert ((Actor a, Actor ` as), n)
               (if l \<in> \<Union> (range (Rep_ledger lg))
                then fmap data_trans {dl::(char list \<times> char list set) \<times> char list. l \<in> (lg \<nabla> dl)} else {})))
        la\<close>
   apply simp
  apply (rule conjI)
   apply (rule impI)+
  apply (simp add: ledgra_at_def)
   apply (rule conjI)
     apply (rule impI)+
     apply (subst ledgra_insert, assumption, assumption)
     apply (subst fmap_lem)
  prefer 2
       apply (simp add: data_trans_def dlm_to_dlm_def)
      apply (insert a)
      apply (erule spec)
     apply (simp add: ledgra_upd_def)
     apply (subst ledgra_update_lem)
      apply blast
     apply force
    apply (rule impI)+
(*  *)
    apply (rule conjI)
     apply (rule impI)
     apply (subgoal_tac
          "{dl::(char list \<times> char list set) \<times> char list. la \<in> (lg ((a, as), n) := insert la L \<nabla> dl)} =
           {((a,as),n)}")
      apply (rotate_tac -1, erule ssubst)
    apply (subst fmap_lem_one)
      apply (simp add: data_trans_def dlm_to_dlm_def)
     apply (simp add: ledgra_at_def ledgra_upd_def)
     apply (subst ledgra_update_lem)
      apply blast
     apply force
     apply (simp add: ledgra_upd_def)
     apply (subst ledgra_update_lem)
     apply (simp add: ledgra_at_def, blast)
by force
next show "\<And>la::location.
       (lg \<nabla> ((a, as), n)) = L \<Longrightarrow>
       l' \<in> L \<Longrightarrow>
       l \<noteq> la \<Longrightarrow>
       (if la \<in> \<Union> (range (Rep_ledger (lg ((a, as), n) := insert l L)))
        then fmap data_trans {dl::(char list \<times> char list set) \<times> char list. la \<in> (lg ((a, as), n) := insert l L \<nabla> dl)}
        else {}) =
       ((\<lambda>l::location.
            if l \<in> \<Union> (range (Rep_ledger lg))
            then fmap data_trans {dl::(char list \<times> char list set) \<times> char list. l \<in> (lg \<nabla> dl)} else {})
        (l := insert ((Actor a, Actor ` as), n)
               (if l \<in> \<Union> (range (Rep_ledger lg))
                then fmap data_trans {dl::(char list \<times> char list set) \<times> char list. l \<in> (lg \<nabla> dl)} else {})))
        la"
   apply simp
  apply (rule conjI)
   apply (rule impI)+
  apply (simp add: ledgra_at_def)
   apply (rule conjI)
     apply (rule impI)+
      apply (subst ledgra_insert0, assumption, simp, assumption, rule refl)
     apply (simp add: ledgra_upd_def)
          apply (subst ledgra_update_lem)
      apply blast
     apply (rule impI)
    apply (subgoal_tac "{dl::(char list \<times> char list set) \<times> char list.
         la \<in> ((Rep_ledger lg)(((a, as), n) := insert l L)) dl} = {}")
    apply (rotate_tac -1, erule ssubst)
     apply (simp add: fmap_def)
     apply force
    apply (rule impI)+
    apply (rule FalseE)
    apply (erule exE)+
    apply (drule_tac x = aa in spec)
    apply (drule_tac x = b in spec)
    apply (drule_tac x = ba in spec)
    apply (rotate_tac -1, erule notE)
    apply (simp add: ledgra_upd_def)
    apply (subst ledgra_update_lem)
     apply (simp add: ledgra_at_def)
     apply blast
    apply (erule subst)
    apply (simp add: ledgra_at_def)
by force
qed

lemma update_empty_lem0: "xa \<in> (f(x := {})) y \<Longrightarrow> xa \<in> f y"
  by (simp, case_tac "x = y", simp+)

lemma ledger_del0: "Rep_ledger (lg x := {}) y \<subseteq> Rep_ledger lg y"
proof (rule subsetI, simp add: ledgra_upd_def)
  fix xa
  show "xa \<in> Rep_ledger (Abs_ledger ((Rep_ledger lg)(x := {}))) y \<Longrightarrow> xa \<in> Rep_ledger lg y"
  proof -
    assume a0:  "xa \<in> Rep_ledger (Abs_ledger ((Rep_ledger lg)(x := {}))) y"
    from a0 ledgra_update_lem have a1: "xa \<in> ((Rep_ledger lg)(x := {})) y" by simp
    with a0 show "xa \<in> Rep_ledger (Abs_ledger ((Rep_ledger lg)(x := {}))) y \<Longrightarrow>
               xa \<in> Rep_ledger lg y"
      apply (rule_tac f = "\<lambda> y. Rep_ledger lg y" and x = x in update_empty_lem0)
      by assumption
  qed
qed

lemma inset_n_empty: "x \<in> s \<Longrightarrow> s \<noteq> {}"
  by force

lemma inj_data_trans: "inj Actor \<Longrightarrow> inj data_trans"
  apply (rule injI)
  apply (simp add: data_trans_def dlm_to_dlm_def)
  apply (case_tac x)
  apply (case_tac y)
  apply simp
  apply (case_tac aa)
  apply (case_tac a)
  apply simp
  apply (rule conjI)
  apply (erule conjE)+
   apply (erule injD, assumption)
  apply (erule image_inj)
  by simp

lemma setsub_spec: "A - {x. P x} = A - {x. x \<in> A \<and> P x}"
  by blast

lemma b32a0: "l \<noteq> x \<Longrightarrow> x \<notin> Rep_ledger lg xa \<Longrightarrow>
               x \<notin> ((Rep_ledger lg)(((a, as), n) := Rep_ledger lg ((a, as), n) - {l})) xa"
  apply simp
  apply (rule impI)
  apply (erule subst)
  by assumption

lemma inj_inj_on: "inj f \<Longrightarrow> inj_on f A"
  by (simp add: inj_def inj_onI)

lemma ledger_to_loc_delete:
  assumes a: "\<forall> l. finite {dl::(char list \<times> char list set) \<times> char list. l \<in> Rep_ledger lg dl}"
      and b: "inj Actor"
  shows "(lg \<nabla> ((a, as), n)) = L \<Longrightarrow> l \<in> L \<Longrightarrow>
      ledger_to_loc (lg ((a, as), n) := L - {l}) =
       (ledger_to_loc lg)(l := ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list). x = n})"
proof -
  assume a0: "(lg \<nabla> ((a, as), n)) = L" and a1: "l \<in> L"
  have a1a: "l \<in> Rep_ledger lg ((a, as), n)"
    by (insert a0 a1, unfold ledgra_at_def, erule ssubst)
  have a1b: "ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list). x = n} =
             ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list).
                      (y, x) \<in> ledger_to_loc lg l \<and> x = n}" by blast
  show "(lg \<nabla> ((a, as), n)) = L \<Longrightarrow> l \<in> L \<Longrightarrow> ledger_to_loc (lg ((a, as), n) := L - {l}) =
       (ledger_to_loc lg)(l := ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list). x = n})"
  proof(rule ext, case_tac "\<forall> dl. dl \<noteq> ((a,as),n) \<longrightarrow> x \<notin> Rep_ledger lg dl")
    fix x
    assume A: "\<forall>dl::(char list \<times> char list set) \<times> char list. dl \<noteq> ((a, as), n) \<longrightarrow> x \<notin> Rep_ledger lg dl"
    show "ledger_to_loc (lg ((a, as), n) := L - {l}) x =
       ((ledger_to_loc lg)(l := ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list). x = n})) x"
    proof (case_tac "l = x", simp)
      assume lex: "l = x"
      show "ledger_to_loc (lg ((a, as), n) := L - {x}) x =
            ledger_to_loc lg x - {(y::actor \<times> actor set, x::char list). x = n}"
      proof -
        have b00: "(\<forall> b::(char list \<times> char list set) \<times> char list.
             x \<notin> ((Rep_ledger lg)(((a, as), n) := Rep_ledger lg ((a, as), n) - {x})) b)"
          by (rule allI, case_tac "b = ((a,as),n)", simp, simp add: A)
        have b0: "x \<notin> \<Union> (range(Rep_ledger(lg ((a, as), n) := L - {x})))"
          by (unfold ledgra_upd_def, subst ledgra_update_lem, rule disjI2,
              rule inset_n_empty, rule a1a, insert a0, erule subst, unfold ledgra_at_def,
              insert b00, blast)
        have b1: "ledger_to_loc (lg ((a, as), n) := L - {x}) x = {}" using b0 ledger_to_loc_def by simp
        have b2000: "x \<in> \<Union> (range (Rep_ledger lg))"
          by (insert a1a, insert lex, force)
        have b200: "ledger_to_loc lg x = fmap data_trans {dl. x \<in> Rep_ledger lg dl}"
          by (unfold ledger_to_loc_def, insert b2000, simp add: ledgra_at_def)
        have b21: "{dl::(char list \<times> char list set) \<times> char list. x \<in> Rep_ledger lg dl}
                   = {((a,as),n)}"
          by (rule equalityI, insert A, blast, insert a1a, insert lex, simp)
        have b22: "{data_trans ((a,as),n)} = fmap data_trans {((a,as),n)}"
           by (rule sym, rule fmap_lem_one)
        have b20: "ledger_to_loc lg x = {data_trans ((a,as),n)}"
          by (subst b200, subst b22, subst b21, rule refl)
        have b2: "ledger_to_loc lg x - {(y::actor \<times> actor set, x::char list). x = n} = {}"
               by (subst b20, simp add: data_trans_def)
        show ?thesis by (subst b1, subst b2, rule refl)
      qed
    next assume lnex: "l \<noteq> x" show
     "ledger_to_loc (lg ((a, as), n) := L - {l}) x =
    ((ledger_to_loc lg)(l := ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list). x = n})) x"
      proof (case_tac "x \<in> Rep_ledger lg ((a,as),n)")
        assume b3: "x \<in> Rep_ledger lg ((a,as),n)"
          have b300: "x \<in> \<Union> (range (Rep_ledger lg))"
             by (insert a1a, insert b3, force)
          have b30: "x \<in> Rep_ledger (lg ((a,as),n):= L - {l})((a,as),n)"
            by (insert lnex, insert b3, insert a0, unfold ledgra_upd_def, subst ledgra_update_lem,
                  rule disjI2, erule inset_n_empty, simp add: ledgra_at_def)
          have b3000: "x \<in> \<Union> (range (Rep_ledger (lg ((a, as), n) := L - {l})))"
            by (insert b300, insert b30, force)
          have b31a: "ledger_to_loc (lg ((a, as), n) := L - {l}) x =
                   fmap data_trans {dl. x \<in> Rep_ledger (lg ((a,as),n):= (L - {l})) dl}"
            by (insert b3000, insert lnex, insert A, unfold ledger_to_loc_def, simp add: ledgra_at_def)
          have b31b: "{dl. x \<in> Rep_ledger (lg ((a,as),n):= (L - {l})) dl} =
                       {dl. x \<in> ((Rep_ledger lg)(((a,as),n):= L - {l})) dl}"
            by (unfold ledgra_upd_def, subst ledgra_update_lem,
                rule disjI2, rule inset_n_empty, rule b3, rule refl)
          have b31c: "fmap data_trans {dl. x \<in> Rep_ledger (lg ((a,as),n):= (L - {l})) dl} =
                   fmap data_trans {dl. x \<in> ((Rep_ledger lg)(((a,as),n):= L - {l})) dl}"
            by (subst b31b, rule refl)
          have b32a: "{dl. x \<in> ((Rep_ledger lg)(((a, as), n) := L - {l})) dl} = {((a,as),n)}"
          proof
            show "{((a, as), n)} \<subseteq> {dl. x \<in> ((Rep_ledger lg)(((a, as), n) := L - {l})) dl}"
              by (insert b3, insert lnex, simp, insert a0, simp add: ledgra_at_def)
          next show "{dl. x \<in> ((Rep_ledger lg)(((a, as), n) := L - {l})) dl} \<subseteq> {((a, as), n)}"
              by (insert A, insert lnex, insert b3, insert a0, unfold ledgra_at_def,
                  erule subst, rule subsetI, drule CollectD, subgoal_tac "xa = ((a,as),n)",
                  simp, rule_tac Q = "x \<in> Rep_ledger lg ((a, as), n)" in contrapos_pp, assumption,
                  drule_tac x = xa in spec, drule mp, assumption, drule b32a0, assumption,
                  erule_tac notE, assumption)
          qed
          have b32: "ledger_to_loc (lg ((a, as), n) := L - {l}) x =
                    fmap data_trans {((a,as),n)}"
              by (subst b31a, subst b31c, subst b32a, rule refl)
          have b33: "((ledger_to_loc lg)(l := ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list). x = n})) x
                    = (ledger_to_loc lg) x" by (insert lnex ,simp)
          have b34: "(ledger_to_loc lg) x = fmap data_trans {dl. x \<in> Rep_ledger lg dl}"
            by (insert b300, insert b3, unfold ledger_to_loc_def ledgra_at_def, simp)
          have b35a: "{dl. x \<in> Rep_ledger lg dl} = {((a,as),n)}"
            by (insert b3, insert A, blast)
          have b35: "fmap data_trans {dl. x \<in> Rep_ledger lg dl} = fmap data_trans {((a,as),n)}"
            by (subst b35a, rule refl)
        show ?thesis
          by (subst b32, subst b33, subst b34, subst b35, rule refl)
      next assume b4: "x \<notin> Rep_ledger lg ((a,as),n)"
        have b40: "x \<notin> Rep_ledger (lg ((a,as),n) := L - {l})((a,as),n)"
          by (insert a0, unfold ledgra_at_def, erule subst, unfold ledgra_upd_def,
              subst ledgra_update_lem, rule disjI2, rule inset_n_empty, rule a1a,
              insert b4, erule contrapos_nn, simp)
        have b40b: "x \<notin> \<Union> (range (Rep_ledger lg))"
          by (insert A, insert b4, force)
        have b40a: "x \<notin> \<Union> (range (Rep_ledger (lg ((a,as),n) := L - {l})))"
          by (insert b40b, insert a0, unfold ledgra_at_def, erule subst, unfold ledgra_upd_def,
              subst ledgra_update_lem, rule disjI2, rule inset_n_empty, rule a1a, simp)
        have b41: "ledger_to_loc (lg ((a, as), n) := L - {l}) x = {}"
          by (insert b40a, unfold ledger_to_loc_def, simp)
        have b420: "((ledger_to_loc lg)(l := ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list). x = n})) x
                   = (ledger_to_loc lg) x"
          by (insert lnex ,simp)
        have b42:  "((ledger_to_loc lg)(l := ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list). x = n})) x
                   = {}"
          by (subst b420, insert b40b, simp add: ledger_to_loc_def)
        show ?thesis
          by (subst b41, subst b42, rule refl)
      qed
    qed
  next fix x
    assume B: "\<not> (\<forall>dl::(char list \<times> char list set) \<times> char list. dl \<noteq> ((a, as), n) \<longrightarrow> x \<notin> Rep_ledger lg dl)"
    show "ledger_to_loc (lg ((a, as), n) := L - {l}) x =
       ((ledger_to_loc lg)(l := ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list). x = n})) x"
    proof -
      have B0: "(\<exists> dl. dl \<noteq> ((a, as), n) \<and> x \<in> Rep_ledger lg dl)" using B by blast
      show ?thesis
      proof (case_tac "l = x", simp)
        assume lex: "l = x"
        show "ledger_to_loc (lg ((a, as), n) := L - {x}) x =
              ledger_to_loc lg x - {(y::actor \<times> actor set, x::char list). x = n}"
        proof -
          have c000: "x \<in> Rep_ledger lg ((a,as),n)"
            by (insert a0, insert a1, insert lex, simp add: ledgra_at_def)
          have c00: "x \<in> \<Union> (range (Rep_ledger lg))"
              by (insert a1a, insert lex, force)
          have c0: "x \<in> \<Union> (range(Rep_ledger(lg ((a, as), n) := L - {x})))"
            by (unfold ledgra_upd_def, subst ledgra_update_lem, rule disjI2, rule inset_n_empty,
                rule a1a, insert B0, erule exE, insert a0, erule subst, unfold ledgra_at_def, force)
          have c1: "ledger_to_loc (lg ((a, as), n) := L - {x}) x =
                    fmap data_trans {dl. x \<in> Rep_ledger (lg ((a,as),n):= (L - {l})) dl}"
            by (insert c0, insert lex, unfold ledger_to_loc_def, simp add: ledgra_at_def)
          have c20: "{dl. x \<in> Rep_ledger (lg ((a,as),n):= (L - {l})) dl} =
                       {dl. x \<in> ((Rep_ledger lg)(((a,as),n):= L - {l})) dl}"
            by (unfold ledgra_upd_def, subst ledgra_update_lem, rule disjI2, rule inset_n_empty,
                   rule c000, rule refl)
          have c2: "ledger_to_loc (lg ((a, as), n) := L - {x}) x =
                     fmap data_trans  {dl. x \<in> ((Rep_ledger lg)(((a,as),n):= L - {l})) dl}"
            by (subst c1, subst c20, rule refl)
          have c30: "ledger_to_loc lg x - {(y::actor \<times> actor set, x::char list). x = n} =
                    fmap data_trans {dl. x \<in> Rep_ledger lg dl} - {(y,x). x = n}"
            by (insert c00, unfold ledger_to_loc_def, simp add: ledgra_at_def)
          have c3000: "fmap data_trans {dl. x \<in> Rep_ledger lg dl} - {(y,x). x = n} =
           fmap data_trans {dl. x \<in> Rep_ledger lg dl} -
               {(y,z). (y,z) \<in> fmap data_trans {dl. x \<in> Rep_ledger lg dl} \<and> z = n }"
            by blast
          have c30a: "{(y,z). (y,z) \<in> fmap data_trans {dl. x \<in> Rep_ledger lg dl} \<and> z = n } =
                      fmap data_trans {dl. x \<in> Rep_ledger lg dl \<and> snd dl = n}"
            by (subst fmap_set_rep', insert a, erule spec, subst fmap_set_rep',
                rule_tac B = "{dl. x \<in> Rep_ledger lg dl}" in finite_subset, blast, erule spec,
                unfold data_trans_def, rule equalityI, force, force)
          have c30b: "fmap data_trans {dl. x \<in> Rep_ledger lg dl} -
               {(y,z). (y,z) \<in> fmap data_trans {dl. x \<in> Rep_ledger lg dl} \<and> z = n } =
               fmap data_trans ({dl. x \<in> Rep_ledger lg dl} - {dl. x \<in> Rep_ledger lg dl \<and> snd dl = n})"
            by (subst c30a, rule fmap_set_del_set, insert a, erule spec, rule inj_inj_on,
                  rule inj_data_trans, rule b, blast)
          have c30c: "{dl. x \<in> Rep_ledger lg dl \<and> snd dl = n}=
                      {((a,as),n)}"
          proof
            show "{((a, as), n)} \<subseteq> {dl. x \<in> Rep_ledger lg dl \<and> snd dl = n}"
              by (insert c000, simp)
          next show "{dl. x \<in> Rep_ledger lg dl \<and> snd dl = n} \<subseteq> {((a, as), n)}"
             by (insert c000, rule subsetI, subgoal_tac "xa = ((a,as),n)", simp,
              drule CollectD, case_tac xa, simp,
              rule_tac dl = aa and dl' = "(a,as)" in ledger_to_loc_data_unique,
               erule conjE, erule inset_n_empty, erule conjE, rule inset_n_empty, simp)
            qed
          have c300: "fmap data_trans {dl. x \<in> Rep_ledger lg dl} - {(y,x). x = n} =
                      fmap data_trans ({dl. x \<in> Rep_ledger lg dl} - {((a,as),n)})"
            by (subst c3000, subst c30b, subst c30c, rule refl)
          have c3: "ledger_to_loc lg x - {(y::actor \<times> actor set, x::char list). x = n} =
                   fmap data_trans ({dl. x \<in> Rep_ledger lg dl} - {((a,as),n)})"
            by (subst c30, subst c300, rule refl)
          have c4: "{dl. x \<in> ((Rep_ledger lg)(((a,as),n):= L - {l})) dl} =
                    {dl. x \<in> Rep_ledger lg dl} - {((a,as),n)}"
            by (insert a0, unfold ledgra_at_def, erule subst, insert lex, simp, blast)
          show ?thesis
            by (subst c2, subst c3, subst c4, rule refl)
        qed
      next assume lnex: "l \<noteq> x"
        show "ledger_to_loc (lg ((a, as), n) := L - {l}) x =
    ((ledger_to_loc lg)(l := ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list). x = n})) x"
        proof -
          have d3000: "x \<in> \<Union>(range (Rep_ledger (lg ((a, as), n) := L - {l})))"
            apply (insert B0)
            by (metis Union_iff a0 a1 fun_upd_apply insert_absorb insert_not_empty
                ledgra_at_def ledgra_upd_def ledgra_update_lem rangeI)
          have d300: "x \<in> \<Union> (range (Rep_ledger (lg)))"
            by (insert B0, insert d3000, force)
          have d4000: "ledger_to_loc (lg ((a, as), n) := L - {l}) x =
                    fmap data_trans {dl. x \<in> Rep_ledger (lg ((a, as), n) := L - {l}) dl}"
            by (insert d3000, unfold ledger_to_loc_def, simp add: ledgra_at_def)
          have d400: "{dl. x \<in> Rep_ledger (lg ((a,as),n):= (L - {l})) dl} =
                       {dl. x \<in> ((Rep_ledger lg)(((a,as),n):= L - {l})) dl}"
            by (unfold ledgra_upd_def, subst ledgra_update_lem, rule disjI2, rule inset_n_empty,
                rule a1a, rule refl)
          have d40: "ledger_to_loc (lg ((a, as), n) := L - {l}) x =
                     fmap data_trans {dl. x \<in> ((Rep_ledger lg)(((a,as),n):= L - {l})) dl}"
            by (subst d4000, subst d400, rule refl)
          have d4: "x \<in> Rep_ledger lg ((a, as), n) \<Longrightarrow> {dl. x \<in> ((Rep_ledger lg)(((a,as),n):= L - {l})) dl} =
                     {dl. x \<in> (Rep_ledger lg) dl}"
            by (insert lnex, insert a0, insert a1, erule subst, simp add: ledgra_at_def, blast)
          have d5000: "((ledger_to_loc lg)(l := ledger_to_loc lg l - {(y::actor \<times> actor set, x::char list). x = n})) x
                   = (ledger_to_loc lg) x"
            by (insert lnex, simp)
          have d500: "(ledger_to_loc lg) x = fmap data_trans {dl. x \<in> Rep_ledger lg dl}"
            by (insert d300, insert a1a, unfold ledger_to_loc_def ledgra_at_def, simp)
          show ?thesis
            apply (subst d40, subst d5000, subst d500, case_tac "x \<in> Rep_ledger lg ((a, as), n)",
                insert d4, drule meta_mp, assumption, erule ssubst, rule refl)
            by (metis Diff_iff a0 fun_upd_apply ledgra_at_def)
      qed
  qed
qed
qed
qed

definition ref_map :: "[RRLoopFour.infrastructure,
                        [RRLoopThree.igraph, location] \<Rightarrow> policy set]
                        \<Rightarrow> RRLoopThree.infrastructure"
  where "ref_map I lp = RRLoopThree.Infrastructure
                                 (RRLoopThree.Lgraph
                                        (gra (graphI I))(agra (graphI I))
                                        (cgra (graphI I))
                                        (ledger_to_loc (ledgra (graphI I))))
                                 lp"

lemma delta_invariant: "\<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow>  delta(z) = delta(z')"
  apply clarify
  apply (erule state_transition_in.cases)
 by simp+

end


(*  Title:      HOL/Auth/n_german_lemma_on_inv__50.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

(*header{*The n_german Protocol Case Study*}*)

theory n_german_lemma_on_inv__50 imports n_german_base
begin
section{*All lemmas on causal relation between inv__50 and some rule r*}
lemma n_SendInv__part__0Vsinv__50:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__0  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__1Vsinv__50:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__1  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInvAckVsinv__50:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvAck  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvInvAckVsinv__50:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvInvAck  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntSVsinv__50:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntS  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv0) ''Cmd'')) (Const GntE)) (eqn (IVar (Ident ''ExGntd'')) (Const false))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__50:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv0) ''Cmd'')) (Const GntE)) (eqn (IVar (Para (Ident ''ShrSet'') p__Inv0)) (Const false))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntSVsinv__50:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntS  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntEVsinv__50:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntE  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendReqE__part__1Vsinv__50:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_StoreVsinv__50:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqEVsinv__50:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqE N i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqE__part__0Vsinv__50:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqSVsinv__50:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqS  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqSVsinv__50:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqS N i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__50  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end


(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: Railways_Spec.thy                                                    *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk                 *)
(******************************************************************************)
(* LAST REVIEWED: 19 Oct 2017 *)

section {* Railways Specification *}

theory Railways_Spec
imports Vector Topology utp_hoare_ext
begin recall_syntax

consts dots :: "'a" ("\<dots>")

declare [[syntax_ambiguity_warning=false]]

(* declare atLeastAtMost_iff [simp del] *)

definition front :: "'a list \<Rightarrow> 'a list" where
"front l = rev (tl (rev l))"

abbreviation middle :: "'a list \<Rightarrow> 'a list" where
"middle l \<equiv> front (tl l)"

(* "x \<in> set l \<Longrightarrow> x \<noteq> *)

subsection {* Isabelle/UTP Laws *}

lemma uimp_uconjI:
"`P \<Rightarrow> Q` \<Longrightarrow>
 `P \<Rightarrow> R` \<Longrightarrow>
 `P \<Rightarrow> Q \<and> R`"
apply (pred_auto)
done

lemma uconjD1:
"`P \<Rightarrow> R` \<Longrightarrow> `P \<and> Q \<Rightarrow> R`"
apply (pred_auto)
done

lemma uconjD2:
"`Q \<Rightarrow> R` \<Longrightarrow> `P \<and> Q \<Rightarrow> R`"
apply (pred_auto)
done

lemma exportation:
"`P \<and> Q \<Rightarrow> R` = `P \<Rightarrow> Q \<Rightarrow> R`"
apply (pred_auto)
done

method ustrip_tac =
  (rule uimp_uconjI; ustrip_tac)?

subsection {* Centralised FMU State *}

type_synonym TIME = "nat"

alphabet railways_state =
  (* Train FMUs *)
  current_track\<^sub>1 :: "int"
  current_track\<^sub>2 :: "int"
  telecommand\<^sub>1 :: "bool vector"
  telecommand\<^sub>2 :: "bool vector"
  (* Merger FMU *)
  cdv :: "bool vector"
  tc :: "bool vector"
  (* Interlocking FMU *)
  relays :: "bool vector"
  signals :: "bool vector"
  switches :: "switch vector"
  (* Simulation Time *)
  time :: "TIME"

text \<open>Convenience syntax for indexed access of @{const cdv}.\<close>

abbreviation CDV :: "nat \<Rightarrow> (bool, railways_state) uexpr" ("CDV[_]") where
"CDV[i] \<equiv> &cdv[i]\<^sub>u"

text \<open>Convenience syntax for indexed access of @{const tc}.\<close>

abbreviation TC :: "nat \<Rightarrow> (bool, railways_state) uexpr" ("TC[_]") where
"TC[i] \<equiv> &tc[i]\<^sub>u"

text \<open>Convenience syntax for accessing elements of @{const relays}.\<close>

abbreviation "R1 \<equiv> &relays[1]\<^sub>u"
abbreviation "R2 \<equiv> &relays[2]\<^sub>u"
abbreviation "R3 \<equiv> &relays[3]\<^sub>u"
abbreviation "R4 \<equiv> &relays[4]\<^sub>u"
abbreviation "R5 \<equiv> &relays[5]\<^sub>u"

text \<open>Convenience syntax for accessing elements of @{const switches}.\<close>

abbreviation "SW1 \<equiv> &switches[1]\<^sub>u"
abbreviation "SW2 \<equiv> &switches[2]\<^sub>u"
abbreviation "SW3 \<equiv> &switches[3]\<^sub>u"
abbreviation "SW4 \<equiv> &switches[4]\<^sub>u"
abbreviation "SW5 \<equiv> &switches[5]\<^sub>u"

subsection {* Proof Support *}

text \<open>Interpretations for the @{type railways_state} alphabet type.\<close>

interpretation railways_state_interp1:
  lens_interp "\<lambda>r. (
    current_track\<^sub>1\<^sub>v r,
    current_track\<^sub>2\<^sub>v r,
    telecommand\<^sub>1\<^sub>v r,
    telecommand\<^sub>2\<^sub>v r,
    cdv\<^sub>v r,
    tc\<^sub>v r,
    relays\<^sub>v r,
    signals\<^sub>v r,
    switches\<^sub>v r,
    time\<^sub>v r,
    more r)"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

interpretation ilock_var_interp2:
  lens_interp "\<lambda>(r, r'). (
    current_track\<^sub>1\<^sub>v r, current_track\<^sub>1\<^sub>v r',
    current_track\<^sub>2\<^sub>v r, current_track\<^sub>2\<^sub>v r',
    telecommand\<^sub>1\<^sub>v r, telecommand\<^sub>1\<^sub>v r',
    telecommand\<^sub>2\<^sub>v r, telecommand\<^sub>2\<^sub>v r',
    cdv\<^sub>v r, cdv\<^sub>v r',
    tc\<^sub>v r, tc\<^sub>v r',
    relays\<^sub>v r, relays\<^sub>v r',
    signals\<^sub>v r, signals\<^sub>v r',
    switches\<^sub>v r, switches\<^sub>v r',
    time\<^sub>v r, time\<^sub>v r',
    more r, more r')"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

subsection {* Type Invariant *}

definition railways_type_inv :: "railways_state upred" where [upred_defs]:
"railways_type_inv = (
  &current_track\<^sub>1 \<in>\<^sub>u \<guillemotleft>{-1..11}\<guillemotright> \<and> #\<^sub>u(&telecommand\<^sub>1) =\<^sub>u 4 \<and>
  &current_track\<^sub>2 \<in>\<^sub>u \<guillemotleft>{-1..11}\<guillemotright> \<and> #\<^sub>u(&telecommand\<^sub>2) =\<^sub>u 4 \<and>
  #\<^sub>u(&cdv) =\<^sub>u 11 \<and> #\<^sub>u(&tc) =\<^sub>u 4 \<and>
  #\<^sub>u(&relays) =\<^sub>u 5 \<and> #\<^sub>u(&signals) =\<^sub>u 3 \<and> #\<^sub>u(&switches) =\<^sub>u 5)"

subsection {* Safety Invariant *}

definition present\<^sub>1 :: "railways_state upred" where [upred_defs]:
"present\<^sub>1 = (&current_track\<^sub>1 \<noteq>\<^sub>u 0)"

definition present\<^sub>2 :: "railways_state upred" where [upred_defs]:
"present\<^sub>2 = (&current_track\<^sub>2 \<noteq>\<^sub>u 0)"

definition derailed\<^sub>1 :: "railways_state upred" where [upred_defs]:
"derailed\<^sub>1 = (&current_track\<^sub>1 =\<^sub>u -1)"

definition derailed\<^sub>2 :: "railways_state upred" where [upred_defs]:
"derailed\<^sub>2 = (&current_track\<^sub>2 =\<^sub>u -1)"

definition safety_req :: "railways_state upred" where [upred_defs]:
"safety_req =
  (\<not> derailed\<^sub>1 \<and> \<not> derailed\<^sub>2 \<and>
  (present\<^sub>1 \<and> present\<^sub>2 \<Rightarrow> &current_track\<^sub>1 \<noteq>\<^sub>u &current_track\<^sub>2))"

subsection {* Relays Invariant *}

text \<open>Ensures that at most one relay can be activated at a time.\<close>

definition relays_excl_inv :: "railways_state upred" where
[upred_defs]: "relays_excl_inv = (
  (#\<^sub>u(&relays) =\<^sub>u 5) \<and>
  (R1 \<Rightarrow> \<not> R2 \<and> \<not> R4) \<and>
  (R2 \<Rightarrow> \<not> R1 \<and> \<not> R3 \<and> \<not> R4 \<and> \<not> R5) \<and>
  (R3 \<Rightarrow> \<not> R2 \<and> \<not> R4 \<and> \<not> R5) \<and>
  (R4 \<Rightarrow> \<not> R1 \<and> \<not> R2 \<and> \<not> R3 \<and> \<not> R5) \<and>
  (R5 \<Rightarrow> \<not> R2 \<and> \<not> R3 \<and> \<not> R4))"

paragraph {* Proof Support *}

definition valid_relay_states :: "(bool vector) set" where
"valid_relay_states =
 vector_from_list ` {
  [OFF, OFF, OFF, OFF, OFF],
  [ON, OFF, OFF, OFF, OFF],
  [ON, OFF, OFF, OFF, ON],
  [ON, OFF, ON, OFF, OFF],
  [OFF, ON, OFF, OFF, OFF],
  [OFF, OFF, ON, OFF, OFF],
  [ON, OFF, ON, OFF, OFF],
  [OFF, OFF, OFF, ON, OFF],
  [OFF, OFF, OFF, OFF, ON],
  [ON, OFF, OFF, OFF, ON]}"

lemma eq_vector_from_list_5:
"size v = 5 \<Longrightarrow>
  (v = vector_from_list [b1, b2, b3, b4, b5]) =
  (v\<^bold>[1\<^bold>] = b1 \<and> v\<^bold>[2\<^bold>] = b2 \<and> v\<^bold>[3\<^bold>] = b3 \<and> v\<^bold>[4\<^bold>] = b4 \<and> v\<^bold>[5\<^bold>] = b5)"
apply (subst vector_equality)
apply (clarsimp)
apply (safe; clarsimp)
apply (subgoal_tac "i \<in> {1, 2, 3, 4, 5}")
apply (safe; clarsimp)
apply (safe; clarsimp)
done

lemma relays_excl_inv_cases:
"relays_excl_inv = (&relays \<in>\<^sub>u \<guillemotleft>valid_relay_states\<guillemotright>)"
apply (unfold relays_excl_inv_def)
apply (rel_simp)
apply (safe; clarsimp?)
apply (unfold valid_relay_states_def)
apply (simp_all add: eq_vector_from_list_5)
apply (safe; clarsimp)+
done

lemma relays_excl_inv_split:
"`relays_excl_inv \<Rightarrow> P` = `\<^bold>\<forall> v\<in>\<guillemotleft>valid_relay_states\<guillemotright> \<bullet> P\<lbrakk>\<guillemotleft>v\<guillemotright> / &relays\<rbrakk>`"
apply (unfold relays_excl_inv_cases)
apply (pred_simp robust)
apply (safe; clarsimp)
done

lemma relays_excl_inv_split_alt:
"`relays_excl_inv \<and> P \<Rightarrow> Q` = `\<^bold>\<forall> v\<in>\<guillemotleft>valid_relay_states\<guillemotright> \<bullet> (P \<Rightarrow> Q)\<lbrakk>\<guillemotleft>v\<guillemotright> / &relays\<rbrakk>`"
apply (fold relays_excl_inv_split)
apply (rule exportation)
done

lemma in_nat_set_1_to_5:
"x \<in> {(1::nat)..5} \<longleftrightarrow> x \<in> {1, 2, 3, 4, 5}"
apply (safe; clarsimp)
done

lemma routes_disjoint:
"rs \<in> valid_relay_states \<Longrightarrow>
 rs\<^bold>[i\<^bold>] \<Longrightarrow>
 rs\<^bold>[j\<^bold>] \<Longrightarrow>
 i \<in> {1..5} \<Longrightarrow>
 j \<in> {1..5} \<Longrightarrow>
 i \<noteq> j \<Longrightarrow> set (routes ! i) \<inter> set (routes ! j) = {}"
apply (unfold valid_relay_states_def)
apply (safe; thin_tac "rs = vector_from_list _")
apply (unfold in_nat_set_1_to_5)
apply (safe; simp; unfold routes_def; auto)+
done

subsection {* Train Scenarios *}

text {*
  Train scenarios configure the routes for the two trains passing through the
  interlocking. There are several additional assumptions that need to hold for
  routes pairs to be valid, such as the routes must be distinct and their first
  and last track must not (mutually) overlap. We encapsulate those assumptions
  by way of a locale.
*}

locale train_scenario =
  fixes route\<^sub>1 :: "nat"
  fixes route\<^sub>2 :: "nat"
  assumes route1_in_range: "route\<^sub>1 \<in> ROUTES"
  assumes route2_in_range: "route\<^sub>2 \<in> ROUTES"
  assumes routes_distinct: "route\<^sub>1 \<noteq> route\<^sub>2"
  assumes routes_excl:
    "hd (routes!route\<^sub>1) \<noteq> hd (routes!route\<^sub>2)"
    "hd (routes!route\<^sub>1) \<noteq> last (routes!route\<^sub>2)"
    "last (routes!route\<^sub>1) \<noteq> hd (routes!route\<^sub>2)"
    "last (routes!route\<^sub>1) \<noteq> last (routes!route\<^sub>2)"
begin

text {* Initial and final track, as well as travel direction can be derived. *}

definition initial_track\<^sub>1 :: "int" where
[urel_defs]: "initial_track\<^sub>1 = hd (routes!route\<^sub>1)"

definition initial_track\<^sub>2 :: "int" where
[urel_defs]: "initial_track\<^sub>2 = hd (routes!route\<^sub>2)"

definition final_track\<^sub>1 :: "int" where
[urel_defs]: "final_track\<^sub>1 = last (routes!route\<^sub>1)"

definition final_track\<^sub>2 :: "int" where
[urel_defs]: "final_track\<^sub>2 = last (routes!route\<^sub>2)"

definition direction\<^sub>1 :: "direction" where
[urel_defs]: "direction\<^sub>1 = (directions!route\<^sub>1)"

definition direction\<^sub>2 :: "direction" where
[urel_defs]: "direction\<^sub>2 = (directions!route\<^sub>2)"

paragraph {* Useful lemmas *}

lemma route1_cases:
"(\<And>route1. route1 \<in> ROUTES \<Longrightarrow> P route1) \<Longrightarrow> P route\<^sub>1"
using route1_in_range by (auto)

lemma route2_cases:
"(\<And>route2. route2 \<in> ROUTES \<Longrightarrow> P route2) \<Longrightarrow> P route\<^sub>2"
using route2_in_range by (auto)

lemma route_cases:
"(\<And>route1 route2.
  route1 \<in> ROUTES \<Longrightarrow>
  route2 \<in> ROUTES \<Longrightarrow>
  route1 \<noteq> route2 \<Longrightarrow>
  hd (routes!route1) \<noteq> hd (routes!route2) \<Longrightarrow>
  hd (routes!route1) \<noteq> last (routes!route2) \<Longrightarrow>
  last (routes!route1) \<noteq> hd (routes!route2) \<Longrightarrow>
  last (routes!route1) \<noteq> last (routes!route2) \<Longrightarrow>
  P route1 route2) \<Longrightarrow> P route\<^sub>1 route\<^sub>2"
  by (metis route1_in_range route2_in_range routes_excl)
end

text {*
  We next define the global train scenario that we consider in proofs. Rather
  than assuming particular routes, we keep the route configuration abstract by
  using indefinite description (Hilbert's epsilon). Our approach effectively
  allows us to prove properties of the cosimulation, such as global and safety
  invariants for \emph{all} possible train scenarios.
*}

definition route\<^sub>1 :: "nat" where
"route\<^sub>1 = fst (SOME (route\<^sub>1, route\<^sub>2). train_scenario route\<^sub>1 route\<^sub>2)"

definition route\<^sub>2 :: "nat" where
"route\<^sub>2 = snd (SOME (route\<^sub>1, route\<^sub>2). train_scenario route\<^sub>1 route\<^sub>2)"

lemma train_scenario_witness:
"train_scenario V1Q1 Q2V2"
apply (unfold_locales)
apply (simp_all add: routes_def)
done

lemma train_scenario:
"train_scenario route\<^sub>1 route\<^sub>2"
apply (unfold route\<^sub>1_def route\<^sub>2_def)
apply (rule someI2_ex)
apply (rule_tac x = "(V1Q1, Q2V2)" in exI)
apply (simp del: One_nat_def)
apply (rule train_scenario_witness)
apply (clarsimp)
done

interpretation train_scenario "route\<^sub>1" "route\<^sub>2"
apply (rule train_scenario)
done

subsection {* Train Model *}

definition MustWait :: "bool vector \<Rightarrow> direction \<Rightarrow> int \<Rightarrow> bool" where
"MustWait sig dir track \<longleftrightarrow>
  (track = 1 \<and> dir = QtoV \<and> \<not> sig\<^bold>[1\<^bold>]) \<or>
  (track = 2 \<and> dir = QtoV \<and> \<not> sig\<^bold>[2\<^bold>]) \<or>
  (track = 3 \<and> dir = VtoQ \<and> \<not> sig\<^bold>[3\<^bold>])"

fun MoveTrain :: "int \<times> direction \<times> (bool vector) \<times> (switch vector) \<Rightarrow> int" where
"MoveTrain (track, dir, sig, sw) =
  (if track =  0 then  0 else
  (if track = -1 then -1 else
  (if MustWait sig dir track then track
   else (case dir of
    QtoV \<Rightarrow> NextTrackQV sw track |
    VtoQ \<Rightarrow> NextTrackVQ sw track))))"

syntax "_MoveTrack\<^sub>u" ::
  "(int \<times> direction \<times> (bool vector) \<times> (switch vector) \<Rightarrow> int, '\<alpha>) uexpr"
  ("MoveTrain\<^sub>u")

translations "MoveTrain\<^sub>u" \<rightleftharpoons> "\<guillemotleft>CONST MoveTrain\<guillemotright>"

definition Train1 :: "TIME \<Rightarrow> railways_state hrel" where
"Train1 \<epsilon> = (
  ($current_track\<^sub>1\<acute> =\<^sub>u $current_track\<^sub>1 \<or>
   $current_track\<^sub>1\<acute> =\<^sub>u MoveTrain\<^sub>u($current_track\<^sub>1, \<guillemotleft>direction\<^sub>1\<guillemotright>, $signals, $switches)\<^sub>a)
  \<and> $telecommand\<^sub>1\<acute> =\<^sub>u \<dots> \<and> $time\<acute> \<le>\<^sub>u $time + \<guillemotleft>\<epsilon>\<guillemotright>)"

definition Train2 :: "TIME \<Rightarrow> railways_state hrel" where
"Train2 \<epsilon> = (
  ($current_track\<^sub>2\<acute> =\<^sub>u $current_track\<^sub>2 \<or>
   $current_track\<^sub>2\<acute> =\<^sub>u MoveTrain\<^sub>u($current_track\<^sub>2, \<guillemotleft>direction\<^sub>2\<guillemotright>, $signals, $switches)\<^sub>a)
  \<and> $telecommand\<^sub>2\<acute> =\<^sub>u \<dots> \<and> $time\<acute> \<le>\<^sub>u $time + \<guillemotleft>\<epsilon>\<guillemotright>)"

subsection {* Train Invariant *}

(* Try the following as an invariant! *)

definition train1_inv :: "railways_state upred" where
[urel_defs]: "train1_inv = (
  &current_track\<^sub>1 =\<^sub>u \<guillemotleft>initial_track\<^sub>1\<guillemotright> \<or>
  (&relays[route\<^sub>1]\<^sub>u \<and> &current_track\<^sub>1 \<in>\<^sub>u \<guillemotleft>set (routes!route\<^sub>1)\<guillemotright>) \<or>
  &current_track\<^sub>1 =\<^sub>u \<guillemotleft>final_track\<^sub>1\<guillemotright> \<or>
  &current_track\<^sub>1 =\<^sub>u 0)"

definition train1_inv_new :: "railways_state upred" where
[urel_defs]: "train1_inv_new = (
  &current_track\<^sub>1 \<in>\<^sub>u \<guillemotleft>set (routes!route\<^sub>1) \<union> {0}\<guillemotright> \<and>
  (&current_track\<^sub>1 \<in>\<^sub>u \<guillemotleft>set (middle (routes!route\<^sub>1))\<guillemotright> \<Rightarrow> &relays[route\<^sub>1]\<^sub>u))"

definition train2_inv :: "railways_state upred" where
[urel_defs]: "train2_inv = (
  &current_track\<^sub>2 =\<^sub>u \<guillemotleft>initial_track\<^sub>2\<guillemotright> \<or>
  (&relays[route\<^sub>2]\<^sub>u \<and> &current_track\<^sub>2 \<in>\<^sub>u \<guillemotleft>set (routes!route\<^sub>2)\<guillemotright>) \<or>
  &current_track\<^sub>2 =\<^sub>u \<guillemotleft>final_track\<^sub>2\<guillemotright> \<or>
  &current_track\<^sub>2 =\<^sub>u 0)"

definition train2_inv_new :: "railways_state upred" where
[urel_defs]: "train2_inv_new = (
  &current_track\<^sub>2 \<in>\<^sub>u \<guillemotleft>set (routes!route\<^sub>2) \<union> {0}\<guillemotright> \<and>
  (&current_track\<^sub>2 \<in>\<^sub>u \<guillemotleft>set (middle (routes!route\<^sub>2))\<guillemotright> \<Rightarrow> &relays[route\<^sub>2]\<^sub>u))"

subsection {* Proof of Safety *}

text {* Proof that the train invariants imply safety. *}

context train_scenario
begin
lemma route1_non_empty:
"routes!route\<^sub>1 \<noteq> []"
apply (rule route1_cases)
apply (safe; simp add: routes_def)
done

lemma route2_non_empty:
"routes!route\<^sub>2 \<noteq> []"
apply (rule route2_cases)
apply (safe; simp add: routes_def)
done
end

lemma mem_set_split:
"l \<noteq> [] \<Longrightarrow> x \<in> set l \<longleftrightarrow> (x = hd l \<or> x \<in> set (tl l))"
apply (induction l)
apply (simp_all)
done

lemma at_route_simps [simp]:
"(vector_from_list [a, b, c, d, e])\<^bold>[route\<^sub>1\<^bold>] = [a, b, c, d, e]!(route\<^sub>1 - 1)"
"(vector_from_list [a, b, c, d, e])\<^bold>[route\<^sub>2\<^bold>] = [a, b, c, d, e]!(route\<^sub>2 - 1)"
apply (rule route1_cases)
apply (safe; simp)
apply (rule route2_cases)
apply (safe; simp)
done

lemma hd_route1_not_in_set_route2:
"hd (routes!route\<^sub>1) \<notin> set (routes!route\<^sub>2)"
apply (subst mem_set_split)
apply (rule route2_non_empty)
apply (safe; erule contrapos_pp; simp)
apply (rule routes_excl(1))
apply (rule route_cases)
apply (safe; simp add: routes_def)
done

lemma hd_route2_not_in_set_route1:
"hd (routes!route\<^sub>2) \<notin> set (routes!route\<^sub>1)"
apply (subst mem_set_split)
apply (rule route1_non_empty)
apply (safe; erule contrapos_pp; simp)
apply (subst eq_commute)
apply (rule routes_excl(1))
apply (rule route_cases)
apply (safe; simp add: routes_def)
done

lemma last_route1_not_in_set_route2:
"last (routes!route\<^sub>1) \<notin> set (routes!route\<^sub>2)"
apply (subst mem_set_split)
apply (rule route2_non_empty)
apply (safe; erule contrapos_pp; simp)
apply (rule routes_excl(3))
apply (rule route_cases)
apply (safe; simp add: routes_def)
done

lemma last_route2_not_in_set_route1:
"last (routes!route\<^sub>2) \<notin> set (routes!route\<^sub>1)"
apply (subst mem_set_split)
apply (rule route1_non_empty)
apply (safe; erule contrapos_pp; simp)
apply (subst eq_commute)
apply (rule routes_excl(2))
apply (rule route_cases)
apply (safe; simp add: routes_def)
done

lemma safety_req_lemma1:
"`train1_inv \<Rightarrow> \<not> derailed\<^sub>1`"
apply (rel_simp)
apply (rule route1_cases)
apply (safe; simp add: routes_def)
done

lemma safety_req_lemma2:
"`train2_inv \<Rightarrow> \<not> derailed\<^sub>2`"
apply (rel_simp)
apply (rule route2_cases)
apply (safe; simp add: routes_def)
done

lemma safety_req_lemma3:
"`relays_excl_inv \<and> train1_inv \<and> train2_inv \<Rightarrow>
  (present\<^sub>1 \<and> present\<^sub>2 \<Rightarrow> &current_track\<^sub>1 \<noteq>\<^sub>u &current_track\<^sub>2)`"
apply (subst relays_excl_inv_split_alt)
apply (rel_simp)
apply (rename_tac rs)
apply (safe)
-- {* Subgoal 1 *}
using routes_excl(1)
apply (auto) [1]
-- {* Subgoal 2 *}
using hd_route1_not_in_set_route2
apply (auto) [1]
-- {* Subgoal 3 *}
using routes_excl(2)
apply (auto) [1]
-- {* Subgoal 4 *}
using hd_route2_not_in_set_route1
apply (auto) [1]
-- {* Subgoal 5 *}
using routes_excl(3)
apply (auto) [1]
-- {* Subgoal 6 *}
apply (subgoal_tac "set (routes!route\<^sub>1) \<inter> set (routes!route\<^sub>2) = {}")
-- {* Subgoal 5.1 *}
apply (blast)
-- {* Subgoal 5.2 *}
apply (erule routes_disjoint)
apply (assumption)
apply (assumption)
using in_nat_set_1_to_5 route1_in_range apply (blast)
using in_nat_set_1_to_5 route2_in_range apply (blast)
using routes_distinct apply (blast)
-- {* Subgoal 7 *}
using last_route2_not_in_set_route1
apply (auto) [1]
-- {* Subgoal 8 *}
using last_route1_not_in_set_route2
apply (auto) [1]
-- {* Subgoal 9 *}
using routes_excl(4)
apply (auto) [1]
done

lemma safety_req_holds:
"`relays_excl_inv \<and> train1_inv \<and> train2_inv \<Rightarrow> safety_req`"
apply (unfold safety_req_def)
apply (ustrip_tac)
-- {* Subgoal 1 *}
apply (rule uconjD2; rule uconjD1)
apply (rule safety_req_lemma1)
-- {* Subgoal 2 *}
apply (rule uconjD2; rule uconjD2)
apply (rule safety_req_lemma2)
-- {* Subgoal 3 *}
apply (rule safety_req_lemma3)
done

lemma new_safety_req_lemma1:
"`train1_inv_new \<Rightarrow> \<not> derailed\<^sub>1`"
apply (rel_simp)
apply (atomize (full))
apply (rule route1_cases)
apply (safe; simp add: routes_def)
done

lemma new_safety_req_lemma2:
"`train2_inv_new \<Rightarrow> \<not> derailed\<^sub>2`"
apply (rel_simp)
apply (atomize (full))
apply (rule route2_cases)
apply (safe; simp add: routes_def)
done

lemma new_safety_req_lemma3:
"`relays_excl_inv \<and> train1_inv_new \<and> train2_inv_new \<Rightarrow>
  (present\<^sub>1 \<and> present\<^sub>2 \<Rightarrow> &current_track\<^sub>1 \<noteq>\<^sub>u &current_track\<^sub>2)`"
apply (subst relays_excl_inv_split_alt)
apply (rel_simp)
apply (rename_tac rs)
apply (safe)
-- {* Subgoal 1 *}
defer
-- {* Subgoal 2 *}
defer
-- {* Subgoal 3 *}
defer
-- {* Subgoal 4 *}
apply (atomize (full))
apply (rule route_cases)
apply (safe; clarsimp simp add: routes_def)
apply (auto) [1]
apply (auto) [1]
apply (auto) [1]
apply (auto) [1]
apply (auto) [1]
apply (unfold valid_relay_states_def)
apply (simp; safe; clarsimp)
apply (simp; safe; clarsimp)
sledgehammer
oops

lemma safety_req_holds_new:
"`relays_excl_inv \<and> train1_inv_new \<and> train2_inv_new \<Rightarrow> safety_req`"
apply (unfold safety_req_def)
apply (ustrip_tac)
-- {* Subgoal 1 *}
apply (rule uconjD2; rule uconjD1)
apply (rule new_safety_req_lemma1)
-- {* Subgoal 2 *}
apply (rule uconjD2; rule uconjD2)
apply (rule new_safety_req_lemma2)
-- {* Subgoal 3 *}
(* apply (rule safety_req_lemma3) *)
oops

subsection {* Merger Model *}

definition MergeCDV :: "int \<Rightarrow> (bool vector) \<Rightarrow> (bool vector)" where
"MergeCDV i v =
  (if i = 0 \<or> i = -1 then v else
  (if i \<in> {1..13} then v\<^bold>[nat i\<^bold>] \<hookleftarrow> False else undefined))"

fun MakeCDV :: "int \<times> int \<Rightarrow> (bool vector)" where
"MakeCDV (i, j) = (MergeCDV i (MergeCDV j (mk_vector 13 True)))"

syntax "_MakeCDV" ::
  "(int \<times> int \<Rightarrow> (bool vector), railways_state) uexpr" ("MakeCDV\<^sub>u")

translations "MakeCDV\<^sub>u" \<rightleftharpoons> "\<guillemotleft>CONST MakeCDV\<guillemotright>"

definition Merger :: "railways_state hrel" where
"Merger = ($cdv\<acute> =\<^sub>u MakeCDV\<^sub>u($current_track\<^sub>1, $current_track\<^sub>2)\<^sub>a \<and> $tc\<acute> =\<^sub>u \<dots>)"

subsection {* Proof Experiments *}

lemma udisj_hoare:
"\<lbrace>p\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p\<rbrace>T\<lbrace>q\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p\<rbrace>S \<or> T\<lbrace>q\<rbrace>\<^sub>u"
apply (rel_auto)
done

declare MoveTrain.simps [simp del]

definition relays_set_inv [upred_defs]:
"relays_set_inv =
  (&current_track\<^sub>1 \<in>\<^sub>u \<guillemotleft>set (middle (routes!route\<^sub>1))\<guillemotright> \<Rightarrow> &relays[route\<^sub>1]\<^sub>u)"

method route1_cases_tac =
  ((erule rev_mp)+, rule route1_cases,
    (safe; (simp add: routes_def front_def)?))

lemma in_set_list_split3:
"l \<noteq> [] \<Longrightarrow> x \<in> set l = (x = hd l \<or> x \<in> set (middle l) \<or> x = last l)"
apply (unfold front_def)
apply (metis (no_types, lifting)
  Nil_is_rev_conv hd_rev last_tl mem_set_split set_rev tl_Nil)
done

lemma "\<lbrace>train1_inv\<rbrace>Train1 \<epsilon>\<lbrace>relays_set_inv \<Rightarrow> train1_inv\<rbrace>\<^sub>u"
apply (unfold Train1_def)
apply (unfold train1_inv_def)
apply (rel_simp)
apply (safe; clarsimp; thin_tac "telecommand\<^sub>1\<^sub>v' = _")
apply (meson in_set_list_split3 route1_non_empty)
-- {* A few more days work to do here to prove this invariant! *}
oops

lemma MoveTrain_lemmas:
"MoveTrain (0, dir, sig, sw) = 0"
"MoveTrain (-1, dir, sig, sw) = -1"
"MoveTrain (1, QtoV, sig, sw) = (if sig\<^bold>[1\<^bold>] then 10 else 1)"
"MoveTrain (1, VtoQ, sig, sw) = 0"
"MoveTrain (2, QtoV, sig, sw) = (if sig\<^bold>[2\<^bold>] then 11 else 2)"
"MoveTrain (2, VtoQ, sig, sw) = 0"
"MoveTrain (3, QtoV, sig, sw) = 0"
"MoveTrain (3, VtoQ, sig, sw) =
  (if sig\<^bold>[3\<^bold>] then (if sw\<^bold>[1\<^bold>] = STRAIGHT then 4 else -1) else 3)"
"MoveTrain (4, QtoV, sig, sw) = (if sw\<^bold>[1\<^bold>] = STRAIGHT then 3 else 13)"
"MoveTrain (4, VtoQ, sig, sw) = (if sw\<^bold>[3\<^bold>] = STRAIGHT then 5 else 12)"
"MoveTrain (5, QtoV, sig, sw) = (if sw\<^bold>[3\<^bold>] = STRAIGHT then 4 else -1)"
"MoveTrain (5, VtoQ, sig, sw) = 0"
"MoveTrain (6, QtoV, sig, sw) = 0"
"MoveTrain (6, VtoQ, sig, sw) = (if sw\<^bold>[4\<^bold>] = STRAIGHT then 7 else 13)"
"MoveTrain (7, QtoV, sig, sw) = (if sw\<^bold>[4\<^bold>] = STRAIGHT then 6 else -1)"
"MoveTrain (7, VtoQ, sig, sw) = (if sw\<^bold>[2\<^bold>] = STRAIGHT then 8 else -1)"
"MoveTrain (8, QtoV, sig, sw) = (if sw\<^bold>[2\<^bold>] = STRAIGHT then 7 else 12)"
"MoveTrain (8, VtoQ, sig, sw) = 9"
"MoveTrain (9, QtoV, sig, sw) = 8"
"MoveTrain (9, VtoQ, sig, sw) = (if sw\<^bold>[5\<^bold>] = STRAIGHT then 10 else 11)"
"MoveTrain (10, QtoV, sig, sw) = (if sw\<^bold>[5\<^bold>] = STRAIGHT then 9 else -1)"
"MoveTrain (10, VtoQ, sig, sw) = 1"
"MoveTrain (11, QtoV, sig, sw) = (if sw\<^bold>[5\<^bold>] = DIVERGING then 9 else -1)"
"MoveTrain (11, VtoQ, sig, sw) = 2"
apply (simp_all add: MoveTrain.simps MustWait_def)
apply (simp_all add: NextTrackQV_def NextTrackVQ_def)
done

lemma "\<lbrace>train1_inv_new\<rbrace>Train1 \<epsilon>\<lbrace>relays_set_inv \<Rightarrow> train1_inv_new\<rbrace>\<^sub>u"
apply (unfold Train1_def)
apply (unfold train1_inv_new_def)
apply (rel_simp)
(* apply (safe; clarsimp; thin_tac "telecommand\<^sub>1\<^sub>v' = _") *)
apply (atomize (full))
apply (rule route1_cases)
apply (safe; clarsimp?)
apply (simp_all add: MoveTrain_lemmas(1))
apply (simp_all add: routes_def directions_def)
-- {* Subgoal 1 *}
apply (safe; clarsimp) [1]
apply (simp_all add: MoveTrain_lemmas front_def) [3]
apply (case_tac "signals\<^sub>v\<^bold>[3\<^bold>]"; clarsimp)
apply (case_tac "switches\<^sub>v\<^bold>[1\<^bold>]"; clarsimp)
apply (subgoal_tac "switches\<^sub>v\<^bold>[1\<^bold>] = STRAIGHT")
apply (auto) [1]
defer
-- {* Subgoal 2 *}
apply (safe; clarsimp) [1]
apply (simp_all add: MoveTrain_lemmas front_def) [3]
apply (case_tac "signals\<^sub>v\<^bold>[3\<^bold>]"; clarsimp)
apply (case_tac "switches\<^sub>v\<^bold>[1\<^bold>]"; clarsimp)
apply (subgoal_tac "switches\<^sub>v\<^bold>[1\<^bold>] = STRAIGHT")
apply (auto) [1]
defer
-- {* Subgoal 3 *}
apply (safe; clarsimp) [1]
apply (simp_all add: MoveTrain_lemmas front_def) [3]
apply (case_tac "signals\<^sub>v\<^bold>[3\<^bold>]"; clarsimp)
apply (case_tac "switches\<^sub>v\<^bold>[1\<^bold>]"; clarsimp)
apply (subgoal_tac "switches\<^sub>v\<^bold>[1\<^bold>] = STRAIGHT")
apply (auto) [1]
defer
apply (case_tac "switches\<^sub>v\<^bold>[3\<^bold>]"; clarsimp)
apply (subgoal_tac "switches\<^sub>v\<^bold>[3\<^bold>] = STRAIGHT")
apply (auto) [1]
defer
-- {* Subgoal 4 *}
apply (safe; clarsimp) [1]
apply (simp_all add: MoveTrain_lemmas front_def) [3]
apply (case_tac "signals\<^sub>v\<^bold>[3\<^bold>]"; clarsimp)
apply (case_tac "switches\<^sub>v\<^bold>[1\<^bold>]"; clarsimp)
apply (subgoal_tac "switches\<^sub>v\<^bold>[1\<^bold>] = STRAIGHT")
apply (auto) [1]
defer
apply (case_tac "switches\<^sub>v\<^bold>[3\<^bold>]"; clarsimp)
apply (subgoal_tac "switches\<^sub>v\<^bold>[3\<^bold>] = STRAIGHT")
apply (auto) [1]
defer
-- {* Subgoal 5 *}
apply (safe; clarsimp) [1]
apply (simp_all add: MoveTrain_lemmas front_def) [7]
apply (case_tac "signals\<^sub>v\<^bold>[3\<^bold>]"; clarsimp)
apply (case_tac "switches\<^sub>v\<^bold>[1\<^bold>]"; clarsimp)
apply (subgoal_tac "switches\<^sub>v\<^bold>[1\<^bold>] = STRAIGHT")
apply (auto) [1]
defer
oops

(*
declare atLeastAtMost_iff [simp del]

lemma [simp]:
"n \<le> m \<Longrightarrow> i \<in> {n..m} = (i = n \<or> i \<in> {Suc n..m})"
apply (unfold atLeastAtMost_iff)
apply (auto)
done
*)
end


(*  Title:      HOL/MicroJava/JVM/JVMExec.thy
    Author:     Cornelia Pusch, Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

header {* \isaheader{Program Execution in the JVM} *}

theory JVMExec
imports JVMExecInstr JVMExceptions
begin

abbreviation
  instrs_of :: "jvm_prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> instr list" where
  "instrs_of P C M == fst(snd(snd(snd(snd(snd(method P C M))))))"

fun exec :: "jvm_prog \<times> jvm_state => jvm_state option" where -- "single step execution"
  "exec (P, xp, h, []) = None"

| "exec (P, None, h, (stk,loc,C,M,pc)#frs) =
  (let
     i = instrs_of P C M ! pc;
     (xcpt', h', frs') = exec_instr i P h stk loc C M pc frs
   in Some(case xcpt' of
             None \<Rightarrow> (None,h',frs')
           | Some a \<Rightarrow> find_handler P a h ((stk,loc,C,M,pc)#frs)))"

| "exec (P, Some xa, h, frs) = None"

-- "relational view"
inductive_set
  exec_1 :: "jvm_prog \<Rightarrow> (jvm_state \<times> jvm_state) set"
  and exec_1' :: "jvm_prog \<Rightarrow> jvm_state \<Rightarrow> jvm_state \<Rightarrow> bool"
    ("_ \<turnstile>/ _ -jvm\<rightarrow>\<^sub>1/ _" [61,61,61] 60)
  for P :: jvm_prog
where
  "P \<turnstile> \<sigma> -jvm\<rightarrow>\<^sub>1 \<sigma>' \<equiv> (\<sigma>,\<sigma>') \<in> exec_1 P"
| exec_1I: "exec (P,\<sigma>) = Some \<sigma>' \<Longrightarrow> P \<turnstile> \<sigma> -jvm\<rightarrow>\<^sub>1 \<sigma>'"

-- "reflexive transitive closure:"
definition exec_all :: "jvm_prog \<Rightarrow> jvm_state \<Rightarrow> jvm_state \<Rightarrow> bool"
              ("_ |-/ _ -jvm->/ _" [61,61,61]60) where
(* FIXME exec_all \<rightarrow> exec_star, also in Def.JVM *)
  exec_all_def1: "P |- \<sigma> -jvm-> \<sigma>' \<longleftrightarrow> (\<sigma>,\<sigma>') \<in> (exec_1 P)\<^sup>*"

notation (xsymbols)
  exec_all  ("(_ \<turnstile>/ _ -jvm\<rightarrow>/ _)" [61,61,61]60)

lemma exec_1_eq:
  "exec_1 P = {(\<sigma>,\<sigma>'). exec (P,\<sigma>) = Some \<sigma>'}"
(*<*)by (auto intro: exec_1I elim: exec_1.cases)(*>*)

lemma exec_1_iff:
  "P \<turnstile> \<sigma> -jvm\<rightarrow>\<^sub>1 \<sigma>' = (exec (P,\<sigma>) = Some \<sigma>')"
(*<*)by (simp add: exec_1_eq)(*>*)

lemma exec_all_def:
  "P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>' = ((\<sigma>,\<sigma>') \<in> {(\<sigma>,\<sigma>'). exec (P,\<sigma>) = Some \<sigma>'}\<^sup>*)"
(*<*)by (simp add: exec_all_def1 exec_1_eq)(*>*)

lemma jvm_refl[iff]: "P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>"
(*<*)by(simp add: exec_all_def)(*>*)

lemma jvm_trans[trans]:
 "\<lbrakk> P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>'; P \<turnstile> \<sigma>' -jvm\<rightarrow> \<sigma>'' \<rbrakk> \<Longrightarrow> P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>''"
(*<*)by(simp add: exec_all_def)(*>*)

lemma jvm_one_step1[trans]:
 "\<lbrakk> P \<turnstile> \<sigma> -jvm\<rightarrow>\<^sub>1 \<sigma>'; P \<turnstile> \<sigma>' -jvm\<rightarrow> \<sigma>'' \<rbrakk> \<Longrightarrow> P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>''"
(*<*) by (simp add: exec_all_def1) (*>*)

lemma jvm_one_step2[trans]:
 "\<lbrakk> P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>'; P \<turnstile> \<sigma>' -jvm\<rightarrow>\<^sub>1 \<sigma>'' \<rbrakk> \<Longrightarrow> P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>''"
(*<*) by (simp add: exec_all_def1) (*>*)

lemma exec_all_conf:
  "\<lbrakk> P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>'; P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>'' \<rbrakk>
  \<Longrightarrow> P \<turnstile> \<sigma>' -jvm\<rightarrow> \<sigma>'' \<or> P \<turnstile> \<sigma>'' -jvm\<rightarrow> \<sigma>'"
(*<*)by(simp add: exec_all_def single_valued_def single_valued_confluent)(*>*)

lemma exec_all_finalD: "P \<turnstile> (x, h, []) -jvm\<rightarrow> \<sigma> \<Longrightarrow> \<sigma> = (x, h, [])"
(*<*)
apply(simp only: exec_all_def)
apply(erule converse_rtranclE)
 apply simp
apply simp
done
(*>*)

lemma exec_all_deterministic:
  "\<lbrakk> P \<turnstile> \<sigma> -jvm\<rightarrow> (x,h,[]); P \<turnstile> \<sigma> -jvm\<rightarrow> \<sigma>' \<rbrakk> \<Longrightarrow> P \<turnstile> \<sigma>' -jvm\<rightarrow> (x,h,[])"
(*<*)
apply(drule (1) exec_all_conf)
apply(blast dest!: exec_all_finalD)
done
(*>*)

text {*
  The start configuration of the JVM: in the start heap, we call a
  method @{text m} of class @{text C} in program @{text P}. The
  @{text this} pointer of the frame is set to @{text Null} to simulate
  a static method invokation.
*}
definition start_state :: "jvm_prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> jvm_state" where
  "start_state P C M =
  (let (D,Ts,T,mxs,mxl\<^sub>0,b) = method P C M in
    (None, start_heap P, [([], Null # replicate mxl\<^sub>0 undefined, C, M, 0)]))"

end