section "Simplifiying the definition"

theory Evaluate_Clock
imports Evaluate_Termination
begin

hide_const (open) sem_env.v

lemma fix_clock:
  "fix_clock s1 (s2, x) = (s, x) \<Longrightarrow> clock s \<le> clock s1"
  "fix_clock s1 (s2, x) = (s, x) \<Longrightarrow> clock s \<le> clock s2"
unfolding fix_clock_alt_def by auto

lemma dec_clock[simp]: "clock (dec_clock st) = clock st - 1"
unfolding dec_clock_def by auto

context begin

private lemma fun_evaluate_clock0:
  "clock (fst (fun_evaluate_match s1 env v p v')) \<le> clock s1"
  "clock (fst (fun_evaluate s1 env e)) \<le> clock s1"
proof (induction rule: fun_evaluate_match_fun_evaluate.induct)
  case (2 st env e1 e2 es)

  obtain st' r where *[simp]: "fix_clock st (fun_evaluate st env [e1]) = (st', r)"
    by force

  show ?case
    apply (auto split: prod.splits result.splits)
    subgoal
      using 2(2)[OF *[symmetric]]
      by (smt "*" fix_clock(1) fix_clock.simps fst_conv le_trans prod.collapse)
    subgoal
      using 2(2)[OF *[symmetric]]
      by (smt "*" fix_clock(1) fix_clock.simps fst_conv le_trans prod.collapse)
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps prod.collapse prod.sel(2))
    done
next
  case (5 st env e pes)

  obtain st' r where *[simp]: "fix_clock st (fun_evaluate st env [e]) = (st', r)"
    by force

  show ?case
    apply (auto split: prod.splits result.splits)
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps prod.collapse prod.sel(2))
    subgoal
      using 5(2)[OF *[symmetric]]
      by (smt "*" "5.IH"(1) dual_order.trans eq_fst_iff error_result.exhaust error_result.simps(5) error_result.simps(6) fix_clock(2) fix_clock.simps)
    done
next
  case (9 st env op1 es)

  obtain st' r where *[simp]: "fix_clock st (fun_evaluate st env (rev es)) = (st', r)"
    by force

  note do_app.simps[simp del]

  show ?case
    apply (auto split: prod.splits result.splits option.splits if_splits)
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps prod.collapse prod.sel(2))
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps prod.collapse prod.sel(2))
    subgoal
      by (smt "*" "9.IH"(2) One_nat_def Suc_pred dec_clock dual_order.trans fix_clock(1) fix_clock.simps fst_conv le_imp_less_Suc nat_less_le prod.collapse)
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps fst_conv prod.collapse)
    subgoal
      using 9(2)[OF *[symmetric], simplified]
      by (smt "*" Suc_pred dual_order.trans fix_clock(1) fix_clock.simps le_imp_less_Suc less_irrefl_nat nat_le_linear prod.collapse prod.sel(2))
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps prod.collapse prod.sel(2))
    subgoal
      using 9(2)[OF *[symmetric], simplified]
      by (smt "*" Suc_pred dual_order.trans fix_clock(1) fix_clock.simps le_imp_less_Suc less_irrefl_nat nat_le_linear prod.collapse prod.sel(2))
    done
next
  case (10 st env lop e1 e2)

  obtain st' r where *[simp]: "fix_clock st (fun_evaluate st env [e1]) = (st', r)"
    by force

  show ?case
    apply (auto split: prod.splits result.splits option.splits exp_or_val.splits)
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps fst_conv prod.collapse)
    subgoal
      using 10(2)[OF *[symmetric]]
      by (metis (no_types, lifting) "*" dual_order.trans fix_clock(1) fix_clock.simps fstI prod.collapse)
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps prod.collapse snd_conv)
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps fst_conv prod.exhaust_sel)
    done
next
  case (11 st env e1 e2 e3)

  obtain st' r where *[simp]: "fix_clock st (fun_evaluate st env [e1]) = (st', r)"
    by force

  show ?case
    apply (auto split: prod.splits result.splits option.splits)
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps fst_conv prod.collapse)
    subgoal
      using 11(2)[OF *[symmetric]]
      by (metis (no_types, lifting) "*" dual_order.trans eq_fst_iff fix_clock(1) fix_clock.simps)
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps fst_conv prod.exhaust_sel)
    done
next
  case (12 st env e pes)

  obtain st' r where *[simp]: "fix_clock st (fun_evaluate st env [e]) = (st', r)"
    by force

  show ?case
    apply (auto split: prod.splits result.splits option.splits)
    subgoal
      using 12(2)[OF *[symmetric]]
      by (metis (no_types, lifting) "*" dual_order.trans eq_fst_iff fix_clock(1) fix_clock.simps)
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps fst_conv prod.exhaust_sel)
    done
next
  case (13 st env xo e1 e2)

  obtain st' r where *[simp]: "fix_clock st (fun_evaluate st env [e1]) = (st', r)"
    by force

  show ?case
    apply (auto split: prod.splits result.splits option.splits)
    subgoal
      using 13(2)[OF *[symmetric]]
      by (metis (no_types, lifting) "*" dual_order.trans eq_fst_iff fix_clock(1) fix_clock.simps)
    subgoal
      by (metis "*" fix_clock(1) fix_clock.simps fst_conv prod.exhaust_sel)
    done
qed (auto split: prod.splits result.splits option.splits match_result.splits)

lemma fun_evaluate_clock:
  "fun_evaluate_match s1 env v p v' = (s2, r) \<Longrightarrow> clock s2 \<le> clock s1"
  "fun_evaluate s1 env e = (s2, r) \<Longrightarrow> clock s2 \<le> clock s1"
using fun_evaluate_clock0 by (metis fst_conv)+

end

lemma fix_clock_evaluate[simp]:
  "fix_clock s1 (fun_evaluate s1 env e) = fun_evaluate s1 env e"
unfolding fix_clock_alt_def
using fun_evaluate_clock by (fastforce split: prod.splits)

declare fun_evaluate.simps[simp del]
declare fun_evaluate_match.simps[simp del]

lemmas fun_evaluate_simps[simp] =
  fun_evaluate.simps[unfolded fix_clock_evaluate]
  fun_evaluate_match.simps[unfolded fix_clock_evaluate]

lemmas fun_evaluate_induct =
  fun_evaluate_match_fun_evaluate.induct[unfolded fix_clock_evaluate]

lemma fun_evaluate_length:
  "fun_evaluate_match s env v pes err_v = (s', res) \<Longrightarrow> (case res of Rval vs \<Rightarrow> length vs = 1 | _ \<Rightarrow> True)"
  "fun_evaluate s env es = (s', res) \<Longrightarrow> (case res of Rval vs \<Rightarrow> length vs = length es | _ \<Rightarrow> True)"
proof (induction arbitrary: s' res and s' res rule: fun_evaluate_match_fun_evaluate.induct)
  case (9 st env op1 es)
  then show ?case
    supply do_app.simps[simp del]
    apply (fastforce
        split: if_splits prod.splits result.splits option.splits exp_or_val.splits match_result.splits error_result.splits
        simp: list_result_alt_def)
    done
qed (fastforce
      split: if_splits prod.splits result.splits option.splits exp_or_val.splits
             match_result.splits error_result.splits)+

lemma fun_evaluate_matchE:
  assumes "fun_evaluate_match s env v pes err_v = (s', Rval vs)"
  obtains v where "vs = [v]"
using fun_evaluate_length(1)[OF assms]
by (cases vs) auto

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "Additional Syntax for Word Bit Operations"

theory Word_Syntax
imports
  "HOL-Word.More_Word"
  WordBitwise_Signed
  Hex_Words
  Norm_Words
  Word_Type_Syntax
begin

text \<open>Additional bit and type syntax that forces word types.\<close>

type_synonym word8 = "8 word"
type_synonym word16 = "16 word"
type_synonym word32 = "32 word"
type_synonym word64 = "64 word"

lemma len8: "len_of (x :: 8 itself) = 8" by simp
lemma len16: "len_of (x :: 16 itself) = 16" by simp
lemma len32: "len_of (x :: 32 itself) = 32" by simp
lemma len64: "len_of (x :: 64 itself) = 64" by simp

abbreviation
  wordNOT  :: "'a::len0 word \<Rightarrow> 'a word"      ("~~ _" [70] 71)
where
  "~~ x == NOT x"

abbreviation
  wordAND  :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "&&" 64)
where
  "a && b == a AND b"

abbreviation
  wordOR   :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "||"  59)
where
  "a || b == a OR b"

abbreviation
  wordXOR  :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "xor" 59)
where
  "a xor b == a XOR b"

(* testing for presence of word_bitwise *)
lemma "((x :: word32) >> 3) AND 7 = (x AND 56) >> 3"
  by word_bitwise

(* FIXME: move to Word distribution *)
lemma bin_nth_minus_Bit0[simp]:
  "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit0 w)) n = bin_nth (numeral w) (n - 1)"
  by (cases n; simp)

lemma bin_nth_minus_Bit1[simp]:
  "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit1 w)) n = bin_nth (numeral w) (n - 1)"
  by (cases n; simp)

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Early_Bisim_Pres
  imports Strong_Early_Bisim Strong_Early_Sim_Pres
begin

(************* Preservation rules *************)

lemma tauPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim> Q"

  shows "\<tau>.(P) \<sim> \<tau>.(Q)"
proof -
  let ?X = "{(\<tau>.(P), \<tau>.(Q)) | P Q. P \<sim> Q}"
  from `P \<sim> Q` have "(\<tau>.(P), \<tau>.(Q)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: tauPres dest: bisimE)
qed

lemma inputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   x :: name

  assumes PSimQ: "\<forall>y. P[x::=y] \<sim> Q[x::=y]"

  shows "a<x>.P \<sim> a<x>.Q"
proof -
  let ?X = "{(a<x>.P, a<x>.Q) | a x P Q. \<forall>y. P[x::=y] \<sim> Q[x::=y]}"
  {
    fix axP axQ p
    assume "(axP, axQ) \<in> ?X"
    then obtain a x P Q where A: "\<forall>y. P[x::=y] \<sim> Q[x::=y]" and B: "axP = a<x>.P" and C: "axQ = a<x>.Q"
      by auto
    have "\<And>y. ((p::name prm) \<bullet> P)[(p \<bullet> x)::=y] \<sim> (p \<bullet> Q)[(p \<bullet> x)::=y]"
    proof -
      fix y
      from A have "P[x::=(rev p \<bullet> y)] \<sim> Q[x::=(rev p \<bullet> y)]"
        by blast
      hence "(p \<bullet> (P[x::=(rev p \<bullet> y)])) \<sim> p \<bullet> (Q[x::=(rev p \<bullet> y)])"
        by(rule bisimClosed)
      thus "(p \<bullet> P)[(p \<bullet> x)::=y] \<sim> (p \<bullet> Q)[(p \<bullet> x)::=y]"
        by(simp add: eqvts pt_pi_rev[OF pt_name_inst, OF at_name_inst])
    qed
    hence "((p::name prm) \<bullet> axP, p \<bullet> axQ) \<in> ?X" using B C
      by auto
  }
  hence "eqvt ?X" by(simp add: eqvt_def)
  from PSimQ have "(a<x>.P, a<x>.Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim P Q)
    thus ?case using `eqvt ?X`
      by(force intro: inputPres)
  next
    case(cSym P Q)
    thus ?case
      by(blast dest: bisimE)
  qed
qed

lemma outputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<sim> Q"

  shows "a{b}.P \<sim> a{b}.Q"
proof -
  let ?X = "{(a{b}.P, a{b}.Q) | a b P Q. P \<sim> Q}"
  from `P \<sim> Q` have "(a{b}.P, a{b}.Q) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (blast intro: outputPres dest: bisimE)+
qed

  assumes "P \<sim> Q"

  shows "[a\<frown>b]P \<sim> [a\<frown>b]Q"
proof -
  let ?X = "{x. \<exists>P Q a b. P \<sim> Q \<and> x = ([a\<frown>b]P, [a\<frown>b]Q)}"
  from assms have "([a\<frown>b]P, [a\<frown>b]Q) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (blast intro: matchPres dest: bisimE)+
qed

lemma mismatchPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<sim> Q"

  shows "[a\<noteq>b]P \<sim> [a\<noteq>b]Q"
proof -
  let ?X = "{x. \<exists>P Q a b. P \<sim> Q \<and> x = ([a\<noteq>b]P, [a\<noteq>b]Q)}"
  from assms have "([a\<noteq>b]P, [a\<noteq>b]Q) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (blast intro: mismatchPres dest: bisimE)+
qed

lemma sumPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<sim> Q"

  shows "P \<oplus> R \<sim> Q \<oplus> R"
proof -
  let ?X = "{(P \<oplus> R, Q \<oplus> R) | P Q R. P \<sim> Q}"
  from assms have "(P \<oplus> R, Q \<oplus> R) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto dest: bisimE intro: reflexive sumPres)
qed

  shows "<\<nu>x>P \<sim> <\<nu>x>Q"
proof -
  let ?X = "{x. \<exists>P Q. P \<sim> Q \<and> (\<exists>a. x = (<\<nu>a>P, <\<nu>a>Q))}"
  from assms have "(<\<nu>x>P, <\<nu>x>Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim xP xQ)
    moreover {
      fix P Q a
      assume "P \<sim> Q"
      hence "P \<leadsto>[bisim] Q" by(rule bisimE)
      moreover have "\<And>P Q a. P \<sim> Q \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> ?X \<union> bisim" by blast
      moreover have "bisim \<subseteq> ?X \<union> bisim" by blast
      moreover have "eqvt bisim" by(rule eqvt)
      moreover have "eqvt (?X \<union> bisim)" using eqvts
        by(auto simp add: eqvt_def) blast
      ultimately have "<\<nu>a>P \<leadsto>[(?X \<union> bisim)] <\<nu>a>Q"
        by(rule Strong_Early_Sim_Pres.resPres)
    }
    ultimately show ?case by auto
  next
    case(cSym xP xQ)
    thus ?case by(auto dest: bisimE)
  qed
qed

lemma parPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi
  and   T :: pi

  assumes "P \<sim> Q"

  shows "P \<parallel> R \<sim> Q \<parallel> R"
proof -
  let ?X = "{(resChain lst (P \<parallel> R), resChain lst (Q \<parallel> R)) | lst P Q R. P \<sim> Q}"
  have BC: "\<And>P Q. P \<parallel> Q = resChain [] (P \<parallel> Q)" by auto
  from assms have "(P \<parallel> R, Q \<parallel> R) \<in> ?X" by(blast intro: BC)
  thus ?thesis
  proof(coinduct rule: bisimWeakCoinduct)
    case(cSim PR QR)
    moreover {
      fix lst P Q R
      assume "P \<sim> Q"
      have "eqvt ?X" using eqvts by(auto simp add: eqvt_def) blast
      moreover have Res: "\<And>P Q x. (P, Q) \<in> ?X \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?X"
        by(auto, rule_tac x="x#lst" in exI) auto
      moreover {
        from `P \<sim> Q` have "P \<leadsto>[bisim] Q" by(rule bisimE)
        moreover note `P \<sim> Q`
        moreover have "\<And>P Q R. P \<sim> Q \<Longrightarrow> (P \<parallel> R, Q \<parallel> R) \<in> ?X"
          by(blast intro: BC)
        ultimately have "P \<parallel> R \<leadsto>[?X] Q \<parallel> R" using Res
          by(rule parPres)
      }

      ultimately have "resChain lst (P \<parallel> R) \<leadsto>[?X] resChain lst (Q \<parallel> R)"
        by(rule resChainI)
    }
    ultimately show ?case by auto
  next
    case(cSym P Q)
    thus ?case by(auto dest: bisimE)
  qed
qed

lemma bangRelBisimE:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes A:   "(P, Q) \<in> bangRel Rel"
  and     Sym: "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> (Q, P) \<in> Rel"

  shows "(Q, P) \<in> bangRel Rel"
proof -
  from A show ?thesis
  proof(induct)
    fix P Q
    assume "(P, Q) \<in> Rel"
    hence "(Q, P) \<in> Rel" by(rule Sym)
    thus "(!Q, !P) \<in> bangRel Rel" by(rule BRBang)
  next
    fix P Q R T
    assume RRelT: "(R, T) \<in> Rel"
    assume IH: "(Q, P) \<in> bangRel Rel"
    from RRelT have "(T, R) \<in> Rel" by(rule Sym)
    thus "(T \<parallel> Q, R \<parallel> P) \<in> bangRel Rel" using IH by(rule BRPar)
  next
    fix P Q a
    assume "(Q, P) \<in> bangRel Rel"
    thus "(<\<nu>a>Q, <\<nu>a>P) \<in> bangRel Rel" by(rule BRRes)
  qed
qed

  assumes PBiSimQ: "P \<sim> Q"

  shows "!P \<sim> !Q"
proof -
  let ?X = "bangRel bisim"
    from PBiSimQ have "(!P, !Q) \<in> ?X" by(rule BRBang)
    thus ?thesis
    proof(coinduct rule: bisimWeakCoinduct)
      case(cSim bP bQ)
      {
        fix P Q
        assume "(P, Q) \<in> ?X"
        hence "P \<leadsto>[?X] Q"
        proof(induct)
          fix P Q
          assume "P \<sim> Q"
          thus "!P \<leadsto>[?X] !Q" using bisimE(1) eqvt
            by(rule Strong_Early_Sim_Pres.bangPres)
        next
          fix P Q R T
          assume RBiSimT: "R \<sim> T"
          assume PBangRelQ: "(P, Q) \<in> ?X"
          assume PSimQ: "P \<leadsto>[?X] Q"
          from RBiSimT  have "R \<leadsto>[bisim] T" by(blast dest: bisimE)
          thus "R \<parallel> P \<leadsto>[?X] T \<parallel> Q" using PSimQ RBiSimT PBangRelQ BRPar BRRes eqvt eqvtBangRel
            by(blast intro: Strong_Early_Sim_Pres.parCompose)
        next
          fix P Q a
          assume "P \<leadsto>[?X] Q"
          moreover from eqvtBangRel eqvt have "eqvt ?X" by blast
          ultimately show "<\<nu>a>P \<leadsto>[?X] <\<nu>a>Q" using BRRes by(blast intro: Strong_Early_Sim_Pres.resPres)
        qed
      }
      with `(bP, bQ) \<in> ?X` show ?case by blast
    next
      case(cSym bP bQ)
      thus ?case by(metis bangRelSymetric bisimE)
  qed
qed

end


(*  Title:       Conflict analysis/Operational Semantics
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
section "Operational Semantics"
theory Semantics
imports Main Flowgraph "HOL-Library.Multiset" LTS Interleave ThreadTracking
begin
text_raw \<open>\label{thy:Semantics}\<close>

subsection "Configurations and labels"
text \<open>
  The state of a single thread is described by a stack of control nodes. The top node is the current control node and the nodes deeper in the stack are stored return addresses.
  The configuration of a whole program is described by a multiset of stacks.

  Note that we model stacks as lists here, the first element being the top element.
\<close>
type_synonym 'n conf = "('n list) multiset"

text \<open>
  A step is labeled according to the executed edge. Additionally, we introduce a label for a procedure return step, that has no corresponding edge.
\<close>
datatype ('p,'ba) label = LBase 'ba | LCall 'p | LRet | LSpawn 'p

subsection \<open>Monitors\<close>
text \<open>
  The following defines the monitors of nodes, stacks, configurations, step labels and paths (sequences of step labels)
\<close>
definition
  \<comment> \<open>The monitors of a node are the monitors the procedure of the node synchronizes on\<close>
  "mon_n fg n == mon fg (proc_of fg n)"

definition
  \<comment> \<open>The monitors of a stack are the monitors of all its nodes\<close>
  "mon_s fg s == \<Union> { mon_n fg n | n . n \<in> set s }"

definition
  \<comment> \<open>The monitors of a configuration are the monitors of all its stacks\<close>
  "mon_c fg c == \<Union> { mon_s fg s | s . s \<in># c }"

\<comment> \<open>The monitors of a step label are the monitors of procedures that are called by this step\<close>
definition mon_e :: "('b, 'c, 'd, 'a, 'e) flowgraph_rec_scheme \<Rightarrow> ('c, 'f) label \<Rightarrow> 'a set" where
  "mon_e fg e = (case e of (LCall p) \<Rightarrow> mon fg p | _ \<Rightarrow> {})"

lemma mon_e_simps [simp]:
  "mon_e fg (LBase a) = {}"
  "mon_e fg (LCall p) = mon fg p"
  "mon_e fg (LRet) = {}"
  "mon_e fg (LSpawn p) = {}"
  by (simp_all add: mon_e_def)

\<comment> \<open>The monitors of a path are the monitors of all procedures that are called on the path\<close>
definition
  "mon_w fg w == \<Union> { mon_e fg e | e. e \<in> set w}"

lemma mon_s_alt: "mon_s fg s == \<Union> (mon fg ` proc_of fg ` set s)"
  by (unfold mon_s_def mon_n_def) (auto intro!: eq_reflection)
lemma mon_c_alt: "mon_c fg c == \<Union> (mon_s fg ` set_mset c)"
  by (unfold mon_c_def set_mset_def) (auto intro!: eq_reflection)
lemma mon_w_alt: "mon_w fg w == \<Union> (mon_e fg ` set w)"
  by (unfold mon_w_def) (auto intro!: eq_reflection)

lemma mon_sI: "\<lbrakk>n\<in>set s; m\<in>mon_n fg n\<rbrakk> \<Longrightarrow> m\<in>mon_s fg s"
  by (unfold mon_s_def, auto)
lemma mon_sD: "m\<in>mon_s fg s \<Longrightarrow> \<exists>n\<in>set s. m\<in>mon_n fg n"
  by (unfold mon_s_def, auto)

lemma mon_n_same_proc:
  "proc_of fg n = proc_of fg n' \<Longrightarrow> mon_n fg n = mon_n fg n'"
  by (unfold mon_n_def, simp)
lemma mon_s_same_proc:
  "proc_of fg ` set s = proc_of fg ` set s' \<Longrightarrow> mon_s fg s = mon_s fg s'"
  by (unfold mon_s_alt, simp)

lemma (in flowgraph) mon_of_entry[simp]: "mon_n fg (entry fg p) = mon fg p"
  by (unfold mon_n_def, simp add: entry_valid)
lemma (in flowgraph) mon_of_ret[simp]: "mon_n fg (return fg p) = mon fg p"
  by (unfold mon_n_def, simp add: return_valid)

lemma mon_c_single[simp]: "mon_c fg {#s#} = mon_s fg s"
  by (unfold mon_c_def) auto
lemma mon_s_single[simp]: "mon_s fg [n] = mon_n fg n"
  by (unfold mon_s_def) auto
lemma mon_s_empty[simp]: "mon_s fg [] = {}"
  by (unfold mon_s_def) auto
lemma mon_c_empty[simp]: "mon_c fg {#} = {}"
  by (unfold mon_c_def) auto

lemma mon_s_unconc: "mon_s fg (a@b) = mon_s fg a \<union> mon_s fg b"
  by (unfold mon_s_def) auto
lemma mon_s_uncons[simp]: "mon_s fg (a#as) = mon_n fg a \<union> mon_s fg as"
  by (rule mon_s_unconc[where a="[a]", simplified])

lemma mon_c_union_conc: "mon_c fg (a+b) = mon_c fg a \<union> mon_c fg b"
  by (unfold mon_c_def) auto

lemma mon_c_add_mset_unconc: "mon_c fg (add_mset x b) = mon_s fg x \<union> mon_c fg b"
  by (unfold mon_c_def) auto

lemmas mon_c_unconc = mon_c_union_conc mon_c_add_mset_unconc

lemma mon_cI: "\<lbrakk>s \<in># c; m\<in>mon_s fg s\<rbrakk> \<Longrightarrow> m\<in>mon_c fg c"
  by (unfold mon_c_def, auto)
lemma mon_cD: "\<lbrakk>m\<in>mon_c fg c\<rbrakk> \<Longrightarrow> \<exists>s. s \<in># c \<and> m\<in>mon_s fg s"
  by (unfold mon_c_def, auto)

lemma mon_s_mono: "set s \<subseteq> set s' \<Longrightarrow> mon_s fg s \<subseteq> mon_s fg s'"
  by (unfold mon_s_def) auto
lemma mon_c_mono: "c\<subseteq>#c' \<Longrightarrow> mon_c fg c \<subseteq> mon_c fg c'"
  by (unfold mon_c_def) (auto dest: mset_subset_eqD)

lemma mon_w_empty[simp]: "mon_w fg [] = {}"
  by (unfold mon_w_def, auto)
lemma mon_w_single[simp]: "mon_w fg [e] = mon_e fg e"
  by (unfold mon_w_def, auto)
lemma mon_w_unconc: "mon_w fg (wa@wb) = mon_w fg wa \<union> mon_w fg wb"
  by (unfold mon_w_def) auto
lemma mon_w_uncons[simp]: "mon_w fg (e#w) = mon_e fg e \<union> mon_w fg w"
  by (rule mon_w_unconc[where wa="[e]", simplified])
lemma mon_w_ileq: "w\<preceq>w' \<Longrightarrow> mon_w fg w \<subseteq> mon_w fg w'"
  by (induct rule: less_eq_list_induct) auto

subsection \<open>Valid configurations\<close>
text_raw \<open>\label{sec:Semantics:validity}\<close>
text \<open>We call a configuration {\em valid} if each monitor is owned by at most one thread.\<close>
definition
  "valid fg c == \<forall>s s'. {#s, s'#} \<subseteq># c \<longrightarrow> mon_s fg s \<inter> mon_s fg s' = {}"

lemma valid_empty[simp, intro!]: "valid fg {#}"
  by (unfold valid_def, auto)

lemma valid_single[simp, intro!]: "valid fg {#s#}"
  by (unfold valid_def subset_mset_def) auto

lemma valid_split1:
  "valid fg (c+c') \<Longrightarrow> valid fg c \<and> valid fg c' \<and> mon_c fg c \<inter> mon_c fg c' = {}"
  apply (unfold valid_def)
  apply (auto simp add: mset_le_incr_right)
  apply (drule mon_cD)+
  apply auto
  apply (subgoal_tac "{#s#}+{#sa#} \<subseteq># c+c'")
  apply (auto dest!: multi_member_split)
  done

lemma valid_split2:
  "\<lbrakk>valid fg c; valid fg c'; mon_c fg c \<inter> mon_c fg c' = {}\<rbrakk> \<Longrightarrow> valid fg (c+c')"
  apply (unfold valid_def)
  apply (intro impI allI)
  apply (erule mset_2dist2_cases)
  apply simp_all
  apply (blast intro: mon_cI)+
  done

lemma valid_union_conc:
  "valid fg (c+c') \<longleftrightarrow> (valid fg c \<and> valid fg c' \<and> mon_c fg c \<inter> mon_c fg c' = {})"
  by (blast dest: valid_split1 valid_split2)

lemma valid_add_mset_conc:
  "valid fg (add_mset x c') \<longleftrightarrow> (valid fg c' \<and> mon_s fg x \<inter> mon_c fg c' = {})"
  unfolding add_mset_add_single[of x c'] valid_union_conc by (auto simp: mon_s_def)

lemmas valid_unconc = valid_union_conc valid_add_mset_conc

lemma valid_no_mon: "mon_c fg c = {} \<Longrightarrow> valid fg c"
proof (unfold valid_def, intro allI impI)
  fix s s'
  assume A: "mon_c fg c = {}" and B: "{#s, s'#} \<subseteq># c"
  from mon_c_mono[OF B, of fg] A have "mon_s fg s = {}" "mon_s fg s' = {}" by (auto simp add: mon_c_unconc)
  thus "mon_s fg s \<inter> mon_s fg s' = {}" by blast
qed

subsection \<open>Configurations at control points\<close>

\<comment> \<open>A stack is {\em at} @{term U} if its top node is from the set @{term U}\<close>
primrec atU_s :: "'n set \<Rightarrow> 'n list \<Rightarrow> bool" where
  "atU_s U [] = False"
| "atU_s U (u#r) = (u\<in>U)"

lemma atU_s_decomp[simp]: "atU_s U (s@s') = (atU_s U s \<or> (s=[] \<and> atU_s U s'))"
  by (induct s) auto

\<comment> \<open>A configuration is {\em at} @{term U} if it contains a stack that is at @{term U}\<close>
definition
  "atU U c == \<exists>s. s \<in># c \<and> atU_s U s"

lemma atU_fmt: "\<lbrakk>atU U c; !!ui r. \<lbrakk>ui#r \<in># c; ui\<in>U\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  apply (unfold atU_def)
  apply auto
  apply (case_tac s)
  apply auto
  done

lemma atU_union_cases[case_names left right, consumes 1]: "\<lbrakk>
    atU U (c1+c2);
    atU U c1 \<Longrightarrow> P;
    atU U c2 \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  by (unfold atU_def) (blast elim: mset_un_cases)

lemma atU_union[simp]: "atU U (c1+c2) = (atU U c1 \<or> atU U c2)"
  by (auto simp add: atU_add elim: atU_union_cases)

lemma atU_empty[simp]: "\<not>atU U {#}"
  by (unfold atU_def, auto)
lemma atU_single[simp]: "atU U {#s#} = atU_s U s"
  by (unfold atU_def, auto)

lemma atU_add_mset[simp]: "atU U (add_mset c c2) = (atU_s U c \<or> atU U c2)"
  unfolding add_mset_add_single[of c c2] atU_union by auto

lemma atU_xchange_stack: "atU U (add_mset (u#r) c) \<Longrightarrow> atU U (add_mset (u#r') c)"
  by (simp)

\<comment> \<open>A configuration is {\em simultaneously at} @{term U} and @{term V} if it contains a stack at @{term U} and another one at @{term V}\<close>
definition
  "atUV U V c == \<exists>su sv. {#su#}+{#sv#} \<subseteq># c \<and> atU_s U su \<and> atU_s V sv"

lemma atUV_empty[simp]: "\<not>atUV U V {#}"
  by (unfold atUV_def) auto
lemma atUV_single[simp]: "\<not>atUV U V {#s#}"
  by (unfold atUV_def) auto

lemma atUV_union[simp]: "
  atUV U V (c1+c2) \<longleftrightarrow>
  (
    (atUV U V c1) \<or>
    (atUV U V c2) \<or>
    (atU U c1 \<and> atU V c2) \<or>
    (atU V c1 \<and> atU U c2)
  )"
  apply (unfold atUV_def atU_def)
  apply (auto elim!: mset_2dist2_cases intro: mset_le_incr_right iff add: mset_le_mono_add_single)
  apply (subst union_commute)
  apply (auto iff add: mset_le_mono_add_single)
  done

lemma atUV_add_mset[simp]: "
  atUV U V (add_mset c c2) \<longleftrightarrow>
  (
    (atUV U V c2) \<or>
    (atU U {#c#} \<and> atU V c2) \<or>
    (atU V {#c#} \<and> atU U c2)
  )"
  unfolding add_mset_add_single[of c c2]
  unfolding atUV_union
  by auto

lemma atUV_union_cases[case_names left right lr rl, consumes 1]: "\<lbrakk>
    atUV U V (c1+c2);
    atUV U V c1 \<Longrightarrow> P;
    atUV U V c2 \<Longrightarrow> P;
    \<lbrakk>atU U c1; atU V c2\<rbrakk> \<Longrightarrow> P;
    \<lbrakk>atU V c1; atU U c2\<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  by auto

subsection \<open>Operational semantics\<close>

subsubsection "Semantic reference point"
text \<open>We now define our semantic reference point. We assess correctness and completeness of analyses relative to this reference point.\<close>
inductive_set
  refpoint :: "('n,'p,'ba,'m,'more) flowgraph_rec_scheme \<Rightarrow>
                 ('n conf \<times> ('p,'ba) label \<times> 'n conf) set"
  for fg
where
  \<comment> \<open>A base edge transforms the top node of one stack and leaves the other stacks untouched.\<close>
  refpoint_base: "\<lbrakk> (u,Base a,v)\<in>edges fg; valid fg ({#u#r#}+c) \<rbrakk>
    \<Longrightarrow> (add_mset (u#r) c,LBase a,add_mset (v#r) c)\<in>refpoint fg" |
  \<comment> \<open>A call edge transforms the top node of a stack and then pushes the entry node of the called procedure onto that stack.
      It can only be executed if all monitors the called procedure synchronizes on are available. Reentrant monitors are modeled here by
      checking availability of monitors just against the other stacks, not against the stack of the thread that executes the call. The other stacks are left untouched.\<close>
  refpoint_call: "\<lbrakk> (u,Call p,v)\<in>edges fg; valid fg ({#u#r#}+c);
                    mon fg p \<inter> mon_c fg c = {} \<rbrakk>
    \<Longrightarrow> (add_mset (u#r) c,LCall p, add_mset (entry fg p#v#r) c)\<in>refpoint fg" |
  \<comment> \<open>A return step pops a return node from a stack. There is no corresponding flowgraph edge for a return step. The other stacks are left untouched.\<close>
  refpoint_ret: "\<lbrakk> valid fg ({#return fg p#r#}+c) \<rbrakk>
    \<Longrightarrow> (add_mset (return fg p#r) c,LRet,(add_mset r c))\<in>refpoint fg" |
  \<comment> \<open>A spawn edge transforms the top node of a stack and adds a new stack to the environment, with the entry node of the spawned procedure at the top and no stored return addresses. The other stacks are also left untouched.\<close>
  refpoint_spawn: "\<lbrakk> (u,Spawn p,v)\<in>edges fg; valid fg (add_mset (u#r) c) \<rbrakk>
    \<Longrightarrow> (add_mset (u#r) c,LSpawn p, add_mset (v#r) (add_mset [entry fg p] c))\<in>refpoint fg"

text \<open>
  Instead of working directly with the reference point semantics, we define the operational semantics of flowgraphs by describing how a single stack is transformed in a context of environment threads,
  and then use the theory developed in Section~\ref{thy:ThreadTracking} to derive an interleaving semantics.
  Note that this semantics is also defined for invalid configurations (cf. Section~\ref{sec:Semantics:validity}). In Section~\ref{sec:Semantics:valid_preserve} we will show that it preserves validity
  of a configuration, and in Section~\ref{sec:Semantics: refpoint_eq} we show that it is equivalent
  to the reference point semantics on valid configurations.
\<close>

inductive_set
  trss :: "('n,'p,'ba,'m,'more) flowgraph_rec_scheme \<Rightarrow>
             (('n list * 'n conf) * ('p,'ba) label * ('n list * 'n conf)) set"
  for fg
  where
    trss_base: "\<lbrakk>(u,Base a,v)\<in>edges fg\<rbrakk> \<Longrightarrow>
      ((u#r,c), LBase a, (v#r,c) ) \<in> trss fg"
  | trss_call: "\<lbrakk>(u,Call p,v)\<in>edges fg; mon fg p \<inter> mon_c fg c = {} \<rbrakk> \<Longrightarrow>
    ((u#r,c),LCall p, ((entry fg p)#v#r,c)) \<in> trss fg"
  | trss_ret: "((((return fg p)#r),c),LRet,(r,c)) \<in> trss fg"
  | trss_spawn: "\<lbrakk> (u,Spawn p,v)\<in>edges fg \<rbrakk> \<Longrightarrow>
    ((u#r,c),LSpawn p,(v#r,add_mset [entry fg p] c)) \<in> trss fg"

(* Not needed
lemma trss_base': "\<lbrakk>(u,Base a,v)\<in>edges fg; s=u#r; s'=v#r; e=LBase a\<rbrakk> \<Longrightarrow> ((s,c), e, (s',c) ) \<in> trss fg"
  by (simp add: trss_base)
lemma trss_call': "\<lbrakk>(u,Call p,v)\<in>edges fg; mon fg p \<inter> mon_c fg c = {}; s=u#r; e=LCall p; s'=(entry fg p)#v#r\<rbrakk> \<Longrightarrow> ((s,c),e, (s',c)) \<in> trss fg"
  by (simp add: trss_call)
lemma trss_ret': "\<lbrakk> s=(return fg p)#r; e=LRet \<rbrakk> \<Longrightarrow> ((s,c),e,(r,c)) \<in> trss fg"
  by (simp add: trss_ret)
lemma trss_spawn': "\<lbrakk> (u,Spawn p,v)\<in>edges fg; s=u#r; e=LSpawn p; s'=v#r; c'={#[entry fg p]#}+c\<rbrakk> \<Longrightarrow> ((s,c),e,(s',c')) \<in> trss fg"
  by (simp add: trss_spawn)
*)

\<comment> \<open>The interleaving semantics is generated using the general techniques from Section~\ref{thy:ThreadTracking}\<close>
abbreviation tr where "tr fg == gtr (trss fg)"
\<comment> \<open>We also generate the loc/env-semantics\<close>
abbreviation trp where "trp fg == gtrp (trss fg)"

subsection "Basic properties"
subsubsection "Validity"
text_raw\<open>\label{sec:Semantics:valid_preserve}\<close>
lemma (in flowgraph) trss_valid_preserve_s:
  "\<lbrakk>valid fg (add_mset s c); ((s,c),e,(s',c'))\<in>trss fg\<rbrakk> \<Longrightarrow> valid fg (add_mset s' c')"
  apply (erule trss.cases)
  apply (simp_all add: valid_unconc mon_c_unconc)
by (blast dest: mon_n_same_proc edges_part)+

lemma (in flowgraph) trss_valid_preserve:
  "\<lbrakk>((s,c),w,(s',c'))\<in>trcl (trss fg); valid fg ({#s#}+c)\<rbrakk> \<Longrightarrow> valid fg ({#s'#}+c')"
  by (induct rule: trcl_pair_induct) (auto intro: trss_valid_preserve_s)

lemma (in flowgraph) tr_valid_preserve_s:
  "\<lbrakk>(c,e,c')\<in>tr fg; valid fg c\<rbrakk> \<Longrightarrow> valid fg c'"
  by (rule gtr_preserve_s[where P="valid fg"]) (auto dest: trss_valid_preserve_s)

lemma (in flowgraph) tr_valid_preserve:
  "\<lbrakk>(c,w,c')\<in>trcl (tr fg); valid fg c\<rbrakk> \<Longrightarrow> valid fg c'"
  by (rule gtr_preserve[where P="valid fg"]) (auto dest: trss_valid_preserve_s)

lemma (in flowgraph) trp_valid_preserve_s:
  "\<lbrakk>((s,c),e,(s',c'))\<in>trp fg; valid fg (add_mset s c)\<rbrakk> \<Longrightarrow> valid fg (add_mset s' c')"
  by (rule gtrp_preserve_s[where P="valid fg"]) (auto dest: trss_valid_preserve_s)

lemma (in flowgraph) trp_valid_preserve:
  "\<lbrakk>((s,c),w,(s',c'))\<in>trcl (trp fg); valid fg ({#s#}+c)\<rbrakk> \<Longrightarrow> valid fg (add_mset s' c')"
  by (rule gtrp_preserve[where P="valid fg"]) (auto dest: trss_valid_preserve_s)

subsubsection "Equivalence to reference point"
text_raw \<open>\label{sec:Semantics: refpoint_eq}\<close>
\<comment> \<open>The equivalence between the semantics that we derived using the techniques from Section~\ref{thy:ThreadTracking} and the semantic reference point is shown nearly automatically.\<close>
lemma refpoint_eq_s: "valid fg c \<Longrightarrow> ((c,e,c')\<in>refpoint fg) \<longleftrightarrow> ((c,e,c')\<in>tr fg)"
  apply rule
  apply (erule refpoint.cases)
      apply (auto intro: gtrI_s trss.intros simp add: union_assoc add_mset_commute)
  apply (erule gtrE)
  apply (erule trss.cases)
  apply (auto intro: refpoint.intros simp add: union_assoc[symmetric] add_mset_commute)
  done

lemma (in flowgraph) refpoint_eq:
  "valid fg c \<Longrightarrow> ((c,w,c')\<in>trcl (refpoint fg)) \<longleftrightarrow> ((c,w,c')\<in>trcl (tr fg))"
proof -
  have "((c,w,c')\<in>trcl (refpoint fg)) \<Longrightarrow> valid fg c \<Longrightarrow> ((c,w,c')\<in>trcl (tr fg))" by (induct rule: trcl.induct) (auto simp add: refpoint_eq_s tr_valid_preserve_s)
  moreover have "((c,w,c')\<in>trcl (tr fg)) \<Longrightarrow> valid fg c \<Longrightarrow> ((c,w,c')\<in>trcl (refpoint fg))" by (induct rule: trcl.induct) (auto simp add: refpoint_eq_s tr_valid_preserve_s)
  ultimately show "valid fg c \<Longrightarrow> ((c,w,c')\<in>trcl (refpoint fg)) = ((c,w,c')\<in>trcl (tr fg))" ..
qed

subsubsection \<open>Case distinctions\<close>

lemma trss_c_cases_s[cases set, case_names no_spawn spawn]: "\<lbrakk>
    ((s,c),e,(s',c'))\<in>trss fg;
    \<lbrakk> c'=c \<rbrakk> \<Longrightarrow> P;
    !!p u v. \<lbrakk> e=LSpawn p; (u,Spawn p,v)\<in>edges fg;
               hd s=u; hd s'=v; c'={#[ entry fg p ]#}+c \<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
by (auto elim!: trss.cases)
lemma trss_c_fmt_s: "\<lbrakk>((s,c),e,(s',c'))\<in>trss fg\<rbrakk>
  \<Longrightarrow> \<exists>csp. c'=csp+c \<and>
        (csp={#} \<or> (\<exists>p. e=LSpawn p \<and> csp={#[ entry fg p ]#}))"
  by (force elim!: trss_c_cases_s)

lemma (in flowgraph) trss_c'_split_s: "\<lbrakk>
    ((s,c),e,(s',c'))\<in>trss fg;
    !!csp. \<lbrakk>c'=csp+c; mon_c fg csp={}\<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  apply (erule trss_c_cases_s)
  apply (subgoal_tac "c'={#}+c")
  apply (fastforce)
  apply auto
  done

lemma trss_c_cases[cases set, case_names c_case]: "!!s c. \<lbrakk>
    ((s,c),w,(s',c'))\<in>trcl (trss fg);
    !!csp. \<lbrakk> c'=csp+c; !!s. s \<in># csp \<Longrightarrow> \<exists>p u v. s=[entry fg p] \<and>
                                               (u,Spawn p,v)\<in>edges fg \<and>
                                               initialproc fg p\<rbrakk>
            \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
proof (induct w)
  case Nil note A=this
  hence "s'=s" "c'=c" by simp_all
  hence "c'={#}+c" by simp
  from A(2)[OF this] show P by simp
next
  case (Cons e w) note IHP=this
  then obtain sh ch where SPLIT1: "((s,c),e,(sh,ch))\<in>trss fg" and SPLIT2: "((sh,ch),w,(s',c'))\<in>trcl (trss fg)" by (fastforce dest: trcl_uncons)
  from SPLIT2 show ?case proof (rule IHP(1))
    fix csp
    assume C'FMT: "c'=csp+ch" and CSPFMT: "!!s. s \<in># csp \<Longrightarrow> \<exists>p u v. s=[entry fg p] \<and> (u,Spawn p, v)\<in>edges fg \<and> initialproc fg p"
    from SPLIT1 show ?thesis
    proof (rule trss_c_cases_s)
      assume "ch=c" with C'FMT CSPFMT IHP(3) show ?case by blast
    next
      fix p
      assume EFMT: "e=LSpawn p" and CHFMT: "ch={#[entry fg p]#}+c"
      with C'FMT have "c'=({#[entry fg p]#}+csp)+c" by (simp add: union_ac)
      moreover
      from EFMT SPLIT1 have "\<exists>u v. (u,Spawn p, v)\<in>edges fg" by (blast elim!: trss.cases)
      hence "!!s. s \<in># {#[entry fg p]#} + csp \<Longrightarrow> \<exists>p u v. s=[entry fg p] \<and> (u,Spawn p, v)\<in>edges fg \<and> initialproc fg p" using CSPFMT by (unfold initialproc_def, erule_tac mset_un_cases) (auto)
      ultimately show ?case using IHP(3) by blast
    qed
  qed
qed

lemma (in flowgraph) c_of_initial_no_mon:
  assumes A: "!!s. s \<in># csp \<Longrightarrow> \<exists>p. s=[entry fg p] \<and> initialproc fg p"
  shows "mon_c fg csp = {}"
  by (unfold mon_c_def) (auto dest: A initial_no_mon)

  (* WARNING: Don't declare this [simp], as c=c' will cause a simplifier loop *)
lemma (in flowgraph) trss_c_no_mon_s:
  assumes A: "((s,c),e,(s',c'))\<in>trss fg"
  shows "mon_c fg c' = mon_c fg c"
  using A
proof (erule_tac trss_c_cases_s)
  assume "c'=c" thus ?thesis by simp
next
  fix p assume EFMT: "e=LSpawn p" and C'FMT: "c'={#[entry fg p]#} + c"
  from EFMT obtain u v where "(u,Spawn p,v)\<in>edges fg" using A by (auto elim: trss.cases)
  with spawn_no_mon have "mon_c fg {#[entry fg p]#} = {}" by simp
  with C'FMT show ?thesis by (simp add: mon_c_unconc)
qed

  (* WARNING: Don't declare this [simp], as c=c' will cause a simplifier loop *)
  (* FIXME: Dirty proof, not very robust *)
corollary (in flowgraph) trss_c_no_mon:
  "((s,c),w,(s',c'))\<in>trcl (trss fg) \<Longrightarrow> mon_c fg c' = mon_c fg c"
  apply (auto elim!: trss_c_cases simp add: mon_c_unconc)
proof -
  fix csp x
  assume "x\<in>mon_c fg csp"
  then obtain s where "s \<in># csp" and M: "x\<in>mon_s fg s" by (unfold mon_c_def, auto)
  moreover assume "\<forall>s. s \<in># csp \<longrightarrow> (\<exists>p. s = [entry fg p] \<and> (\<exists>u v. (u, Spawn p, v) \<in> edges fg) \<and> initialproc fg p)"
  ultimately obtain p u v where "s=[entry fg p]" and "(u,Spawn p,v)\<in>edges fg" by blast
  hence "mon_s fg s = {}" by (simp)
  with M have False by simp
  thus "x\<in>mon_c fg c" ..
qed

lemma (in flowgraph) trss_spawn_no_mon_step[simp]:
  "((s,c),LSpawn p, (s',c'))\<in>trss fg \<Longrightarrow> mon fg p = {}"
  by (auto elim: trss.cases)

lemma trss_no_empty_s[simp]: "(([],c),e,(s',c'))\<in>trss fg = False"
  by (auto elim!: trss.cases)
lemma trss_no_empty[simp]:
  assumes A: "(([],c),w,(s',c'))\<in>trcl (trss fg)"
  shows "w=[] \<and> s'=[] \<and> c=c'"
proof -
  note A
  moreover {
    fix s
    have "((s,c),w,(s',c'))\<in>trcl (trss fg) \<Longrightarrow> s=[] \<Longrightarrow> w=[] \<and> s'=[] \<and> c=c'"
      by (induct rule: trcl_pair_induct) auto
  } ultimately show ?thesis by blast
qed

lemma trs_step_cases[cases set, case_names NO_SPAWN SPAWN]:
  assumes A: "(c,e,c')\<in>tr fg"
  assumes A_NO_SPAWN: "!!s ce s' csp. \<lbrakk>
      ((s,ce),e,(s',ce))\<in>trss fg;
      c={#s#}+ce; c'={#s'#}+ce
    \<rbrakk> \<Longrightarrow> P"
  assumes A_SPAWN: "!!s ce s' p. \<lbrakk>
      ((s,ce),LSpawn p,(s',{#[entry fg p]#}+ce))\<in>trss fg;
      c={#s#}+ce;
      c'={#s'#}+{#[entry fg p]#}+ce;
      e=LSpawn p
    \<rbrakk> \<Longrightarrow> P"
  shows P
proof -
  from A show ?thesis proof (erule_tac gtr_find_thread)
    fix s ce s' ce'
    assume FMT: "c = add_mset s ce" "c' = add_mset s' ce'"
    assume B: "((s, ce), e, s', ce') \<in> trss fg" thus ?thesis proof (cases rule: trss_c_cases_s)
      case no_spawn thus ?thesis using FMT B by (-) (rule A_NO_SPAWN, auto)
    next
      case (spawn p) thus ?thesis using FMT B by (-) (rule A_SPAWN, auto simp add: union_assoc)
    qed
  qed
qed

subsection "Advanced properties"
subsubsection "Stack composition / decomposition"
lemma trss_stack_comp_s:
  "((s,c),e,(s',c'))\<in>trss fg \<Longrightarrow> ((s@r,c),e,(s'@r,c'))\<in>trss fg"
  by (auto elim!: trss.cases intro: trss.intros)

lemma trss_stack_comp:
  "((s,c),w,(s',c'))\<in>trcl (trss fg) \<Longrightarrow> ((s@r,c),w,(s'@r,c'))\<in>trcl (trss fg)"
proof (induct rule: trcl_pair_induct)
  case empty thus ?case by auto
next
  case (cons s c e sh ch w s' c') note IHP=this
  from trss_stack_comp_s[OF IHP(1)] have "((s @ r, c), e, sh @ r, ch) \<in> trss fg" .
  also note IHP(3)
  finally show ?case .
qed

lemma trss_stack_decomp_s: "\<lbrakk> ((s@r,c),e,(s',c'))\<in>trss fg; s\<noteq>[] \<rbrakk>
  \<Longrightarrow> \<exists>sp'. s'=sp'@r \<and> ((s,c),e,(sp',c'))\<in>trss fg"
  by (cases s, simp) (auto intro: trss.intros elim!: trss.cases)

    (* TODO: Try backward induction proof \<dots> is this simpler ? *)
lemma trss_return_cases[cases set]: "!!u r c. \<lbrakk>
    ((u#r,c),w,(r',c'))\<in>trcl (trss fg);
    !! s' u'. \<lbrakk> r'=s'@u'#r; (([u],c),w,(s'@[u'],c'))\<in>trcl (trss fg) \<rbrakk> \<Longrightarrow> P;
    !! wa wb ch. \<lbrakk> w=wa@wb; (([u],c),wa,([],ch))\<in>trcl (trss fg);
                   ((r,ch),wb,(r',c'))\<in>trcl (trss fg) \<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
proof (induct w rule: length_compl_induct)
  case Nil thus ?case by auto
next
  case (Cons e w) note IHP=this
  then obtain sh ch where SPLIT1: "((u#r,c),e,(sh,ch))\<in>trss fg" and SPLIT2: "((sh,ch),w,(r',c'))\<in>trcl (trss fg)" by (fast dest: trcl_uncons)
  {
    fix ba q
    assume CASE: "e=LBase ba \<or> e=LSpawn q"
    with SPLIT1 obtain v where E: "sh=v#r" "(([u],c),e,([v],ch))\<in>trss fg" by (auto elim!: trss.cases intro: trss.intros)
    with SPLIT2 have "((v#r,ch),w,(r',c'))\<in>trcl (trss fg)" by simp
    hence ?case proof (cases rule: IHP(1)[of w, simplified, cases set])
      case (1 s' u') note CC=this
      with E(2) have "(([u],c),e#w,(s'@[u'],c'))\<in>trcl (trss fg)" by simp
      from IHP(3)[OF CC(1) this] show ?thesis .
    next
      case (2 wa wb ct) note CC=this
      with E(2) have "(([u],c),e#wa,([],ct))\<in>trcl (trss fg)" "e#w = (e#wa)@wb" by simp_all
      from IHP(4)[OF this(2,1) CC(3)] show ?thesis .
    qed
  } moreover {
    assume CASE: "e=LRet"
    with SPLIT1 have "sh=r" "(([u],c),[e],([],ch))\<in>trcl (trss fg)" by (auto elim!: trss.cases intro: trss.intros)
    with IHP(4)[OF _ this(2)] SPLIT2 have ?case by auto
  } moreover {
    fix q
    assume CASE: "e=LCall q"
    with SPLIT1 obtain u' where SHFMT: "sh=entry fg q # u' # r" "(([u],c),e,(entry fg q # [u'],ch))\<in>trss fg" by (auto elim!: trss.cases intro: trss.intros)
    with SPLIT2 have "((entry fg q # u' # r,ch),w,(r',c'))\<in>trcl (trss fg)" by simp
    hence ?case proof (cases rule: IHP(1)[of w, simplified, cases set])
      case (1 st ut) note CC=this
      from trss_stack_comp[OF CC(2), where r="[u']"] have "((entry fg q#[u'], ch), w, (st @ [ut]) @ [u'], c') \<in> trcl (trss fg)" by auto
      with SHFMT(2) have "(([u],c),e#w, (st @ [ut]) @ [u'], c') \<in> trcl (trss fg)" by auto
      from IHP(3)[OF _ this] CC(1) show ?thesis by simp
    next
      case (2 wa wb ct) note CC=this
      from trss_stack_comp[OF CC(2), where r="[u']"] have "((entry fg q # [u'], ch), wa, [u'], ct) \<in> trcl (trss fg)" by simp
      with SHFMT have PREPATH: "(([u],c),e#wa, [u'], ct) \<in> trcl (trss fg)" by simp
      from CC have L: "length wb\<le>length w" by simp
      from CC(3) show ?case proof (cases rule: IHP(1)[OF L, cases set])
        case (1 s'' u'') note CCC=this from trcl_concat[OF PREPATH CCC(2)] CC(1) have "(([u],c),e#w,(s''@[u''],c'))\<in>trcl (trss fg)" by (simp)
        from IHP(3)[OF CCC(1) this] show ?thesis .
      next
        case (2 wba wbb c'') note CCC=this from trcl_concat[OF PREPATH CCC(2)] CC(1) CCC(1) have "e#w = (e#wa@wba)@wbb" "(([u], c), e # wa @ wba, [], c'') \<in> trcl (trss fg)" by auto
        from IHP(4)[OF this CCC(3)] show ?thesis .
      qed
    qed
  } ultimately show ?case by (cases e, auto)
qed

lemma (in flowgraph) trss_find_call:
  "!!v r' c'. \<lbrakk> (([sp],c),w,(v#r',c')) \<in> trcl (trss fg); r'\<noteq>[] \<rbrakk>
  \<Longrightarrow> \<exists>rh ch p wa wb.
        w=wa@(LCall p)#wb \<and>
        proc_of fg v = p \<and>
        (([sp],c),wa,(rh,ch))\<in>trcl (trss fg) \<and>
        ((rh,ch),LCall p,((entry fg p)#r',ch))\<in>trss fg \<and>
        (([entry fg p],ch),wb,([v],c'))\<in>trcl (trss fg)"
proof (induct w rule: length_compl_rev_induct)
  case Nil thus ?case by (auto)
next
  case (snoc w e) note IHP=this
  then obtain rh ch where SPLIT1: "(([sp],c),w,(rh,ch))\<in>trcl (trss fg)" and SPLIT2: "((rh,ch),e,(v#r',c'))\<in>trss fg" by (fast dest: trcl_rev_uncons)

  {
    assume "\<exists>u. rh=u#r'"
    then obtain u where RHFMT[simp]: "rh=u#r'" by blast
    with SPLIT2 have "proc_of fg u = proc_of fg v" by (auto elim: trss.cases intro: edges_part)
    moreover from IHP(1)[of w u r' ch, OF _ SPLIT1[simplified] IHP(3)] obtain rt ct p wa wb where
      IHAPP: "w = wa @ LCall p # wb" "proc_of fg u = p" "(([sp], c), wa, (rt, ct)) \<in> trcl (trss fg)" "((rt, ct), LCall p, entry fg p # r', ct) \<in> trss fg"
          "(([entry fg p], ct), wb, ([u], ch)) \<in> trcl (trss fg)" by (blast)
    moreover
    have "(([entry fg p], ct), wb@[e], ([v], c')) \<in> trcl (trss fg)" proof -
      note IHAPP(5)
      also from SPLIT2 have "(([u],ch),e,([v],c')) \<in> trss fg" by (auto elim!: trss.cases intro!: trss.intros)
      finally show ?thesis .
    qed
    moreover from IHAPP have "w@[e] = wa @ LCall p # (wb@[e])" by auto
    ultimately have ?case by auto
  }
  moreover have "(\<exists>u. rh=u#r') \<or> ?case"
  proof (rule trss.cases[OF SPLIT2], simp_all, goal_cases) \<comment> \<open>Cases for base- and spawn edge are discharged automatically\<close>
      \<comment> \<open>Case: call-edge\<close>
    case (1 ca p r u vv) with SPLIT1 SPLIT2 show ?case by fastforce
  next
      \<comment> \<open>Case: return edge\<close>
    case CC: (2 q r ca)
    hence [simp]: "rh=(return fg q)#v#r'" by simp
    with IHP(1)[of w "(return fg q)" "v#r'" ch, OF _ SPLIT1[simplified]] obtain rt ct wa wb where
      IHAPP: "w = wa @ LCall q # wb" "(([sp], c), wa, rt, ct) \<in> trcl (trss fg)" "((rt, ct), LCall q, entry fg q # v # r', ct) \<in> trss fg"
          "(([entry fg q], ct), wb, [return fg q], ch) \<in> trcl (trss fg)" by force
    then obtain u where RTFMT [simp]: "rt=u#r'" and PROC_OF_U: "proc_of fg u = proc_of fg v" by (auto elim: trss.cases intro: edges_part)
    from IHAPP(1) have LENWA: "length wa \<le> length w" by auto
    from IHP(1)[OF LENWA IHAPP(2)[simplified] IHP(3)] obtain rhh chh p waa wab where
      IHAPP': "wa=waa@LCall p # wab" "proc_of fg u = p" "(([sp],c),waa,(rhh,chh))\<in>trcl (trss fg)" "((rhh,chh),LCall p, (entry fg p#r',chh))\<in>trss fg"
          "(([entry fg p],chh),wab,([u],ct))\<in>trcl (trss fg)"
      by blast
    from IHAPP IHAPP' PROC_OF_U have "w@[e]=waa@LCall p#(wab@LCall q#wb@[e]) \<and> proc_of fg v = p" by auto
    moreover have "(([entry fg p],chh),wab@(LCall q)#wb@[e],([v],c'))\<in>trcl (trss fg)" proof -
      note IHAPP'(5)
      also from IHAPP have "(([u], ct), LCall q, entry fg q # [v], ct) \<in> trss fg" by (auto elim!: trss.cases intro!: trss.intros)
      also from trss_stack_comp[OF IHAPP(4)] have "((entry fg q#[v],ct),wb,(return fg q#[v],ch))\<in>trcl (trss fg)" by simp
      also from CC have "((return fg q#[v],ch),e,([v],c'))\<in>trss fg" by (auto intro: trss_ret)
      finally show ?thesis by simp
    qed
    moreover note IHAPP' CC
    ultimately show ?case by auto
  qed
  ultimately show ?case by blast
qed

\<comment> \<open>This lemma is better suited for application in soundness proofs of constraint systems than @{thm [source] flowgraph.trss_find_call}\<close>
lemma (in flowgraph) trss_find_call':
  assumes A: "(([sp],c),w,(return fg p#[u'],c')) \<in> trcl (trss fg)"
  and EX: "!!uh ch wa wb. \<lbrakk>
      w=wa@(LCall p)#wb;
      (([sp],c),wa,([uh],ch))\<in>trcl (trss fg);
      (([uh],ch),LCall p,((entry fg p)#[u'],ch))\<in>trss fg;
      (uh,Call p,u')\<in>edges fg;
      (([entry fg p],ch),wb,([return fg p],c'))\<in>trcl (trss fg)
    \<rbrakk> \<Longrightarrow> P"
  shows "P"
proof -
  from trss_find_call[OF A] obtain rh ch wa wb where FC:
    "w = wa @ LCall p # wb"
    "(([sp], c), wa, rh, ch) \<in> trcl (trss fg)"
    "((rh, ch), LCall p, [entry fg p, u'], ch) \<in> trss fg"
    "(([entry fg p], ch), wb, [return fg p], c') \<in> trcl (trss fg)"
    by auto
  moreover from FC(3) obtain uh where ADD: "rh=[uh]" "(uh,Call p,u')\<in>edges fg" by (auto elim: trss.cases)
  ultimately show ?thesis using EX by auto
qed

lemma (in flowgraph) trss_bot_proc_const:
  "!!s' u' c'. ((s@[u],c),w,(s'@[u'],c'))\<in>trcl (trss fg)
    \<Longrightarrow> proc_of fg u = proc_of fg u'"
proof (induct w rule: rev_induct)
  case Nil thus ?case by auto
next
  case (snoc e w) note IHP=this then obtain sh ch where SPLIT1: "((s@[u],c),w,(sh,ch))\<in>trcl (trss fg)" and SPLIT2: "((sh,ch),e,(s'@[u'],c'))\<in>trss fg" by (fast dest: trcl_rev_uncons)
  from SPLIT2 have "sh\<noteq>[]" by (auto elim!: trss.cases)
  then obtain ssh uh where SHFMT: "sh=ssh@[uh]" by (blast dest: list_rev_decomp)
  with IHP(1)[of ssh uh ch] SPLIT1 have "proc_of fg u = proc_of fg uh" by auto
  also from SPLIT2 SHFMT have "proc_of fg uh = proc_of fg u'" by (cases rule: trss.cases) (cases ssh, auto simp add: edges_part)+
  finally show ?case .
qed

\<comment> \<open>Specialized version of @{thm [source] flowgraph.trss_bot_proc_const}that comes in handy for precision proofs of constraint systems\<close>
lemma (in flowgraph) trss_er_path_proc_const:
  "(([entry fg p],c),w,([return fg q],c'))\<in>trcl (trss fg) \<Longrightarrow> p=q"
  using trss_bot_proc_const[of "[]" "entry fg p" _ _ "[]" "return fg q", simplified] .

lemma trss_2empty_to_2return: "\<lbrakk> ((s,c),w,([],c'))\<in>trcl (trss fg); s\<noteq>[] \<rbrakk> \<Longrightarrow>
  \<exists>w' p. w=w'@[LRet] \<and> ((s,c),w',([return fg p],c'))\<in>trcl (trss fg)"
proof -
  assume A: "((s,c),w,([],c'))\<in>trcl (trss fg)" "s\<noteq>[]"
  hence "w\<noteq>[]" by auto
  then obtain w' e where WD: "w=w'@[e]" by (blast dest: list_rev_decomp)
  with A(1) obtain sh ch where SPLIT: "((s,c),w',(sh,ch))\<in>trcl (trss fg)" "((sh,ch),e,([],c'))\<in>trss fg" by (fast dest: trcl_rev_uncons)
  from SPLIT(2) obtain p where "e=LRet" "sh=[return fg p]" "ch=c'" by (cases rule: trss.cases, auto)
  with SPLIT(1) WD show ?thesis by blast
qed

lemma trss_2return_to_2empty: "\<lbrakk> ((s,c),w,([return fg p],c'))\<in>trcl (trss fg) \<rbrakk>
  \<Longrightarrow> ((s,c),w@[LRet],([],c'))\<in>trcl (trss fg)"
  apply (subgoal_tac "(([return fg p],c'),LRet,([],c'))\<in>trss fg")
  by (auto dest: trcl_rev_cons intro: trss.intros)

subsubsection "Adding threads"
lemma trss_env_increasing_s: "((s,c),e,(s',c'))\<in>trss fg \<Longrightarrow> c\<subseteq>#c'"
  by (auto elim!: trss.cases)
lemma trss_env_increasing: "((s,c),w,(s',c'))\<in>trcl (trss fg) \<Longrightarrow> c\<subseteq>#c'"
  by (induct rule: trcl_pair_induct) (auto dest: trss_env_increasing_s order_trans)

subsubsection "Conversion between environment and monitor restrictions"
lemma trss_mon_e_no_ctx:
  "((s,c),e,(s',c'))\<in>trss fg \<Longrightarrow> mon_e fg e \<inter> mon_c fg c = {}"
  by (erule trss.cases) auto
lemma (in flowgraph) trss_mon_w_no_ctx:
  "((s,c),w,(s',c'))\<in>trcl (trss fg) \<Longrightarrow> mon_w fg w \<inter> mon_c fg c = {}"
  by (induct rule: trcl_pair_induct) (auto dest: trss_mon_e_no_ctx simp add: trss_c_no_mon_s)

lemma (in flowgraph) trss_modify_context_s:
  "!!cn. \<lbrakk>((s,c),e,(s',c'))\<in>trss fg; mon_e fg e \<inter> mon_c fg cn = {}\<rbrakk>
    \<Longrightarrow> \<exists>csp. c'=csp+c \<and> mon_c fg csp = {} \<and> ((s,cn),e,(s',csp+cn))\<in>trss fg"
  by (erule trss.cases) (auto intro!: trss.intros)

lemma (in flowgraph) trss_modify_context[rule_format]:
  "\<lbrakk>((s,c),w,(s',c'))\<in>trcl (trss fg)\<rbrakk>
  \<Longrightarrow> \<forall>cn. mon_w fg w \<inter> mon_c fg cn = {}
      \<longrightarrow> (\<exists>csp. c'=csp+c \<and> mon_c fg csp = {} \<and>
                 ((s,cn),w,(s',csp+cn))\<in>trcl (trss fg))"
proof (induct rule: trcl_pair_induct)
  case empty thus ?case by simp
next
  case (cons s c e sh ch w s' c') note IHP=this show ?case
  proof (intro allI impI)
    fix cn
    assume MON: "mon_w fg (e # w) \<inter> mon_c fg cn = {}"
    from trss_modify_context_s[OF IHP(1)] MON obtain csph where S1: "ch = csph + c" "mon_c fg csph={}" "((s, cn), e, sh, csph + cn) \<in> trss fg" by auto
    with MON have "mon_w fg w \<inter> mon_c fg (csph+cn) = {}" by (auto simp add: mon_c_unconc)
    with IHP(3)[rule_format] obtain csp where S2: "c'=csp+ch" "mon_c fg csp={}" "((sh,csph+cn),w,(s',csp+(csph+cn)))\<in>trcl (trss fg)" by blast
    from S1 S2 have "c'=(csp+csph)+c" "mon_c fg (csp+csph)={}" "((s,cn),e#w,(s',(csp+csph)+cn))\<in>trcl (trss fg)" by (auto simp add: union_assoc mon_c_unconc)
    thus "\<exists>csp. c' = csp + c \<and> mon_c fg csp = {} \<and> ((s, cn), e # w, s', csp + cn) \<in> trcl (trss fg)" by blast
  qed
qed

lemma trss_add_context_s:
  "\<lbrakk>((s,c),e,(s',c'))\<in>trss fg; mon_e fg e \<inter> mon_c fg ce = {}\<rbrakk>
    \<Longrightarrow> ((s,c+ce),e,(s',c'+ce))\<in>trss fg"
  by (auto elim!: trss.cases intro!: trss.intros simp add: union_assoc mon_c_unconc)

lemma trss_add_context:
  "\<lbrakk>((s,c),w,(s',c'))\<in>trcl (trss fg); mon_w fg w \<inter> mon_c fg ce = {}\<rbrakk>
    \<Longrightarrow> ((s,c+ce),w,(s',c'+ce))\<in>trcl (trss fg)"
proof (induct rule: trcl_pair_induct)
  case empty thus ?case by simp
next
  case (cons s c e sh ch w s' c') note IHP=this
  from IHP(4) have MM: "mon_e fg e \<inter> mon_c fg ce = {}" "mon_w fg w \<inter> mon_c fg ce = {}" by auto
  from trcl.cons[OF trss_add_context_s[OF IHP(1) MM(1)] IHP(3)[OF MM(2)]] show ?case .
qed

lemma trss_drop_context_s: "\<lbrakk> ((s,c+ce),e,(s',c'+ce))\<in>trss fg \<rbrakk>
  \<Longrightarrow> ((s,c),e,(s',c'))\<in>trss fg \<and> mon_e fg e \<inter> mon_c fg ce = {}"
  by (erule trss.cases) (auto intro!: trss.intros simp add: mon_c_unconc union_assoc[of _ c ce, symmetric])

lemma trss_drop_context: "!!s c. \<lbrakk> ((s,c+ce),w,(s',c'+ce))\<in>trcl (trss fg) \<rbrakk>
  \<Longrightarrow> ((s,c),w,(s',c'))\<in>trcl (trss fg) \<and> mon_w fg w \<inter> mon_c fg ce = {}"
proof (induct w)
  case Nil thus ?case by auto
next
  case (Cons e w) note IHP=this
  then obtain sh ch where SPLIT: "((s,c+ce),e,(sh,ch))\<in>trss fg" "((sh,ch),w,(s',c'+ce))\<in> trcl (trss fg)" by (fast dest: trcl_uncons)
  from trss_c_fmt_s[OF SPLIT(1)] obtain csp where CHFMT: "ch = (csp + c) + ce" by (auto simp add: union_assoc)
  from CHFMT trss_drop_context_s SPLIT(1) have "((s,c),e,(sh,csp+c))\<in>trss fg" "mon_e fg e \<inter> mon_c fg ce = {}" by blast+
  moreover from CHFMT IHP(1) SPLIT(2) have "((sh,csp+c),w,(s',c'))\<in>trcl (trss fg)" "mon_w fg w \<inter> mon_c fg ce = {}" by blast+
  ultimately show ?case by auto
qed

lemma trss_xchange_context_s:
  assumes A: "((s,c),e,(s',csp+c))\<in>trss fg"
  and M:"mon_c fg cn \<subseteq> mon_c fg c"
  shows "((s,cn),e,(s',csp+cn))\<in>trss fg"
proof -
  from trss_drop_context_s[of _ "{#}", simplified, OF A] have DC: "((s, {#}), e, s', csp) \<in> trss fg" "mon_e fg e \<inter> mon_c fg c = {}" by simp_all
  with M have "mon_e fg e \<inter> mon_c fg cn = {}" by auto
  from trss_add_context_s[OF DC(1) this] show ?thesis by auto
qed

lemma trss_xchange_context:
  assumes A: "((s,c),w,(s',csp+c))\<in>trcl (trss fg)"
  and M:"mon_c fg cn \<subseteq> mon_c fg c"
  shows "((s,cn),w,(s',csp+cn))\<in>trcl (trss fg)"
proof -
  from trss_drop_context[of _ "{#}", simplified, OF A] have DC: "((s, {#}), w, s', csp) \<in> trcl (trss fg)" "mon_w fg w \<inter> mon_c fg c = {}" by simp_all
  with M have "mon_w fg w \<inter> mon_c fg cn = {}" by auto
  from trss_add_context[OF DC(1) this] show ?thesis by auto
qed

lemma trss_drop_all_context_s[cases set, case_names dropped]:
  assumes A: "((s,c),e,(s',c'))\<in>trss fg"
  and C: "!!csp. \<lbrakk> c'=csp+c; ((s,{#}),e,(s',csp))\<in>trss fg \<rbrakk> \<Longrightarrow> P"
  shows P
using A proof (cases rule: trss_c_cases_s)
  case no_spawn with trss_xchange_context_s[of s c e s' "{#}" fg "{#}"] A C show P by auto
next
  case (spawn p u v) with trss_xchange_context_s[of s c e s' "{#[entry fg p]#}" fg "{#}"] A C show P by auto
qed

lemma trss_drop_all_context[cases set, case_names dropped]:
  assumes A: "((s,c),w,(s',c'))\<in>trcl (trss fg)"
  and C: "!!csp. \<lbrakk> c'=csp+c; ((s,{#}),w,(s',csp))\<in>trcl (trss fg)\<rbrakk> \<Longrightarrow> P"
  shows P
using A proof (cases rule: trss_c_cases)
  case (c_case csp) with trss_xchange_context[of s c w s' csp fg "{#}"] A C show P by auto
qed

lemma tr_add_context_s:
  "\<lbrakk> (c,e,c')\<in>tr fg; mon_e fg e \<inter> mon_c fg ce = {} \<rbrakk> \<Longrightarrow> (c+ce,e,c'+ce)\<in>tr fg"
  by (erule gtrE) (auto simp add: mon_c_unconc union_assoc intro: gtrI_s dest: trss_add_context_s)

lemma tr_add_context:
  "\<lbrakk> (c,w,c')\<in>trcl (tr fg); mon_w fg w \<inter> mon_c fg ce = {} \<rbrakk>
    \<Longrightarrow> (c+ce,w,c'+ce)\<in>trcl (tr fg)"
proof (induct rule: trcl.induct)
  case empty thus ?case by auto
next
  case (cons c e c' w c'') note IHP=this
  from tr_add_context_s[OF IHP(1), of ce] IHP(4) have "(c + ce, e, c' + ce) \<in> tr fg" by auto
  also from IHP(3,4) have "(c' + ce, w, c'' + ce) \<in> trcl (tr fg)" by auto
  finally show ?case .
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Sep_Cancel
imports Sep_Provers Sep_Tactic_Helpers Sep_Cancel_Set
begin

(* Sep_Cancel performs cancellative elimination of conjuncts *)

lemma sep_curry': "\<lbrakk>(P \<and>* F) s; \<And>s. (Q \<and>* P \<and>* F) s \<Longrightarrow> R s\<rbrakk> \<Longrightarrow> (Q \<longrightarrow>* R) s"
  by (metis (full_types) sep.mult_commute sep_curry)

lemma sep_conj_sep_impl_safe:
  "(P \<longrightarrow>* P') s \<Longrightarrow> (\<And>s. ((P \<longrightarrow>* P') \<and>* Q) s \<Longrightarrow> (Q') s) \<Longrightarrow> (Q \<longrightarrow>* Q') s"
  by (rule sep_curry)

lemma  sep_conj_sep_impl_safe': "P s \<Longrightarrow> (\<And>s. (P \<and>* Q) s \<Longrightarrow> (P \<and>* R) s) \<Longrightarrow> (Q \<longrightarrow>* P \<and>* R) s"
  by (rule sep_curry)

lemma sep_wand_lens_simple: "(\<And>s. T s = (Q \<and>* R) s) \<Longrightarrow> (P \<longrightarrow>* T) s \<Longrightarrow> (P \<longrightarrow>* Q \<and>* R) s"
  by (clarsimp simp: sep_impl_def)

schematic_goal schem_impAny: " (?C \<and>* B) s \<Longrightarrow> A s" by (erule sep_mp)

ML {*
  fun sep_cancel_tactic ctxt concl  =
    let val thms = rev (SepCancel_Rules.get ctxt)
        val tac  = assume_tac ctxt ORELSE'
                   eresolve_tac ctxt [@{thm sep_mp}, @{thm sep_conj_empty}, @{thm sep_empty_conj}] ORELSE'
                   sep_erule_tactic ctxt thms
        val direct_tac = eresolve_tac ctxt thms
        val safe_sep_wand_tac = rotator' ctxt (resolve0_tac [@{thm sep_wand_lens_simple}]) (eresolve0_tac [@{thm sep_conj_sep_impl_safe'}])
        fun sep_cancel_tactic_inner true   = sep_erule_full_tac' tac ctxt
          | sep_cancel_tactic_inner false  = sep_erule_full_tac tac ctxt
  in sep_cancel_tactic_inner concl ORELSE'
      eresolve_tac ctxt [@{thm sep_curry'}, @{thm sep_conj_sep_impl_safe}, @{thm sep_imp_empty}, @{thm sep_empty_imp'}] ORELSE'
      safe_sep_wand_tac ORELSE'
      direct_tac
  end

  fun sep_cancel_tactic' ctxt concl =
    let
      val sep_cancel = sep_cancel_tactic ctxt
    in
      (sep_flatten ctxt THEN_ALL_NEW sep_cancel concl) ORELSE' sep_cancel concl
    end

  fun sep_cancel_method (concl,_) ctxt = SIMPLE_METHOD' (sep_cancel_tactic' ctxt concl)

  val sep_cancel_syntax =
    Method.sections [Args.add -- Args.colon >> K (Method.modifier SepCancel_Rules.add @{here})];

  val sep_cancel_syntax' =
    Scan.lift (Args.mode "concl") -- sep_cancel_syntax
*}

method_setup sep_cancel =
  {* sep_cancel_syntax' >> sep_cancel_method *}  {* Simple elimination of conjuncts *}

end


(*
Title: WHATandWHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Parallel_Composition
imports Up_To_Technique MWLs
begin

locale WHATWHERE_Secure_Programs =
L? : MWLs_semantics "E" "BMap"
+ WWs? : WHATWHERE "MWLsSteps_det" "E" "pp" "DA" "lH"
for E :: "('exp, 'id, 'val) Evalfunction"
and BMap :: "'val \<Rightarrow> bool"
and DA :: "('id, 'd::order) DomainAssignment"
and lH :: "('d, 'exp) lHatches"
begin

lemma SdlHPPB_restricted_on_PP_is_SdlHPPB:
  assumes SdlHPPB: "SdlHPPB d PP R'"
  assumes inR': "(V,V) \<in> R'"
  assumes Rdef: "R = {(V',V''). (V',V'') \<in> R'
    \<and> set (PPV V') \<subseteq> set (PPV V)
    \<and> set (PPV V'') \<subseteq> set (PPV V)}"
  shows "SdlHPPB d PP R"
proof (simp add: Strong_dlHPP_Bisimulation_def, auto)
  from SdlHPPB have "sym R'"
    by (simp add: Strong_dlHPP_Bisimulation_def)
  with Rdef show "sym R"
    by (simp add: sym_def)
next
  from SdlHPPB have "trans R'"
    by (simp add: Strong_dlHPP_Bisimulation_def)
  with Rdef show "trans R"
    by (simp add: trans_def, auto)
next
  fix V' V''
  assume inR_part: "(V',V'') \<in> R"
  with SdlHPPB Rdef show "length V' = length V''"
    by (simp add: Strong_dlHPP_Bisimulation_def, auto)
next
  fix V' V'' i
  assume inR_part: "(V',V'') \<in> R"
  assume irange: "i < length V'"
  assume notIDC:
    "\<not> IDC d (V'!i) (htchLoc (pp (V'!i)))"
  with SdlHPPB inR_part irange Rdef
  show "NDC d (V'!i)"
    by (simp add: Strong_dlHPP_Bisimulation_def, auto)
next
  fix V' V'' i \<alpha> p m1 m1' m2
  assume inR_part: "(V',V'') \<in> R"
  assume irange: "i < length V'"
  assume step: "\<langle>V'!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
  assume dhequal: "m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1'"

  from inR_part SdlHPPB Rdef have eqlen: "length V' = length V''"
    by (simp add: Strong_dlHPP_Bisimulation_def, auto)

  from inR_part Rdef
  have "set (PPV V') \<subseteq> set (PPV V) \<and> set (PPV V'') \<subseteq> set (PPV V)"
    by auto

  with irange PPc_in_PPV_version eqlen
  have PPc_Vs_at_i:
    "set (PPc (V'!i)) \<subseteq> set (PPV V) \<and> set (PPc (V''!i)) \<subseteq> set (PPV V)"
    by (metis subset_trans)

  from SdlHPPB inR_part Rdef irange step dhequal
    strongdlHPPB_aux[of "d" "PP" "R'" "i"
    "V'" "V''" "m1" "\<alpha>" "p" "m2" "m1'"]
  obtain p' \<alpha>' m2' where stepreq: "\<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
    stepResultsinR p p' R' \<and> (\<alpha>,\<alpha>') \<in> R' \<and>
    dhequality_alternative d PP (pp (V'!i)) m2 m2'"
    by auto
  have Rpp': "stepResultsinR p p' R"
  proof -
    {
      fix c c'
      assume step1: "\<langle>V'!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c,m2\<rangle>"
      assume step2: "\<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>Some c',m2'\<rangle>"
      assume inR'_res: "([c],[c']) \<in> R'"

      from PPc_Vs_at_i step1 step2 PPsc_of_step
      have "set (PPc c) \<subseteq> set (PPV V) \<and> set (PPc c') \<subseteq> set (PPV V)"
        by (metis (no_types) option.sel xt1(6))

      with inR'_res Rdef have "([c],[c']) \<in> R"
        by auto
    }
    thus ?thesis
      by (metis step stepResultsinR_def stepreq)
  qed

  have R\<alpha>\<alpha>': "(\<alpha>,\<alpha>') \<in> R"
  proof -
    from PPc_Vs_at_i step stepreq PPs\<alpha>_of_step have
      "set (PPV \<alpha>) \<subseteq> set (PPV V) \<and> set (PPV \<alpha>') \<subseteq> set (PPV V)"
      by (metis (no_types) xt1(6))
    with stepreq Rdef show ?thesis
      by auto
  qed

  from stepreq Rpp' R\<alpha>\<alpha>' show
    "\<exists>p' \<alpha>' m2'. \<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
    stepResultsinR p p' R \<and> (\<alpha>,\<alpha>') \<in> R \<and>
    dhequality_alternative d PP (pp (V'!i)) m2 m2'"
    by auto
qed

theorem parallel_composition:
  "\<lbrakk> \<forall>i < length V. WHATWHERE_Secure [V!i]; unique_PPV V \<rbrakk>
  \<Longrightarrow> WHATWHERE_Secure V"
proof (simp add: WHATWHERE_Secure_def, induct V, auto)
  fix d PP
  from WHATWHERE_empty
  show "\<exists>R. SdlHPPB d PP R \<and> ([],[]) \<in> R"
    by (simp add: WHATWHERE_Secure_def)
next
  fix c V d PP
  assume IH: "\<lbrakk> \<forall>i < length V.
    \<forall>d PP. \<exists>R. SdlHPPB d PP R \<and> ([V!i],[V!i]) \<in> R;
    unique_PPV V \<rbrakk>
    \<Longrightarrow> \<forall>d PP. \<exists>R. SdlHPPB d PP R \<and> (V,V) \<in> R"
  assume ISassump: "\<forall>i < Suc (length V).
    \<forall>d PP. \<exists>R. SdlHPPB d PP R \<and> ([(c#V)!i],[(c#V)!i]) \<in> R"
  assume uniPPcV: "unique_PPV (c#V)"

  hence IHassump1: "unique_PPV V"
    by (simp add: unique_PPV_def)

  from uniPPcV have nocommonPP: "set (PPc c) \<inter> set (PPV V) = {}"
    by (simp add: unique_PPV_def)

  from ISassump have IHassump2: "\<forall>i < length V.
    \<forall>d PP. \<exists>R. SdlHPPB d PP R \<and> ([V!i],[V!i]) \<in> R"
    by auto

  with IHassump1 IH obtain RV' where RV'assump:
    "SdlHPPB d PP RV' \<and> (V,V) \<in> RV'"
    by blast

  define RV where "RV = {(V',V''). (V',V'') \<in> RV' \<and> set (PPV V') \<subseteq> set (PPV V)
    \<and> set (PPV V'') \<subseteq> set (PPV V)}"

  with RV'assump RV_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPRV: "SdlHPPB d PP RV"
    by force

  from ISassump obtain Rc' where Rc'assump:
    "SdlHPPB d PP Rc' \<and> ([c],[c]) \<in> Rc'"
    by (metis append_Nil drop_Nil neq0_conv not_Cons_self
      nth_append_length Cons_nth_drop_Suc zero_less_Suc)

  define Rc where "Rc = {(V',V''). (V',V'') \<in> Rc' \<and> set (PPV V') \<subseteq> set (PPc c)
    \<and> set (PPV V'') \<subseteq> set (PPc c)}"

  with Rc'assump Rc_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPRc: "SdlHPPB d PP Rc"
    by force

  from nocommonPP have "Domain RV \<inter> Domain Rc \<subseteq> {[]}"
    by (simp add: RV_def Rc_def, auto,
      metis Int_mono inf_commute inf_idem le_bot nocommonPP unique_V_uneq)

  with commonArefl_subset_commonDomain
  have Areflassump1: "Arefl RV \<inter> Arefl Rc \<subseteq> {[]}"
    by force

  define R where "R = {(V',V''). \<exists>c c' W W'. V' = c#W \<and> V'' = c'#W' \<and> W \<noteq> []
    \<and> W' \<noteq> [] \<and> ([c],[c']) \<in> Rc \<and> (W,W') \<in> RV}"

  with RV_def RV'assump Rc_def Rc'assump have inR:
    "V \<noteq> [] \<Longrightarrow> (c#V,c#V) \<in> R"
    by auto

  from R_def Rc_def RV_def nocommonPP
  have "Domain R \<inter> Domain (Rc \<union> RV) = {}"
    by (simp add: R_def Rc_def RV_def, auto,
      metis inf_bot_right le_inf_iff subset_empty unique_V_uneq,
      metis (hide_lams, no_types) inf_absorb1 inf_bot_right le_inf_iff unique_c_uneq)

  with commonArefl_subset_commonDomain
  have Areflassump2: "Arefl R \<inter> Arefl (Rc \<union> RV) \<subseteq> {[]}"
    by force

  have disjuptoR:
    "disj_dlHPP_Bisimulation_Up_To_R' d PP (Rc \<union> RV) R"
    proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def, auto)
        from Areflassump1 SdlHPPRc SdlHPPRV Union_Strong_dlHPP_Bisim
        show "SdlHPPB d PP (Rc \<union> RV)"
          by force
      next
        from SdlHPPRV have symRV: "sym RV"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        from SdlHPPRc have symRc: "sym Rc"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        with symRV R_def show "sym R"
          by (simp add: sym_def, auto)
      next
        from SdlHPPRV have transRV: "trans RV"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        from SdlHPPRc have transRc: "trans Rc"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        show "trans R"
           proof -
            {
            fix V V' V''
            assume p1: "(V,V') \<in> R"
            assume p2: "(V',V'') \<in> R"
            have "(V,V'') \<in> R"
              proof -
                from p1 R_def obtain c c' W W' where p1assump:
                  "V = c#W \<and> V' = c'#W' \<and> W \<noteq> [] \<and> W' \<noteq> [] \<and>
                  ([c],[c']) \<in> Rc \<and> (W,W') \<in> RV"
                  by auto
                with p2 R_def obtain c'' W'' where p2assump:
                  "V'' = c''#W'' \<and> W'' \<noteq> [] \<and>
                  ([c'],[c'']) \<in> Rc \<and> (W',W'') \<in> RV"
                  by auto
                with p1assump transRc transRV have
                  trans_assump: "([c],[c'']) \<in> Rc \<and> (W,W'') \<in> RV"
                  by (simp add: trans_def, blast)
                with p1assump p2assump R_def show ?thesis
                  by auto
              qed
             }
            thus ?thesis unfolding trans_def by blast
           qed
      next
        fix V V'
        assume "(V,V') \<in> R"
        with R_def SdlHPPRV show "length V = length V'"
          by (simp add: Strong_dlHPP_Bisimulation_def, auto)
      next
        fix V V' i
        assume inR: "(V,V') \<in> R"
        assume irange: "i < length V"
        assume notIDC: "\<not> IDC d (V!i)
          (htchLoc (pp (V!i)))"
        from inR R_def obtain c c' W W' where VV'assump:
          "V = c#W \<and> V'=c'#W' \<and> W \<noteq> [] \<and> W' \<noteq> [] \<and>
          ([c],[c']) \<in> Rc \<and> (W,W') \<in> RV"
          by auto
        \<comment> \<open>Case separation for i\<close>
        from VV'assump SdlHPPRc have Case_i0:
          "i = 0 \<Longrightarrow> (NDC d (V!i) \<or>
            IDC d (V!i) (htchLoc (pp (V!i))))"
          by (simp add: Strong_dlHPP_Bisimulation_def, auto)

        from VV'assump SdlHPPRV have "\<forall>i < length W.
          (NDC d (W!i) \<or>
            IDC d (W!i) (htchLoc (pp (W!i))))"
          by (simp add: Strong_dlHPP_Bisimulation_def, auto)

        with irange VV'assump have Case_in0:
          "i > 0 \<Longrightarrow> (NDC d (V!i) \<or>
          IDC d (V!i) (htchLoc (pp (V!i))))"
          by simp
        from notIDC Case_i0 Case_in0
        show "NDC d (V!i)"
          by auto
      next
        fix V V' m1 m1' m2 \<alpha> p i
        assume inR: "(V,V') \<in> R"
        assume irange: "i < length V"
        assume step: "\<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
        assume dhequal: "m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1'"

        from inR R_def obtain c c' W W' where VV'assump:
          "V = c#W \<and> V'=c'#W' \<and> W \<noteq> [] \<and> W' \<noteq> [] \<and>
          ([c],[c']) \<in> Rc \<and> (W,W') \<in> RV"
          by auto
        \<comment> \<open>Case separation for i\<close>
        from VV'assump SdlHPPRc strongdlHPPB_aux[of "d" "PP"
          "Rc" "0" "[c]" "[c']"] step dhequal
        have Case_i0:
          "i = 0 \<Longrightarrow> \<exists>p' \<alpha>' m2'.
          \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
          stepResultsinR p p' (R \<union> (Rc \<union> RV)) \<and>
          ((\<alpha>,\<alpha>') \<in> R \<or> (\<alpha>,\<alpha>') \<in> Rc \<or> (\<alpha>,\<alpha>') \<in> RV) \<and>
          dhequality_alternative d PP (pp (V!i)) m2 m2'"
          by (simp add: stepResultsinR_def, blast)

        from step VV'assump irange have rewV:
          "i > 0 \<Longrightarrow> (i-Suc 0) < length W \<and> V!i = W!(i-Suc 0)"
          by simp

        with irange VV'assump step dhequal SdlHPPRV
          strongdlHPPB_aux[of "d" "PP" "RV" _ "W" "W'"]
        have Case_in0:
          "i > 0 \<Longrightarrow>  \<exists>p' \<alpha>' m2'.
          \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
          stepResultsinR p p' (R \<union> (Rc \<union> RV)) \<and>
          ((\<alpha>,\<alpha>') \<in> R \<or> (\<alpha>,\<alpha>') \<in> Rc \<or> (\<alpha>,\<alpha>') \<in> RV) \<and>
          dhequality_alternative d PP (pp (V!i)) m2 m2'"
          by (simp add: stepResultsinR_def, blast)

        from Case_i0 Case_in0
        show "\<exists>p' \<alpha>' m2'.
          \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
          stepResultsinR p p' (R \<union> (Rc \<union> RV)) \<and>
          ((\<alpha>,\<alpha>') \<in> R \<or> (\<alpha>,\<alpha>') \<in> Rc \<or> (\<alpha>,\<alpha>') \<in> RV) \<and>
          dhequality_alternative d PP (pp (V!i)) m2 m2'"
          by auto
      qed
  with Areflassump2 Rc'assump Up_To_Technique
  show "\<exists>R. SdlHPPB d PP R \<and> (c#V, c#V) \<in> R"
    by (metis UnCI inR)

qed

end

end


(*
 * Copyright 2022, Proofcraft Pty Ltd
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory ArchKernelInit_AI
imports
  ADT_AI
  Tcb_AI
  Arch_AI
begin

context Arch begin global_naming AARCH64

text \<open>
  Showing that there is a state that satisfies the abstract invariants.
\<close>

lemmas ptr_defs = idle_thread_ptr_def init_irq_node_ptr_def arm_global_pt_ptr_def
lemmas state_defs = init_A_st_def init_kheap_def init_arch_state_def
                    init_vspace_uses_def ptr_defs global_pt_obj_def

lemma is_tcb_TCB[simp]: "is_tcb (TCB t)" by (simp add: is_tcb_def)

lemma ran_empty_cnode[simp]: "ran (empty_cnode n) = {NullCap}"
  apply (rule equalityI; clarsimp simp: ran_def empty_cnode_def)
  apply (rule_tac x="replicate n False" in exI)
  apply simp
  done

lemma empty_cnode_apply[simp]:
  "(empty_cnode n xs = Some cap) = (length xs = n \<and> cap = NullCap)"
  by (auto simp add: empty_cnode_def)

lemma valid_cs_size_empty[simp]:
  "valid_cs_size n (empty_cnode n) = (n < word_bits - cte_level_bits)"
  using wf_empty_bits [of n] by (simp add: valid_cs_size_def)

lemma init_cdt [simp]:
  "cdt init_A_st = init_cdt"
  by (simp add: state_defs)

lemma mdp_parent_empty[simp]:
  "\<not>Map.empty \<Turnstile> x \<rightarrow> y"
  by (auto simp: cdt_parent_of_def dest: tranclD)

lemma descendants_empty[simp]:
  "descendants_of x Map.empty = {}"
  by (clarsimp simp: descendants_of_def)

lemma is_reply_cap_NullCap[simp]: "\<not>is_reply_cap NullCap"
  by (simp add: is_reply_cap_def)

declare cap_range_NullCap [simp]

lemma pptr_base_num:
  "pptr_base = 0x8000000000"
  by (simp add: pptr_base_def pptrBase_def canonical_bit_def)

definition irq_node_bits :: nat where
  "irq_node_bits = cte_level_bits + LENGTH(irq_len)"

lemmas irq_node_bits_num = irq_node_bits_def[unfolded cte_level_bits_def, simplified]

(* Some other architectures need to prove more here, but if the init_irq_node is the last object
   in the init state, we only need info about  init_irq_node_ptr, and not about
   init_irq_node_ptr + mask irq_node bits *)
lemma init_irq_ptrs_ineqs:
  "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits) \<ge> init_irq_node_ptr"
proof -
  have P: "ucast irq < (2 ^ (irq_node_bits - cte_level_bits) :: machine_word)"
    apply (rule order_le_less_trans[OF
        ucast_le_ucast[where 'a=irq_len and 'b=machine_word_len, simplified, THEN iffD2, OF word_n1_ge]])
    apply (simp add: cte_level_bits_def minus_one_norm irq_node_bits_def)
    done
  show "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits) \<ge> init_irq_node_ptr"
    apply (rule is_aligned_no_wrap'[where sz=irq_node_bits])
     apply (simp add: is_aligned_def init_irq_node_ptr_def pptr_base_num irq_node_bits_num)
    apply (rule shiftl_less_t2n[OF P])
    apply (simp add: irq_node_bits_num)
    done
qed

lemmas init_irq_ptrs_less_ineqs
   = init_irq_ptrs_ineqs(1)[THEN order_less_le_trans[rotated]]

lemmas init_irq_ptrs_all_ineqs[unfolded init_irq_node_ptr_def cte_level_bits_def]
   = init_irq_ptrs_ineqs(1)[THEN order_trans[rotated]]
     init_irq_ptrs_less_ineqs
     init_irq_ptrs_less_ineqs[THEN less_imp_neq]
     init_irq_ptrs_less_ineqs[THEN less_imp_neq, THEN not_sym]

lemma init_irq_ptrs_eq:
  "((ucast irq << cte_level_bits) = (ucast (irq' :: irq) << cte_level_bits :: machine_word))
   = (irq = irq')"
  by word_bitwise (clarsimp simp: cte_level_bits_def)

lemma pspace_aligned_init_A:
  "pspace_aligned init_A_st"
  apply (clarsimp simp: pspace_aligned_def state_defs wf_obj_bits [OF wf_empty_bits]
                        dom_if_Some cte_level_bits_def bit_simps pptr_base_num kernel_elf_base_def)
  apply (safe intro!: aligned_add_aligned[OF _ is_aligned_shiftl_self order_refl],
           simp_all add: is_aligned_def word_bits_def)[1]
  done

lemma pspace_distinct_init_A:
  notes ineqs = pptr_base_num init_irq_ptrs_all_ineqs[simplified pptr_base_num mask_def, simplified]
  shows "pspace_distinct init_A_st"
  unfolding pspace_distinct_def
  apply (clarsimp simp: state_defs empty_cnode_bits cte_level_bits_def linorder_not_le
                  split del: if_split cong: if_cong)
  apply (clarsimp simp: ineqs split: if_split_asm)
    apply (simp add: bit_simps ineqs)
   apply (simp add: bit_simps ineqs)
  apply (cut_tac x="init_irq_node_ptr + (ucast irq << cte_level_bits)"
             and y="init_irq_node_ptr + (ucast irqa << cte_level_bits)"
             and sz=cte_level_bits in aligned_neq_into_no_overlap;
         simp add: init_irq_node_ptr_def pptr_base_num cte_level_bits_def)
    apply (rule aligned_add_aligned[OF _ is_aligned_shiftl_self order_refl])
    apply (simp add: is_aligned_def)
   apply (rule aligned_add_aligned[OF _ is_aligned_shiftl_self order_refl])
   apply (simp add: is_aligned_def)
  apply (simp add: linorder_not_le)
  done

lemma caps_of_state_init_A_st_Null:
  "caps_of_state (init_A_st::'z::state_ext state) x
     = (if cte_at x (init_A_st::'z::state_ext state) then Some NullCap else None)"
  apply (subgoal_tac "\<not> cte_wp_at ((\<noteq>) NullCap) x init_A_st")
   apply (auto simp add: cte_wp_at_caps_of_state)[1]
  apply (clarsimp, erule cte_wp_atE)
   apply (auto simp add: state_defs tcb_cap_cases_def split: if_split_asm)
  done

lemma cte_wp_at_init_A_st_Null:
  "cte_wp_at P p init_A_st \<Longrightarrow> P cap.NullCap"
  apply (subst(asm) cte_wp_at_caps_of_state)
  apply (simp add:caps_of_state_init_A_st_Null split: if_splits)
  done

lemmas cte_wp_at_caps_of_state_eq
    = cte_wp_at_caps_of_state[where P="(=) cap" for cap]

lemma pspace_respects_device_region_init[simp]:
  "pspace_respects_device_region init_A_st"
   apply (clarsimp simp: pspace_respects_device_region_def state_defs init_machine_state_def
                         device_mem_def in_device_frame_def obj_at_def a_type_def)
   apply (rule ext)
   apply clarsimp
   done

lemma cap_refs_respects_device_region_init[simp]:
  "cap_refs_respects_device_region init_A_st"
   apply (clarsimp simp: cap_refs_respects_device_region_def)
   apply (frule cte_wp_at_caps_of_state[THEN iffD1])
   apply clarsimp
   apply (subst(asm) caps_of_state_init_A_st_Null)
   apply (clarsimp simp: cte_wp_at_caps_of_state cap_range_respects_device_region_def)
   done

lemma pool_for_asid_init_A_st[simp]:
  "pool_for_asid asid init_A_st = None"
  by (simp add: pool_for_asid_def state_defs)

lemma vspace_for_asid_init_A_st[simp]:
  "vspace_for_asid asid init_A_st = None"
  by (simp add: vspace_for_asid_def entry_for_asid_def obind_def)

lemma global_pt_init_A_st[simp]:
  "global_pt init_A_st = arm_global_pt_ptr"
  by (simp add: state_defs)

lemma is_alignedarm_global_pt_ptr[simp]:
  "is_aligned arm_global_pt_ptr (pt_bits VSRootPT_T)"
  by (simp add: arm_global_pt_ptr_def pptr_base_num bit_simps is_aligned_def)

lemma ptes_of_init_A_st_global:
  "ptes_of init_A_st =
   (\<lambda>pt_t p. if pt_t = VSRootPT_T \<and> table_base VSRootPT_T p = arm_global_pt_ptr \<and>
             is_aligned p pte_bits then Some InvalidPTE else None)"
  by (rule ext)+ (auto simp: state_defs level_pte_of_def obind_def opt_map_def split: option.splits)

lemma pt_walk_init_A_st[simp]:
  "pt_walk max_pt_level level arm_global_pt_ptr vref (ptes_of init_A_st) =
   Some (max_pt_level, arm_global_pt_ptr)"
  apply (subst pt_walk.simps)
  apply (simp add: in_omonad ptes_of_init_A_st_global
                   table_base_pt_slot_offset[where level=max_pt_level, simplified]
                   is_aligned_pt_slot_offset_pte[where pt_t=VSRootPT_T])
  done

lemma kernel_window_init_st:
  "kernel_window init_A_st = { pptr_base ..< pptr_base + (1 << 30) }"
  by (auto simp: state_defs kernel_window_def)

lemma valid_global_vspace_mappings_init_A_st[simp]:
  "valid_global_vspace_mappings init_A_st"
  unfolding valid_global_vspace_mappings_def
  by simp

lemma valid_uses_init_A_st[simp]: "valid_uses_2 init_vspace_uses"
proof -
  have [simp]: "pptr_base < pptr_base + 0x40000000"
    by (simp add: pptr_base_def pptrBase_def)
  have "\<And>p. p < pptr_base + 0x40000000 \<Longrightarrow> canonical_address p"
    by (simp add: canonical_address_range canonical_bit_def mask_def pptr_base_def pptrBase_def
                  word_le_nat_alt word_less_nat_alt)
  moreover
  have "pptr_base + 0x40000000 < pptrTop"
    by (simp add: pptrTop_def pptr_base_def pptrBase_def)
  moreover
  have "pptr_base + 0x40000000 < kdev_base"
    by (simp add: kdev_base_def kdevBase_def pptr_base_def pptrBase_def)
  ultimately
  show ?thesis
    unfolding valid_uses_2_def init_vspace_uses_def window_defs
    by auto
qed

lemma valid_global_arch_objs_init_A_st[simp]:
  "valid_global_arch_objs init_A_st"
  by (simp add: valid_global_arch_objs_def state_defs level_defs obj_at_def)

lemma vspace_for_pool_init_A_st[simp]:
  "vspace_for_pool ap asid (asid_pools_of init_A_st) = None"
  by (clarsimp simp: vspace_for_pool_def obind_def in_opt_map_eq state_defs entry_for_pool_def
               split: option.splits)

lemma user_region_vs_lookup_target_init_A_st[simp]:
  "vref \<in> user_region \<Longrightarrow> vs_lookup_target bot_level asid vref init_A_st = None"
  by (clarsimp simp: vs_lookup_target_def obind_def vs_lookup_slot_def vs_lookup_table_def
               split: option.splits)

lemma valid_vs_lookup_init_A_st[simp]:
  "valid_vs_lookup init_A_st"
  by (clarsimp simp: valid_vs_lookup_def)

lemma valid_vspace_objs_init_A_st[simp]:
  "valid_vspace_objs init_A_st"
  by (clarsimp simp: valid_vspace_objs_def in_omonad vs_lookup_table_def)

lemma idle_thread_in_kernel_window_init_arch_state[simp]:
  "{idle_thread_ptr..0x3FF + idle_thread_ptr} \<subseteq>
     kernel_window_2 (arm_kernel_vspace init_arch_state)"
  apply (clarsimp simp: state_defs pptr_base_num bit_simps kernel_window_def kernel_elf_base_def)
  apply (rule conjI; unat_arith)
  done

lemma irq_node_in_kernel_window_init_arch_state':
  "\<lbrakk> init_irq_node_ptr + m \<le> x; x \<le> init_irq_node_ptr + m + mask cte_level_bits;
     m \<le> mask (size (irq::irq)) << cte_level_bits\<rbrakk>
   \<Longrightarrow> x \<in> kernel_window_2 (arm_kernel_vspace init_arch_state)"
  apply (clarsimp simp: kernel_window_def init_vspace_uses_def init_arch_state_def)
  apply (rule conjI)
   apply (clarsimp simp: state_defs)
   apply (rule ccontr, simp add:not_le)
   apply (drule(1) le_less_trans)
   (* We pick 30 for alignment of pptr_base, because pttr_base is set to 2^40-2^30 *)
   apply (cut_tac is_aligned_no_wrap'[where ptr=pptr_base
                                      and off="0xc000 + m"
                                      and sz=30, simplified])
     apply (simp add: add_ac)
    apply (simp add: pptr_base_num canonical_bit_def is_aligned_def)
   apply (simp add: pptr_base_num cte_level_bits_def canonical_bit_def mask_def word_size)
   apply unat_arith
  apply (simp add: cte_level_bits_def mask_def init_irq_node_ptr_def pptr_base_num word_size)
  apply unat_arith
  done

lemma irq_node_in_kernel_window_init_arch_state[simp]:
  "\<lbrakk> init_irq_node_ptr + (ucast (irq::irq) << cte_level_bits) \<le> x;
     x \<le> init_irq_node_ptr + (ucast irq << cte_level_bits) + 2 ^ cte_level_bits - 1 \<rbrakk>
   \<Longrightarrow> x \<in> kernel_window_2 (arm_kernel_vspace init_arch_state)"
  apply (erule irq_node_in_kernel_window_init_arch_state')
   apply (simp add: mask_def add_diff_eq)
  apply (simp add: word_size mask_def cte_level_bits_def)
  apply (thin_tac P for P)
  apply word_bitwise
  done

lemma tcb_vcpu_init_arch_tcb_None[simp]:
  "tcb_vcpu init_arch_tcb = None"
  by (simp add: init_arch_tcb_def)

lemma pspace_in_kernel_window_init_A_st:
  "pspace_in_kernel_window init_A_st"
  apply (clarsimp simp: pspace_in_kernel_window_def init_A_st_def init_kheap_def)
  apply (safe; clarsimp)
       apply (clarsimp simp: ptr_defs pptr_base_num)
      apply (clarsimp simp: ptr_defs pptr_base_num kernel_window_def init_arch_state_def
                            init_vspace_uses_def)
      apply unat_arith
     apply (clarsimp simp: global_pt_obj_def bit_simps ptr_defs pptr_base_num kernel_window_def
                           init_arch_state_def init_vspace_uses_def
                     split: if_split_asm)
      apply unat_arith
     apply unat_arith
    apply (clarsimp simp: ptr_defs pptr_base_num kernel_window_def init_arch_state_def init_vspace_uses_def)
   apply (clarsimp simp: ptr_defs pptr_base_num kernel_window_def init_arch_state_def init_vspace_uses_def)
   apply unat_arith
  apply (clarsimp simp: global_pt_obj_def bit_simps ptr_defs pptr_base_num kernel_window_def
                        init_arch_state_def init_vspace_uses_def
                  split: if_split_asm)
   apply unat_arith
  apply unat_arith
  done

lemma invs_A:
  "invs init_A_st" (is "invs ?st")
  supply is_aligned_def[THEN iffD2, simp]
  supply image_cong_simp [cong del]
  supply pptr_base_num[simp] kernel_elf_base_def[simp]
  apply (simp add: invs_def)
  apply (rule conjI)
   prefer 2
   apply (simp add: cur_tcb_def state_defs obj_at_def)
  apply (simp add: valid_state_def)
  apply (rule conjI)
   apply (simp add: valid_pspace_def)
   apply (rule conjI)
    apply (clarsimp simp: valid_objs_def state_defs wellformed_pte_def valid_pt_range_def
                          valid_obj_def valid_vm_rights_def vm_kernel_only_def
                          dom_if_Some cte_level_bits_def)
    apply (clarsimp simp: valid_tcb_def tcb_cap_cases_def is_master_reply_cap_def
                          valid_cap_def obj_at_def valid_tcb_state_def valid_arch_tcb_def
                          cap_aligned_def word_bits_def valid_ipc_buffer_cap_simps)+
    apply (clarsimp simp: valid_cs_def word_bits_def cte_level_bits_def
                          valid_tcb_def
                   split: if_split_asm)
   apply (simp add: pspace_aligned_init_A pspace_distinct_init_A)
    apply (clarsimp simp: if_live_then_nonz_cap_def obj_at_def state_defs live_def hyp_live_def arch_live_def)
    apply (clarsimp simp: zombies_final_def cte_wp_at_cases state_defs ex_nonz_cap_to_def
                          tcb_cap_cases_def is_zombie_def)
   apply (clarsimp simp: sym_refs_def state_refs_of_def state_defs state_hyp_refs_of_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_mdb_def init_cdt_def no_mloop_def
                         mdb_cte_at_def)
   apply (clarsimp simp: untyped_mdb_def caps_of_state_init_A_st_Null
                         untyped_inc_def ut_revocable_def
                         irq_revocable_def reply_master_revocable_def
                         reply_mdb_def reply_caps_mdb_def
                         reply_masters_mdb_def valid_arch_mdb_def)
   apply (simp add:descendants_inc_def)
  apply (rule conjI)
   apply (simp add: valid_ioc_def init_A_st_def init_ioc_def cte_wp_at_cases2)
   apply (intro allI impI, elim exE conjE)
   apply (case_tac obj, simp_all add: cap_of_def)
   apply (clarsimp simp: init_kheap_def split: if_split_asm)
  apply (rule conjI)
   apply (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def state_defs valid_arch_idle_def)
  apply (rule conjI, clarsimp simp: only_idle_def pred_tcb_at_def obj_at_def state_defs)
  apply (rule conjI, clarsimp simp: if_unsafe_then_cap_def caps_of_state_init_A_st_Null)
  apply (subgoal_tac "valid_reply_caps ?st \<and> valid_reply_masters ?st \<and> valid_global_refs ?st")
   prefer 2
   subgoal
     using cte_wp_at_init_A_st_Null
     by (fastforce simp: valid_reply_caps_def unique_reply_caps_def
                         has_reply_cap_def is_reply_cap_to_def pred_tcb_at_def obj_at_def
                         caps_of_state_init_A_st_Null is_master_reply_cap_to_def
                         valid_reply_masters_def valid_global_refs_def
                         valid_refs_def[unfolded cte_wp_at_caps_of_state])
  apply (clarsimp, (thin_tac "_")+) (* use new proven assumptions, then drop them *)
  apply (rule conjI)
   apply (clarsimp simp: valid_arch_state_def)
   apply (rule conjI)
    apply (clarsimp simp: valid_asid_table_def state_defs)
   apply (simp add: valid_arch_state_def state_defs obj_at_def a_type_def cur_vcpu_2_def
                    vmid_inv_def is_inv_def vmid_for_asid_2_def obind_def
                    valid_global_tables_2_def empty_pt_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_irq_node_def obj_at_def state_defs
                         is_cap_table_def wf_empty_bits
                         init_irq_ptrs_all_ineqs cte_level_bits_def
                         init_irq_ptrs_eq[unfolded cte_level_bits_def])
   apply (intro conjI)
    apply (rule inj_onI)
    apply (simp add: init_irq_ptrs_eq[unfolded cte_level_bits_def])
   apply (clarsimp; word_bitwise)
  apply (simp add: valid_irq_handlers_def caps_of_state_init_A_st_Null
                   ran_def cong: rev_conj_cong)
  apply (rule conjI)
   apply (clarsimp simp: valid_irq_states_def state_defs init_machine_state_def
                         valid_irq_masks_def init_irq_masks_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_machine_state_def state_defs
                         init_machine_state_def init_underlying_memory_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_arch_caps_def valid_asid_pool_caps_def unique_table_caps_def
                         caps_of_state_init_A_st_Null valid_table_caps_def unique_table_refs_def)
   apply (clarsimp simp: state_defs)
  apply (clarsimp simp: valid_global_objs_def valid_kernel_mappings_def valid_asid_map_def)
  apply (rule conjI)
   apply (clarsimp simp: equal_kernel_mappings_def)
  apply (simp add: pspace_in_kernel_window_init_A_st cap_refs_in_kernel_window_def
                   caps_of_state_init_A_st_Null valid_refs_def[unfolded cte_wp_at_caps_of_state])
  done

end

end