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

subsection "Configurations and labels"
text {*
  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.
*}
type_synonym 'n conf = "('n list) multiset"

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

subsection {* Monitors *}
text {*
  The following defines the monitors of nodes, stacks, configurations, step labels and paths (sequences of step labels)
*}
definition
  -- "The monitors of a node are the monitors the procedure of the node synchronizes on"
  "mon_n fg n == mon fg (proc_of fg n)"

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

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

-- "The monitors of a step label are the monitors of procedures that are called by this step"
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)

-- "The monitors of a path are the monitors of all procedures that are called on the path"
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_of c)"
  by (unfold mon_c_def set_of_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_unconc: "mon_c fg (a+b) = mon_c fg a \<union> mon_c fg b"
  by (unfold mon_c_def) auto

lemma mon_cI: "\<lbrakk>s:#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:#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\<le>c' \<Longrightarrow> mon_c fg c \<subseteq> mon_c fg c'"
  by (unfold mon_c_def) (auto intro: mset_le_trans_elem)

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 {* Valid configurations *}
text_raw {*\label{sec:Semantics:validity}*}
text {* We call a configuration {\em valid} if each monitor is owned by at most one thread. *}
definition
  "valid fg c == \<forall>s s'. {#s#}+{#s'#} \<le> 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 mset_le_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#} \<le> c+c'")
  apply (auto dest: mset_le_mono_add iff add: mset_le_single_conv[symmetric] simp del: mset_le_single_conv)
  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_unconc:
  "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_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'#} \<le> 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 {* Configurations at control points *}

-- {* A stack is {\em at} @{term U} if its top node is from the set @{term U} *}
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

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

lemma atU_fmt: "\<lbrakk>atU U c; !!ui r. \<lbrakk>ui#r :# 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_xchange_stack: "atU U ({#u#r#}+c) \<Longrightarrow> atU U ({#u#r'#}+c)"
  by (simp)

-- {* 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} *}
definition
  "atUV U V c == \<exists>su sv. {#su#}+{#sv#} \<le> 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_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 {* Operational semantics *}

subsubsection "Semantic reference point"
text {* We now define our semantic reference point. We assess correctness and completeness of analyses relative to this reference point. *}
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
  -- "A base edge transforms the top node of one stack and leaves the other stacks untouched."
  refpoint_base: "\<lbrakk> (u,Base a,v)\<in>edges fg; valid fg ({#u#r#}+c) \<rbrakk>
    \<Longrightarrow> ({#u#r#}+c,LBase a,{#v#r#}+c)\<in>refpoint fg" |
  -- "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."
  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> ({#u#r#}+c,LCall p, {#entry fg p#v#r#}+c)\<in>refpoint fg" |
  -- "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."
  refpoint_ret: "\<lbrakk> valid fg ({#return fg p#r#}+c) \<rbrakk>
    \<Longrightarrow> ({#return fg p#r#}+c,LRet,({#r#}+c))\<in>refpoint fg" |
  -- "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."
  refpoint_spawn: "\<lbrakk> (u,Spawn p,v)\<in>edges fg; valid fg ({#u#r#}+c) \<rbrakk>
    \<Longrightarrow> ({#u#r#}+c,LSpawn p,{#v#r#}+{#[entry fg p]#}+c)\<in>refpoint fg"

text {*
  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.
*}

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,{#[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)
*)

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

subsection "Basic properties"
subsubsection "Validity"
text_raw{*\label{sec:Semantics:valid_preserve}*}
lemma (in flowgraph) trss_valid_preserve_s:
  "\<lbrakk>valid fg ({#s#}+c); ((s,c),e,(s',c'))\<in>trss fg\<rbrakk> \<Longrightarrow> valid fg ({#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 ({#s#}+c)\<rbrakk> \<Longrightarrow> valid fg ({#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 ({#s'#}+c')"
  by (rule gtrp_preserve[where P="valid fg"]) (auto dest: trss_valid_preserve_s)

subsubsection "Equivalence to reference point"
text_raw {* \label{sec:Semantics: refpoint_eq} *}
-- {* 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. *}
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)
  apply (erule gtrE)
  apply (erule trss.cases)
  apply (auto intro: refpoint.intros simp add: union_assoc[symmetric])
  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 {* Case distinctions *}

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:#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 (fast dest: trcl_uncons)
  from SPLIT2 show ?case proof (rule IHP(1))
    fix csp
    assume C'FMT: "c'=csp+ch" and CSPFMT: "!!s. s :# 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 :# {#[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:#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:#csp" and M: "x\<in>mon_s fg s" by (unfold mon_c_def, auto)
  moreover assume "\<forall>s. 0 < count csp s \<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 = {#s#} + ce" "c' = {#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) -- "Cases for base- and spawn edge are discharged automatically"
      -- "Case: call-edge"
    case (goal1 ca p r u vv) with SPLIT1 SPLIT2 show ?case by fastforce
  next
      -- "Case: return edge"
    case (goal2 q r ca) note CC=this
    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

-- {* This lemma is better suited for application in soundness proofs of constraint systems than @{thm [source] flowgraph.trss_find_call}*}
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

-- {* Specialized version of @{thm [source] flowgraph.trss_bot_proc_const}that comes in handy for precision proofs of constraint systems *}
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\<le>c'"
  by (auto elim!: trss.cases)
lemma trss_env_increasing: "((s,c),w,(s',c'))\<in>trcl (trss fg) \<Longrightarrow> c\<le>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


section \<open>Operational Semantics\<close>

theory RG_Tran
imports RG_Com
begin

subsection \<open>Semantics of Component Programs\<close>

subsubsection \<open>Environment transitions\<close>

type_synonym 'a conf = "(('a com) option) \<times> 'a"

inductive_set
  etran :: "('a conf \<times> 'a conf) set"
  and etran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool"  ("_ -e\<rightarrow> _" [81,81] 80)
where
  "P -e\<rightarrow> Q \<equiv> (P,Q) \<in> etran"
| Env: "(P, s) -e\<rightarrow> (P, t)"

lemma etranE: "c -e\<rightarrow> c' \<Longrightarrow> (\<And>P s t. c = (P, s) \<Longrightarrow> c' = (P, t) \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (induct c, induct c', erule etran.cases, blast)

subsubsection \<open>Component transitions\<close>

inductive_set
  ctran :: "('a conf \<times> 'a conf) set"
  and ctran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool"   ("_ -c\<rightarrow> _" [81,81] 80)
  and ctrans :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool"   ("_ -c*\<rightarrow> _" [81,81] 80)
where
  "P -c\<rightarrow> Q \<equiv> (P,Q) \<in> ctran"
| "P -c*\<rightarrow> Q \<equiv> (P,Q) \<in> ctran\<^sup>*"

| Basic:  "(Some(Basic f), s) -c\<rightarrow> (None, f s)"

| Seq1:   "(Some P0, s) -c\<rightarrow> (None, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some P1, t)"

| Seq2:   "(Some P0, s) -c\<rightarrow> (Some P2, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some(Seq P2 P1), t)"

| CondT: "s\<in>b  \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P1, s)"
| CondF: "s\<notin>b \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P2, s)"

| WhileF: "s\<notin>b \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (None, s)"
| WhileT: "s\<in>b  \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (Some(Seq P (While b P)), s)"

| Await:  "\<lbrakk>s\<in>b; (Some P, s) -c*\<rightarrow> (None, t)\<rbrakk> \<Longrightarrow> (Some(Await b P), s) -c\<rightarrow> (None, t)"

monos "rtrancl_mono"

subsection \<open>Semantics of Parallel Programs\<close>

type_synonym 'a par_conf = "('a par_com) \<times> 'a"

inductive_set
  par_etran :: "('a par_conf \<times> 'a par_conf) set"
  and par_etran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pe\<rightarrow> _" [81,81] 80)
where
  "P -pe\<rightarrow> Q \<equiv> (P,Q) \<in> par_etran"
| ParEnv:  "(Ps, s) -pe\<rightarrow> (Ps, t)"

inductive_set
  par_ctran :: "('a par_conf \<times> 'a par_conf) set"
  and par_ctran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pc\<rightarrow> _" [81,81] 80)
where
  "P -pc\<rightarrow> Q \<equiv> (P,Q) \<in> par_ctran"
| ParComp: "\<lbrakk>i<length Ps; (Ps!i, s) -c\<rightarrow> (r, t)\<rbrakk> \<Longrightarrow> (Ps, s) -pc\<rightarrow> (Ps[i:=r], t)"

lemma par_ctranE: "c -pc\<rightarrow> c' \<Longrightarrow>
  (\<And>i Ps s r t. c = (Ps, s) \<Longrightarrow> c' = (Ps[i := r], t) \<Longrightarrow> i < length Ps \<Longrightarrow>
     (Ps ! i, s) -c\<rightarrow> (r, t) \<Longrightarrow> P) \<Longrightarrow> P"
  by (induct c, induct c', erule par_ctran.cases, blast)

subsection \<open>Computations\<close>

subsubsection \<open>Sequential computations\<close>

type_synonym 'a confs = "'a conf list"

inductive_set cptn :: "'a confs set"
where
  CptnOne: "[(P,s)] \<in> cptn"
| CptnEnv: "(P, t)#xs \<in> cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> cptn"
| CptnComp: "\<lbrakk>(P,s) -c\<rightarrow> (Q,t); (Q, t)#xs \<in> cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> cptn"

definition cp :: "('a com) option \<Rightarrow> 'a \<Rightarrow> ('a confs) set" where
  "cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> cptn}"

subsubsection \<open>Parallel computations\<close>

type_synonym 'a par_confs = "'a par_conf list"

inductive_set par_cptn :: "'a par_confs set"
where
  ParCptnOne: "[(P,s)] \<in> par_cptn"
| ParCptnEnv: "(P,t)#xs \<in> par_cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> par_cptn"
| ParCptnComp: "\<lbrakk> (P,s) -pc\<rightarrow> (Q,t); (Q,t)#xs \<in> par_cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> par_cptn"

definition par_cp :: "'a par_com \<Rightarrow> 'a \<Rightarrow> ('a par_confs) set" where
  "par_cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> par_cptn}"

subsection\<open>Modular Definition of Computation\<close>

definition lift :: "'a com \<Rightarrow> 'a conf \<Rightarrow> 'a conf" where
  "lift Q \<equiv> \<lambda>(P, s). (if P=None then (Some Q,s) else (Some(Seq (the P) Q), s))"

inductive_set cptn_mod :: "('a confs) set"
where
  CptnModOne: "[(P, s)] \<in> cptn_mod"
| CptnModEnv: "(P, t)#xs \<in> cptn_mod \<Longrightarrow> (P, s)#(P, t)#xs \<in> cptn_mod"
| CptnModNone: "\<lbrakk>(Some P, s) -c\<rightarrow> (None, t); (None, t)#xs \<in> cptn_mod \<rbrakk> \<Longrightarrow> (Some P,s)#(None, t)#xs \<in>cptn_mod"
| CptnModCondT: "\<lbrakk>(Some P0, s)#ys \<in> cptn_mod; s \<in> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P0, s)#ys \<in> cptn_mod"
| CptnModCondF: "\<lbrakk>(Some P1, s)#ys \<in> cptn_mod; s \<notin> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P1, s)#ys \<in> cptn_mod"
| CptnModSeq1: "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; zs=map (lift P1) xs \<rbrakk>
                 \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"
| CptnModSeq2:
  "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; fst(last ((Some P0, s)#xs)) = None;
  (Some P1, snd(last ((Some P0, s)#xs)))#ys \<in> cptn_mod;
  zs=(map (lift P1) xs)@ys \<rbrakk> \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"

| CptnModWhile1:
  "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; s \<in> b; zs=map (lift (While b P)) xs \<rbrakk>
  \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"
| CptnModWhile2:
  "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; fst(last ((Some P, s)#xs))=None; s \<in> b;
  zs=(map (lift (While b P)) xs)@ys;
  (Some(While b P), snd(last ((Some P, s)#xs)))#ys \<in> cptn_mod\<rbrakk>
  \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"

subsection \<open>Equivalence of Both Definitions.\<close>

lemma last_length: "((a#xs)!(length xs))=last (a#xs)"
  by (induct xs) auto

lemma div_seq [rule_format]: "list \<in> cptn_mod \<Longrightarrow>
 (\<forall>s P Q zs. list=(Some (Seq P Q), s)#zs \<longrightarrow>
  (\<exists>xs. (Some P, s)#xs \<in> cptn_mod  \<and> (zs=(map (lift Q) xs) \<or>
  ( fst(((Some P, s)#xs)!length xs)=None \<and>
  (\<exists>ys. (Some Q, snd(((Some P, s)#xs)!length xs))#ys \<in> cptn_mod
  \<and> zs=(map (lift (Q)) xs)@ys)))))"
apply(erule cptn_mod.induct)
apply simp_all
    apply clarify
    apply(force intro:CptnModOne)
   apply clarify
   apply(erule_tac x=Pa in allE)
   apply(erule_tac x=Q in allE)
   apply simp
   apply clarify
   apply(erule disjE)
    apply(rule_tac x="(Some Pa,t)#xsa" in exI)
    apply(rule conjI)
     apply clarify
     apply(erule CptnModEnv)
    apply(rule disjI1)
    apply(simp add:lift_def)
   apply clarify
   apply(rule_tac x="(Some Pa,t)#xsa" in exI)
   apply(rule conjI)
    apply(erule CptnModEnv)
   apply(rule disjI2)
   apply(rule conjI)
    apply(case_tac xsa,simp,simp)
   apply(rule_tac x="ys" in exI)
   apply(rule conjI)
    apply simp
   apply(simp add:lift_def)
  apply clarify
  apply(erule ctran.cases,simp_all)
 apply clarify
 apply(rule_tac x="xs" in exI)
 apply simp
 apply clarify
apply(rule_tac x="xs" in exI)
apply(simp add: last_length)
done

lemma cptn_onlyif_cptn_mod_aux [rule_format]:
  "\<forall>s Q t xs.((Some a, s), Q, t) \<in> ctran \<longrightarrow> (Q, t) # xs \<in> cptn_mod
  \<longrightarrow> (Some a, s) # (Q, t) # xs \<in> cptn_mod"
  supply [[simproc del: defined_all]]
apply(induct a)
apply simp_all
\<comment> \<open>basic\<close>
apply clarify
apply(erule ctran.cases,simp_all)
apply(rule CptnModNone,rule Basic,simp)
apply clarify
apply(erule ctran.cases,simp_all)
\<comment> \<open>Seq1\<close>
apply(rule_tac xs="[(None,ta)]" in CptnModSeq2)
  apply(erule CptnModNone)
  apply(rule CptnModOne)
 apply simp
apply simp
apply(simp add:lift_def)
\<comment> \<open>Seq2\<close>
apply(erule_tac x=sa in allE)
apply(erule_tac x="Some P2" in allE)
apply(erule allE,erule impE, assumption)
apply(drule div_seq,simp)
apply clarify
apply(erule disjE)
 apply clarify
 apply(erule allE,erule impE, assumption)
 apply(erule_tac CptnModSeq1)
 apply(simp add:lift_def)
apply clarify
apply(erule allE,erule impE, assumption)
apply(erule_tac CptnModSeq2)
  apply (simp add:last_length)
 apply (simp add:last_length)
apply(simp add:lift_def)
\<comment> \<open>Cond\<close>
apply clarify
apply(erule ctran.cases,simp_all)
apply(force elim: CptnModCondT)
apply(force elim: CptnModCondF)
\<comment> \<open>While\<close>
apply  clarify
apply(erule ctran.cases,simp_all)
apply(rule CptnModNone,erule WhileF,simp)
apply(drule div_seq,force)
apply clarify
apply (erule disjE)
 apply(force elim:CptnModWhile1)
apply clarify
apply(force simp add:last_length elim:CptnModWhile2)
\<comment> \<open>await\<close>
apply clarify
apply(erule ctran.cases,simp_all)
apply(rule CptnModNone,erule Await,simp+)
done

lemma cptn_onlyif_cptn_mod [rule_format]: "c \<in> cptn \<Longrightarrow> c \<in> cptn_mod"
apply(erule cptn.induct)
  apply(rule CptnModOne)
 apply(erule CptnModEnv)
apply(case_tac P)
 apply simp
 apply(erule ctran.cases,simp_all)
apply(force elim:cptn_onlyif_cptn_mod_aux)
done

lemma lift_is_cptn: "c\<in>cptn \<Longrightarrow> map (lift P) c \<in> cptn"
apply(erule cptn.induct)
  apply(force simp add:lift_def CptnOne)
 apply(force intro:CptnEnv simp add:lift_def)
apply(force simp add:lift_def intro:CptnComp Seq2 Seq1 elim:ctran.cases)
done

lemma cptn_append_is_cptn [rule_format]:
 "\<forall>b a. b#c1\<in>cptn \<longrightarrow>  a#c2\<in>cptn \<longrightarrow> (b#c1)!length c1=a \<longrightarrow> b#c1@c2\<in>cptn"
apply(induct c1)
 apply simp
apply clarify
apply(erule cptn.cases,simp_all)
 apply(force intro:CptnEnv)
apply(force elim:CptnComp)
done

lemma last_lift: "\<lbrakk>xs\<noteq>[]; fst(xs!(length xs - (Suc 0)))=None\<rbrakk>
 \<Longrightarrow> fst((map (lift P) xs)!(length (map (lift P) xs)- (Suc 0)))=(Some P)"
  by (cases "(xs ! (length xs - (Suc 0)))") (simp add:lift_def)

lemma last_fst [rule_format]: "P((a#x)!length x) \<longrightarrow> \<not>P a \<longrightarrow> P (x!(length x - (Suc 0)))"
  by (induct x) simp_all

lemma last_fst_esp:
 "fst(((Some a,s)#xs)!(length xs))=None \<Longrightarrow> fst(xs!(length xs - (Suc 0)))=None"
apply(erule last_fst)
apply simp
done

lemma last_snd: "xs\<noteq>[] \<Longrightarrow>
  snd(((map (lift P) xs))!(length (map (lift P) xs) - (Suc 0)))=snd(xs!(length xs - (Suc 0)))"
  by (cases "(xs ! (length xs - (Suc 0)))") (simp_all add:lift_def)

lemma Cons_lift: "(Some (Seq P Q), s) # (map (lift Q) xs) = map (lift Q) ((Some P, s) # xs)"
  by (simp add:lift_def)

lemma Cons_lift_append:
  "(Some (Seq P Q), s) # (map (lift Q) xs) @ ys = map (lift Q) ((Some P, s) # xs)@ ys "
  by (simp add:lift_def)

lemma lift_nth: "i<length xs \<Longrightarrow> map (lift Q) xs ! i = lift Q  (xs! i)"
  by (simp add:lift_def)

lemma snd_lift: "i< length xs \<Longrightarrow> snd(lift Q (xs ! i))= snd (xs ! i)"
  by (cases "xs!i") (simp add:lift_def)

lemma cptn_if_cptn_mod: "c \<in> cptn_mod \<Longrightarrow> c \<in> cptn"
apply(erule cptn_mod.induct)
        apply(rule CptnOne)
       apply(erule CptnEnv)
      apply(erule CptnComp,simp)
     apply(rule CptnComp)
      apply(erule CondT,simp)
    apply(rule CptnComp)
     apply(erule CondF,simp)
\<comment> \<open>Seq1\<close>
apply(erule cptn.cases,simp_all)
  apply(rule CptnOne)
 apply clarify
 apply(drule_tac P=P1 in lift_is_cptn)
 apply(simp add:lift_def)
 apply(rule CptnEnv,simp)
apply clarify
apply(simp add:lift_def)
apply(rule conjI)
 apply clarify
 apply(rule CptnComp)
  apply(rule Seq1,simp)
 apply(drule_tac P=P1 in lift_is_cptn)
 apply(simp add:lift_def)
apply clarify
apply(rule CptnComp)
 apply(rule Seq2,simp)
apply(drule_tac P=P1 in lift_is_cptn)
apply(simp add:lift_def)
\<comment> \<open>Seq2\<close>
apply(rule cptn_append_is_cptn)
  apply(drule_tac P=P1 in lift_is_cptn)
  apply(simp add:lift_def)
 apply simp
apply(simp split: if_split_asm)
apply(frule_tac P=P1 in last_lift)
 apply(rule last_fst_esp)
 apply (simp add:last_length)
apply(simp add:Cons_lift lift_def split_def last_conv_nth)
\<comment> \<open>While1\<close>
apply(rule CptnComp)
 apply(rule WhileT,simp)
apply(drule_tac P="While b P" in lift_is_cptn)
apply(simp add:lift_def)
\<comment> \<open>While2\<close>
apply(rule CptnComp)
 apply(rule WhileT,simp)
apply(rule cptn_append_is_cptn)
  apply(drule_tac P="While b P" in lift_is_cptn)
  apply(simp add:lift_def)
 apply simp
apply(simp split: if_split_asm)
apply(frule_tac P="While b P" in last_lift)
 apply(rule last_fst_esp,simp add:last_length)
apply(simp add:Cons_lift lift_def split_def last_conv_nth)
done

theorem cptn_iff_cptn_mod: "(c \<in> cptn) = (c \<in> cptn_mod)"
apply(rule iffI)
 apply(erule cptn_onlyif_cptn_mod)
apply(erule cptn_if_cptn_mod)
done

section \<open>Validity  of Correctness Formulas\<close>

subsection \<open>Validity for Component Programs.\<close>

type_synonym 'a rgformula =
  "'a com \<times> 'a set \<times> ('a \<times> 'a) set \<times> ('a \<times> 'a) set \<times> 'a set"

definition assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a confs) set" where
  "assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
               c!i -e\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"

definition comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a confs) set" where
  "comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
               c!i -c\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
               (fst (last c) = None \<longrightarrow> snd (last c) \<in> post)}"

definition com_validity :: "'a com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
                 ("\<Turnstile> _ sat [_, _, _, _]" [60,0,0,0,0] 45) where
  "\<Turnstile> P sat [pre, rely, guar, post] \<equiv>
   \<forall>s. cp (Some P) s \<inter> assum(pre, rely) \<subseteq> comm(guar, post)"

subsection \<open>Validity for Parallel Programs.\<close>

definition All_None :: "(('a com) option) list \<Rightarrow> bool" where
  "All_None xs \<equiv> \<forall>c\<in>set xs. c=None"

definition par_assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a par_confs) set" where
  "par_assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
             c!i -pe\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"

definition par_comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a par_confs) set" where
  "par_comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
        c!i -pc\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
         (All_None (fst (last c)) \<longrightarrow> snd( last c) \<in> post)}"

definition par_com_validity :: "'a  par_com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set
\<Rightarrow> 'a set \<Rightarrow> bool"  ("\<Turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45) where
  "\<Turnstile> Ps SAT [pre, rely, guar, post] \<equiv>
   \<forall>s. par_cp Ps s \<inter> par_assum(pre, rely) \<subseteq> par_comm(guar, post)"

subsection \<open>Compositionality of the Semantics\<close>

subsubsection \<open>Definition of the conjoin operator\<close>

definition same_length :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" where
  "same_length c clist \<equiv> (\<forall>i<length clist. length(clist!i)=length c)"

definition same_state :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" where
  "same_state c clist \<equiv> (\<forall>i <length clist. \<forall>j<length c. snd(c!j) = snd((clist!i)!j))"

definition same_program :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" where
  "same_program c clist \<equiv> (\<forall>j<length c. fst(c!j) = map (\<lambda>x. fst(nth x j)) clist)"

definition compat_label :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" where
  "compat_label c clist \<equiv> (\<forall>j. Suc j<length c \<longrightarrow>
         (c!j -pc\<rightarrow> c!Suc j \<and> (\<exists>i<length clist. (clist!i)!j -c\<rightarrow> (clist!i)! Suc j \<and>
                       (\<forall>l<length clist. l\<noteq>i \<longrightarrow> (clist!l)!j -e\<rightarrow> (clist!l)! Suc j))) \<or>
         (c!j -pe\<rightarrow> c!Suc j \<and> (\<forall>i<length clist. (clist!i)!j -e\<rightarrow> (clist!i)! Suc j)))"

definition conjoin :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"  ("_ \<propto> _" [65,65] 64) where
  "c \<propto> clist \<equiv> (same_length c clist) \<and> (same_state c clist) \<and> (same_program c clist) \<and> (compat_label c clist)"

subsubsection \<open>Some previous lemmas\<close>

lemma list_eq_if [rule_format]:
  "\<forall>ys. xs=ys \<longrightarrow> (length xs = length ys) \<longrightarrow> (\<forall>i<length xs. xs!i=ys!i)"
  by (induct xs) auto

lemma list_eq: "(length xs = length ys \<and> (\<forall>i<length xs. xs!i=ys!i)) = (xs=ys)"
apply(rule iffI)
 apply clarify
 apply(erule nth_equalityI)
 apply simp+
done

lemma nth_tl: "\<lbrakk> ys!0=a; ys\<noteq>[] \<rbrakk> \<Longrightarrow> ys=(a#(tl ys))"
  by (cases ys) simp_all

lemma nth_tl_if [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P ys \<longrightarrow> P (a#(tl ys))"
  by (induct ys) simp_all

lemma nth_tl_onlyif [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P (a#(tl ys)) \<longrightarrow> P ys"
  by (induct ys) simp_all

lemma seq_not_eq1: "Seq c1 c2\<noteq>c1"
  by (induct c1) auto

lemma seq_not_eq2: "Seq c1 c2\<noteq>c2"
  by (induct c2) auto

lemma if_not_eq1: "Cond b c1 c2 \<noteq>c1"
  by (induct c1) auto

lemma if_not_eq2: "Cond b c1 c2\<noteq>c2"
  by (induct c2) auto

lemmas seq_and_if_not_eq [simp] = seq_not_eq1 seq_not_eq2
seq_not_eq1 [THEN not_sym] seq_not_eq2 [THEN not_sym]
if_not_eq1 if_not_eq2 if_not_eq1 [THEN not_sym] if_not_eq2 [THEN not_sym]

lemma prog_not_eq_in_ctran_aux:
  assumes c: "(P,s) -c\<rightarrow> (Q,t)"
  shows "P\<noteq>Q" using c
  by (induct x1 \<equiv> "(P,s)" x2 \<equiv> "(Q,t)" arbitrary: P s Q t) auto

lemma prog_not_eq_in_ctran [simp]: "\<not> (P,s) -c\<rightarrow> (P,t)"
apply clarify
apply(drule prog_not_eq_in_ctran_aux)
apply simp
done

lemma prog_not_eq_in_par_ctran_aux [rule_format]: "(P,s) -pc\<rightarrow> (Q,t) \<Longrightarrow> (P\<noteq>Q)"
apply(erule par_ctran.induct)
apply(drule prog_not_eq_in_ctran_aux)
apply clarify
apply(drule list_eq_if)
 apply simp_all
apply force
done

lemma prog_not_eq_in_par_ctran [simp]: "\<not> (P,s) -pc\<rightarrow> (P,t)"
apply clarify
apply(drule prog_not_eq_in_par_ctran_aux)
apply simp
done

lemma tl_in_cptn: "\<lbrakk> a#xs \<in>cptn; xs\<noteq>[] \<rbrakk> \<Longrightarrow> xs\<in>cptn"
  by (force elim: cptn.cases)

lemma tl_zero[rule_format]:
  "P (ys!Suc j) \<longrightarrow> Suc j<length ys \<longrightarrow> ys\<noteq>[] \<longrightarrow> P (tl(ys)!j)"
  by (induct ys) simp_all

subsection \<open>The Semantics is Compositional\<close>

lemma aux_if [rule_format]:
  "\<forall>xs s clist. (length clist = length xs \<and> (\<forall>i<length xs. (xs!i,s)#clist!i \<in> cptn)
  \<and> ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#snd i) (zip xs clist))
   \<longrightarrow> (xs, s)#ys \<in> par_cptn)"
apply(induct ys)
 apply(clarify)
 apply(rule ParCptnOne)
apply(clarify)
apply(simp add:conjoin_def compat_label_def)
apply clarify
apply(erule_tac x="0" and P="\<lambda>j. H j \<longrightarrow> (P j \<or> Q j)" for H P Q in all_dupE, simp)
apply(erule disjE)
\<comment> \<open>first step is a Component step\<close>
 apply clarify
 apply simp
 apply(subgoal_tac "a=(xs[i:=(fst(clist!i!0))])")
  apply(subgoal_tac "b=snd(clist!i!0)",simp)
   prefer 2
   apply(simp add: same_state_def)
   apply(erule_tac x=i in allE,erule impE,assumption,
         erule_tac x=1 and P="\<lambda>j. (H j) \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE, simp)
  prefer 2
  apply(simp add:same_program_def)
  apply(erule_tac x=1 and P="\<lambda>j. H j \<longrightarrow> (fst (s j))=(t j)" for H s t in allE,simp)
  apply(rule nth_equalityI,simp)
  apply clarify
  apply(case_tac "i=ia",simp,simp)
  apply(erule_tac x=ia and P="\<lambda>j. H j \<longrightarrow> I j \<longrightarrow> J j" for H I J in allE)
  apply(drule_tac t=i in not_sym,simp)
  apply(erule etranE,simp)
 apply(rule ParCptnComp)
  apply(erule ParComp,simp)
\<comment> \<open>applying the induction hypothesis\<close>
 apply(erule_tac x="xs[i := fst (clist ! i ! 0)]" in allE)
 apply(erule_tac x="snd (clist ! i ! 0)" in allE)
 apply(erule mp)
 apply(rule_tac x="map tl clist" in exI,simp)
 apply(rule conjI,clarify)
  apply(case_tac "i=ia",simp)
   apply(rule nth_tl_if)
     apply(force simp add:same_length_def length_Suc_conv)
    apply simp
   apply(erule allE,erule impE,assumption,erule tl_in_cptn)
   apply(force simp add:same_length_def length_Suc_conv)
  apply(rule nth_tl_if)
    apply(force simp add:same_length_def length_Suc_conv)
   apply(simp add:same_state_def)
   apply(erule_tac x=ia in allE, erule impE, assumption,
     erule_tac x=1 and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE)
   apply(erule_tac x=ia and P="\<lambda>j. H j \<longrightarrow> I j \<longrightarrow> J j" for H I J in allE)
   apply(drule_tac t=i  in not_sym,simp)
   apply(erule etranE,simp)
  apply(erule allE,erule impE,assumption,erule tl_in_cptn)
  apply(force simp add:same_length_def length_Suc_conv)
 apply(simp add:same_length_def same_state_def)
 apply(rule conjI)
  apply clarify
  apply(case_tac j,simp,simp)
  apply(erule_tac x=ia in allE, erule impE, assumption,
        erule_tac x="Suc(Suc nat)" and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE,simp)
  apply(force simp add:same_length_def length_Suc_conv)
 apply(rule conjI)
  apply(simp add:same_program_def)
  apply clarify
  apply(case_tac j,simp)
   apply(rule nth_equalityI,simp)
   apply clarify
   apply(case_tac "i=ia",simp,simp)
  apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. H j \<longrightarrow> (fst (s j))=(t j)" for H s t in allE,simp)
  apply(rule nth_equalityI,simp,simp)
  apply(force simp add:length_Suc_conv)
 apply(rule allI,rule impI)
 apply(erule_tac x="Suc j" and P="\<lambda>j. H j \<longrightarrow> (I j \<or> J j)" for H I J in allE,simp)
 apply(erule disjE)
  apply clarify
  apply(rule_tac x=ia in exI,simp)
  apply(case_tac "i=ia",simp)
   apply(rule conjI)
    apply(force simp add: length_Suc_conv)
   apply clarify
   apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> I j \<longrightarrow> J j" for H I J in allE,erule impE,assumption)
   apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> I j \<longrightarrow> J j" for H I J in allE,erule impE,assumption)
   apply simp
   apply(case_tac j,simp)
    apply(rule tl_zero)
      apply(erule_tac x=l in allE, erule impE, assumption,
            erule_tac x=1 and P="\<lambda>j.  (H j) \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE,simp)
      apply(force elim:etranE intro:Env)
     apply force
    apply force
   apply simp
   apply(rule tl_zero)
     apply(erule tl_zero)
      apply force
     apply force
    apply force
   apply force
  apply(rule conjI,simp)
   apply(rule nth_tl_if)
     apply force
    apply(erule_tac x=ia  in allE, erule impE, assumption,
          erule_tac x=1 and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE)
    apply(erule_tac x=ia and P="\<lambda>j. H j \<longrightarrow> I j \<longrightarrow> J j" for H I J in allE)
    apply(drule_tac t=i  in not_sym,simp)
    apply(erule etranE,simp)
   apply(erule tl_zero)
    apply force
   apply force
  apply clarify
  apply(case_tac "i=l",simp)
   apply(rule nth_tl_if)
     apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
    apply simp
   apply(erule_tac P="\<lambda>j. H j \<longrightarrow> I j \<longrightarrow> J j" for H I J in allE,erule impE,assumption,erule impE,assumption)
   apply(erule tl_zero,force)
   apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
   apply(rule nth_tl_if)
     apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
    apply(erule_tac x=l  in allE, erule impE, assumption,
          erule_tac x=1 and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE)
    apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> I j \<longrightarrow> J j" for H I J in allE,erule impE, assumption,simp)
    apply(erule etranE,simp)
   apply(rule tl_zero)
    apply force
   apply force
  apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
 apply(rule disjI2)
 apply(case_tac j,simp)
  apply clarify
  apply(rule tl_zero)
    apply(erule_tac x=ia and P="\<lambda>j. H j \<longrightarrow> I j\<in>etran" for H I in allE,erule impE, assumption)
    apply(case_tac "i=ia",simp,simp)
    apply(erule_tac x=ia  in allE, erule impE, assumption,
    erule_tac x=1 and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE)
    apply(erule_tac x=ia and P="\<lambda>j. H j \<longrightarrow> I j \<longrightarrow> J j" for H I J in allE,erule impE, assumption,simp)
    apply(force elim:etranE intro:Env)
   apply force
  apply(erule_tac x=ia and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
 apply simp
 apply clarify
 apply(rule tl_zero)
   apply(rule tl_zero,force)
    apply force
   apply(erule_tac x=ia and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
  apply force
 apply(erule_tac x=ia and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
\<comment> \<open>first step is an environmental step\<close>
apply clarify
apply(erule par_etran.cases)
apply simp
apply(rule ParCptnEnv)
apply(erule_tac x="Ps" in allE)
apply(erule_tac x="t" in allE)
apply(erule mp)
apply(rule_tac x="map tl clist" in exI,simp)
apply(rule conjI)
 apply clarify
 apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> I j \<in> cptn" for H I in allE,simp)
 apply(erule cptn.cases)
   apply(simp add:same_length_def)
   apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
  apply(simp add:same_state_def)
  apply(erule_tac x=i  in allE, erule impE, assumption,
   erule_tac x=1 and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE,simp)
 apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> J j \<in>etran" for H J in allE,simp)
 apply(erule etranE,simp)
apply(simp add:same_state_def same_length_def)
apply(rule conjI,clarify)
 apply(case_tac j,simp,simp)
 apply(erule_tac x=i  in allE, erule impE, assumption,
       erule_tac x="Suc(Suc nat)" and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE,simp)
 apply(rule tl_zero)
   apply(simp)
  apply force
 apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
apply(rule conjI)
 apply(simp add:same_program_def)
 apply clarify
 apply(case_tac j,simp)
  apply(rule nth_equalityI,simp)
  apply clarify
  apply simp
 apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. H j \<longrightarrow> (fst (s j))=(t j)" for H s t in allE,simp)
 apply(rule nth_equalityI,simp,simp)
 apply(force simp add:length_Suc_conv)
apply(rule allI,rule impI)
apply(erule_tac x="Suc j" and P="\<lambda>j. H j \<longrightarrow> (I j \<or> J j)" for H I J in allE,simp)
apply(erule disjE)
 apply clarify
 apply(rule_tac x=i in exI,simp)
 apply(rule conjI)
  apply(erule_tac x=i and P="\<lambda>i. H i \<longrightarrow> J i \<in>etran" for H J in allE, erule impE, assumption)
  apply(erule etranE,simp)
  apply(erule_tac x=i  in allE, erule impE, assumption,
        erule_tac x=1 and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE,simp)
  apply(rule nth_tl_if)
   apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
  apply simp
 apply(erule tl_zero,force)
  apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
 apply clarify
 apply(erule_tac x=l and P="\<lambda>i. H i \<longrightarrow> J i \<in>etran" for H J in allE, erule impE, assumption)
 apply(erule etranE,simp)
 apply(erule_tac x=l  in allE, erule impE, assumption,
       erule_tac x=1 and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE,simp)
 apply(rule nth_tl_if)
   apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
  apply simp
  apply(rule tl_zero,force)
  apply force
 apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
apply(rule disjI2)
apply simp
apply clarify
apply(case_tac j,simp)
 apply(rule tl_zero)
   apply(erule_tac x=i and P="\<lambda>i. H i \<longrightarrow> J i \<in>etran" for H J in allE, erule impE, assumption)
   apply(erule_tac x=i and P="\<lambda>i. H i \<longrightarrow> J i \<in>etran" for H J in allE, erule impE, assumption)
   apply(force elim:etranE intro:Env)
  apply force
 apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
apply simp
apply(rule tl_zero)
  apply(rule tl_zero,force)
   apply force
  apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
 apply force
apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
done

lemma aux_onlyif [rule_format]: "\<forall>xs s. (xs, s)#ys \<in> par_cptn \<longrightarrow>
  (\<exists>clist. (length clist = length xs) \<and>
  (xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist) \<and>
  (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))"
  supply [[simproc del: defined_all]]
apply(induct ys)
 apply(clarify)
 apply(rule_tac x="map (\<lambda>i. []) [0..<length xs]" in exI)
 apply(simp add: conjoin_def same_length_def same_state_def same_program_def compat_label_def)
 apply(rule conjI)
  apply(rule nth_equalityI,simp,simp)
 apply(force intro: cptn.intros)
apply(clarify)
apply(erule par_cptn.cases,simp)
 apply simp
 apply(erule_tac x="xs" in allE)
 apply(erule_tac x="t" in allE,simp)
 apply clarify
 apply(rule_tac x="(map (\<lambda>j. (P!j, t)#(clist!j)) [0..<length P])" in exI,simp)
 apply(rule conjI)
  prefer 2
  apply clarify
  apply(rule CptnEnv,simp)
 apply(simp add:conjoin_def same_length_def same_state_def)
 apply (rule conjI)
  apply clarify
  apply(case_tac j,simp,simp)
 apply(rule conjI)
  apply(simp add:same_program_def)
  apply clarify
  apply(case_tac j,simp)
   apply(rule nth_equalityI,simp,simp)
  apply simp
  apply(rule nth_equalityI,simp,simp)
 apply(simp add:compat_label_def)
 apply clarify
 apply(case_tac j,simp)
  apply(simp add:ParEnv)
  apply clarify
  apply(simp add:Env)
 apply simp
 apply(erule_tac x=nat in allE,erule impE, assumption)
 apply(erule disjE,simp)
  apply clarify
  apply(rule_tac x=i in exI,simp)
 apply force
apply(erule par_ctran.cases,simp)
apply(erule_tac x="Ps[i:=r]" in allE)
apply(erule_tac x="ta" in allE,simp)
apply clarify
apply(rule_tac x="(map (\<lambda>j. (Ps!j, ta)#(clist!j)) [0..<length Ps]) [i:=((r, ta)#(clist!i))]" in exI,simp)
apply(rule conjI)
 prefer 2
 apply clarify
 apply(case_tac "i=ia",simp)
  apply(erule CptnComp)
  apply(erule_tac x=ia and P="\<lambda>j. H j \<longrightarrow> (I j \<in> cptn)" for H I in allE,simp)
 apply simp
 apply(erule_tac x=ia in allE)
 apply(rule CptnEnv,simp)
apply(simp add:conjoin_def)
apply (rule conjI)
 apply(simp add:same_length_def)
 apply clarify
 apply(case_tac "i=ia",simp,simp)
apply(rule conjI)
 apply(simp add:same_state_def)
 apply clarify
 apply(case_tac j, simp, simp (no_asm_simp))
 apply(case_tac "i=ia",simp,simp)
apply(rule conjI)
 apply(simp add:same_program_def)
 apply clarify
 apply(case_tac j,simp)
  apply(rule nth_equalityI,simp,simp)
 apply simp
 apply(rule nth_equalityI,simp,simp)
 apply(erule_tac x=nat and P="\<lambda>j. H j \<longrightarrow> (fst (a j))=((b j))" for H a b in allE)
 apply(case_tac nat)
  apply clarify
  apply(case_tac "i=ia",simp,simp)
 apply clarify
 apply(case_tac "i=ia",simp,simp)
apply(simp add:compat_label_def)
apply clarify
apply(case_tac j)
 apply(rule conjI,simp)
  apply(erule ParComp,assumption)
  apply clarify
  apply(rule_tac x=i in exI,simp)
 apply clarify
 apply(rule Env)
apply simp
apply(erule_tac x=nat and P="\<lambda>j. H j \<longrightarrow> (P j \<or> Q j)" for H P Q in allE,simp)
apply(erule disjE)
 apply clarify
 apply(rule_tac x=ia in exI,simp)
 apply(rule conjI)
  apply(case_tac "i=ia",simp,simp)
 apply clarify
 apply(case_tac "i=l",simp)
  apply(case_tac "l=ia",simp,simp)
  apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
 apply simp
 apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
apply clarify
apply(erule_tac x=ia and P="\<lambda>j. H j \<longrightarrow> (P j)\<in>etran" for H P in allE, erule impE, assumption)
apply(case_tac "i=ia",simp,simp)
done

lemma one_iff_aux: "xs\<noteq>[] \<Longrightarrow> (\<forall>ys. ((xs, s)#ys \<in> par_cptn) =
 (\<exists>clist. length clist= length xs \<and>
 ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist)) \<and>
 (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))) =
 (par_cp (xs) s = {c. \<exists>clist. (length clist)=(length xs) \<and>
 (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist})"
apply (rule iffI)
 apply(rule subset_antisym)
  apply(rule subsetI)
  apply(clarify)
  apply(simp add:par_cp_def cp_def)
  apply(case_tac x)
   apply(force elim:par_cptn.cases)
  apply simp
  apply(rename_tac a list)
  apply(erule_tac x="list" in allE)
  apply clarify
  apply simp
  apply(rule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in exI,simp)
 apply(rule subsetI)
 apply(clarify)
 apply(case_tac x)
  apply(erule_tac x=0 in allE)
  apply(simp add:cp_def conjoin_def same_length_def same_program_def same_state_def compat_label_def)
  apply clarify
  apply(erule cptn.cases,force,force,force)
 apply(simp add:par_cp_def conjoin_def  same_length_def same_program_def same_state_def compat_label_def)
 apply clarify
 apply(erule_tac x=0 and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in all_dupE)
 apply(subgoal_tac "a = xs")
  apply(subgoal_tac "b = s",simp)
   prefer 3
   apply(erule_tac x=0 and P="\<lambda>j. H j \<longrightarrow> (fst (s j))=((t j))" for H s t in allE)
   apply (simp add:cp_def)
   apply(rule nth_equalityI,simp,simp)
  prefer 2
  apply(erule_tac x=0 in allE)
  apply (simp add:cp_def)
  apply(erule_tac x=0 and P="\<lambda>j. H j \<longrightarrow> (\<forall>i. T i \<longrightarrow> (snd (d j i))=(snd (e j i)))" for H T d e in allE,simp)
  apply(erule_tac x=0 and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE,simp)
 apply(erule_tac x=list in allE)
 apply(rule_tac x="map tl clist" in exI,simp)
 apply(rule conjI)
  apply clarify
  apply(case_tac j,simp)
   apply(erule_tac x=i  in allE, erule impE, assumption,
        erule_tac x="0" and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE,simp)
  apply(erule_tac x=i  in allE, erule impE, assumption,
        erule_tac x="Suc nat" and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE)
  apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
  apply(case_tac "clist!i",simp,simp)
 apply(rule conjI)
  apply clarify
  apply(rule nth_equalityI,simp,simp)
  apply(case_tac j)
   apply clarify
   apply(erule_tac x=i in allE)
   apply(simp add:cp_def)
  apply clarify
  apply simp
  apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
  apply(case_tac "clist!i",simp,simp)
 apply(thin_tac "H = (\<exists>i. J i)" for H J)
 apply(rule conjI)
  apply clarify
  apply(erule_tac x=j in allE,erule impE, assumption,erule disjE)
   apply clarify
   apply(rule_tac x=i in exI,simp)
   apply(case_tac j,simp)
    apply(rule conjI)
     apply(erule_tac x=i in allE)
     apply(simp add:cp_def)
     apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
     apply(case_tac "clist!i",simp,simp)
    apply clarify
    apply(erule_tac x=l in allE)
    apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> I j \<longrightarrow> J j" for H I J in allE)
    apply clarify
    apply(simp add:cp_def)
    apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
    apply(case_tac "clist!l",simp,simp)
   apply simp
   apply(rule conjI)
    apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
    apply(case_tac "clist!i",simp,simp)
   apply clarify
   apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> I j \<longrightarrow> J j" for H I J in allE)
   apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
   apply(case_tac "clist!l",simp,simp)
  apply clarify
  apply(erule_tac x=i in allE)
  apply(simp add:cp_def)
  apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
  apply(case_tac "clist!i",simp)
  apply(rule nth_tl_if,simp,simp)
  apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (P j)\<in>etran" for H P in allE, erule impE, assumption,simp)
  apply(simp add:cp_def)
  apply clarify
  apply(rule nth_tl_if)
   apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
   apply(case_tac "clist!i",simp,simp)
  apply force
 apply force
apply clarify
apply(rule iffI)
 apply(simp add:par_cp_def)
 apply(erule_tac c="(xs, s) # ys" in equalityCE)
  apply simp
  apply clarify
  apply(rule_tac x="map tl clist" in exI)
  apply simp
  apply (rule conjI)
   apply(simp add:conjoin_def cp_def)
   apply(rule conjI)
    apply clarify
    apply(unfold same_length_def)
    apply clarify
    apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,simp)
   apply(rule conjI)
    apply(simp add:same_state_def)
    apply clarify
    apply(erule_tac x=i in allE, erule impE, assumption,
       erule_tac x=j and P="\<lambda>j. H j \<longrightarrow> (snd (d j))=(snd (e j))" for H d e in allE)
    apply(case_tac j,simp)
    apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
    apply(case_tac "clist!i",simp,simp)
   apply(rule conjI)
    apply(simp add:same_program_def)
    apply clarify
    apply(rule nth_equalityI,simp,simp)
    apply(case_tac j,simp)
    apply clarify
    apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
    apply(case_tac "clist!i",simp,simp)
   apply clarify
   apply(simp add:compat_label_def)
   apply(rule allI,rule impI)
   apply(erule_tac x=j in allE,erule impE, assumption)
   apply(erule disjE)
    apply clarify
    apply(rule_tac x=i in exI,simp)
    apply(rule conjI)
     apply(erule_tac x=i in allE)
     apply(case_tac j,simp)
      apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
      apply(case_tac "clist!i",simp,simp)
     apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
     apply(case_tac "clist!i",simp,simp)
    apply clarify
    apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> I j \<longrightarrow> J j" for H I J in allE)
    apply(erule_tac x=l and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE)
    apply(case_tac "clist!l",simp,simp)
    apply(erule_tac x=l in allE,simp)
   apply(rule disjI2)
   apply clarify
   apply(rule tl_zero)
     apply(case_tac j,simp,simp)
     apply(rule tl_zero,force)
      apply force
     apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
    apply force
   apply(erule_tac x=i and P="\<lambda>j. H j \<longrightarrow> (length (s j) = t)" for H s t in allE,force)
  apply clarify
  apply(erule_tac x=i in allE)
  apply(simp add:cp_def)
  apply(rule nth_tl_if)
    apply(simp add:conjoin_def)
    apply clarify
    apply(simp add:same_length_def)
    apply(erule_tac x=i in allE,simp)
   apply simp
  apply simp
 apply simp
apply clarify
apply(erule_tac c="(xs, s) # ys" in equalityCE)
 apply(simp add:par_cp_def)
apply simp
apply(erule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in allE)
apply simp
apply clarify
apply(simp add:cp_def)
done

theorem one: "xs\<noteq>[] \<Longrightarrow>
 par_cp xs s = {c. \<exists>clist. (length clist)=(length xs) \<and>
               (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist}"
apply(frule one_iff_aux)
apply(drule sym)
apply(erule iffD2)
apply clarify
apply(rule iffI)
 apply(erule aux_onlyif)
apply clarify
apply(force intro:aux_if)
done

end


(* Title:     Xml
   Author:    Christian Sternagel
   Author:    René Thiemann
*)

section \<open>A Sum Type with Bottom Element\<close>

theory Strict_Sum
imports
  "HOL-Library.Monad_Syntax"
  Error_Syntax
  Partial_Function_MR.Partial_Function_MR
begin

datatype (dead 'e, 'a) sum_bot (infixr "+\<^sub>\<bottom>" 10) = Bottom | Left 'e | Right 'a for map: sum_bot_map

subsection \<open>Setup for Partial Functions\<close>

abbreviation sum_bot_ord :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> 'e +\<^sub>\<bottom> 'a \<Rightarrow> bool"
where
  "sum_bot_ord \<equiv> flat_ord Bottom"

interpretation sum_bot:
  partial_function_definitions sum_bot_ord "flat_lub Bottom"
  by (rule flat_interpretation)

declaration \<open>
Partial_Function.init
  "sum_bot"
  @{term sum_bot.fixp_fun}
  @{term sum_bot.mono_body}
  @{thm sum_bot.fixp_rule_uc}
  @{thm sum_bot.fixp_induct_uc}
  NONE
\<close>

subsection \<open>Monad Setup\<close>

fun bind :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> ('a \<Rightarrow> ('e +\<^sub>\<bottom> 'b)) \<Rightarrow> 'e +\<^sub>\<bottom> 'b"
where
  "bind Bottom f = Bottom" |
  "bind (Left e) f = Left e" |
  "bind (Right x) f = f x"

abbreviation mono_sum_bot :: "(('a \<Rightarrow> ('e +\<^sub>\<bottom> 'b)) \<Rightarrow> 'f +\<^sub>\<bottom> 'c) \<Rightarrow> bool"
where
  "mono_sum_bot \<equiv> monotone (fun_ord sum_bot_ord) sum_bot_ord"

(* TODO: perhaps use Partial_Function.bind_mono to proof this result immediately *)
lemma bind_mono [partial_function_mono]:
  assumes mf: "mono_sum_bot B" and mg: "\<And>y. mono_sum_bot (\<lambda>f. C y f)"
  shows "mono_sum_bot (\<lambda>f. bind (B f) (\<lambda>y. C y f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b +\<^sub>\<bottom> 'c"
  assume fg: "fun_ord sum_bot_ord f g"
  with mf have "sum_bot_ord (B f) (B g)" by (rule monotoneD [of _ _ _ f g])
  then have "sum_bot_ord (bind (B f) (\<lambda>y. C y f)) (bind (B g) (\<lambda>y. C y f))"
    unfolding flat_ord_def by auto
  also from mg have "\<And>y'. sum_bot_ord (C y' f) (C y' g)"
    by (rule monotoneD) (rule fg)
  then have "sum_bot_ord (bind (B g) (\<lambda>y'. C y' f)) (bind (B g) (\<lambda>y'. C y' g))"
    unfolding flat_ord_def by (cases "B g") auto
  finally (sum_bot.leq_trans)
  show "sum_bot_ord (bind (B f) (\<lambda>y. C y f)) (bind (B g) (\<lambda>y'. C y' g))" .
qed

adhoc_overloading
  Monad_Syntax.bind bind

hide_const (open) bind

fun catch_error :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> ('e \<Rightarrow> ('f +\<^sub>\<bottom> 'a)) \<Rightarrow> 'f +\<^sub>\<bottom> 'a"
where
  "catch_error Bottom f = Bottom " |
  "catch_error (Left a) f = f a" |
  "catch_error (Right a) f = Right a"

adhoc_overloading
  Error_Syntax.catch catch_error

lemma catch_mono [partial_function_mono]:
  assumes mf: "mono_sum_bot B" and mg: "\<And>y. mono_sum_bot (\<lambda>f. C y f)"
  shows "mono_sum_bot (\<lambda>f. try (B f) catch (\<lambda>y. C y f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b +\<^sub>\<bottom> 'c"
  assume fg: "fun_ord sum_bot_ord f g"
  with mf have "sum_bot_ord (B f) (B g)" by (rule monotoneD [of _ _ _ f g])
  then have "sum_bot_ord (try (B f) catch (\<lambda>y. C y f)) (try (B g) catch (\<lambda>y. C y f))"
    unfolding flat_ord_def by auto
  also from mg
  have "\<And>y'. sum_bot_ord (C y' f) (C y' g)"
    by (rule monotoneD) (rule fg)
  then have "sum_bot_ord (try (B g) catch (\<lambda>y'. C y' f)) (try (B g) catch (\<lambda>y'. C y' g))"
    unfolding flat_ord_def by (cases "B g") auto
  finally (sum_bot.leq_trans)
    show "sum_bot_ord (try (B f) catch (\<lambda>y. C y f)) (try (B g) catch (\<lambda>y'. C y' g))" .
qed

definition error :: "'e \<Rightarrow> 'e +\<^sub>\<bottom> 'a"
where
  [simp]: "error x = Left x"

definition return :: "'a \<Rightarrow> 'e +\<^sub>\<bottom> 'a"
where
  [simp]: "return x = Right x"

fun map_sum_bot :: "('a \<Rightarrow> ('e +\<^sub>\<bottom> 'b)) \<Rightarrow> 'a list \<Rightarrow> 'e +\<^sub>\<bottom> 'b list"
where
  "map_sum_bot f [] = return []" |
  "map_sum_bot f (x#xs) = do {
    y \<leftarrow> f x;
    ys \<leftarrow> map_sum_bot f xs;
    return (y # ys)
  }"

lemma map_sum_bot_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "map_sum_bot f xs = map_sum_bot g ys"
  unfolding assms(1) using assms(2) by (induct ys) auto

lemmas sum_bot_const_mono =
  sum_bot.const_mono [of "fun_ord sum_bot_ord"]

lemma map_sum_bot_mono [partial_function_mono]:
  fixes C :: "'a \<Rightarrow> ('b \<Rightarrow> ('e +\<^sub>\<bottom> 'c)) \<Rightarrow> 'e +\<^sub>\<bottom> 'd"
  assumes "\<And>y. y \<in> set B \<Longrightarrow> mono_sum_bot (C y)"
  shows "mono_sum_bot (\<lambda>f. map_sum_bot (\<lambda>y. C y f) B)"
  using assms by (induct B) (auto intro!: partial_function_mono)

abbreviation update_error :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> ('e \<Rightarrow> 'f) \<Rightarrow> 'f +\<^sub>\<bottom> 'a"
where
  "update_error r f \<equiv> try r catch (\<lambda> e. error (f e))"

adhoc_overloading
  Error_Syntax.update_error update_error

fun sumbot :: "'e + 'a \<Rightarrow> 'e +\<^sub>\<bottom> 'a"
where
  "sumbot (Inl x) = Left x" |
  "sumbot (Inr x) = Right x"

code_datatype sumbot

lemma [code]:
  "(try (sumbot a) catch f) = (case a of Inl b \<Rightarrow> f b | Inr a \<Rightarrow> sumbot (Inr a))"
  by (cases a) auto

lemma [code]: "Right x = sumbot (Inr x)" by simp

lemma [code]: "Left x = sumbot (Inl x)" by simp

lemma [code]: "return x = sumbot (Inr x)" by simp

lemma [code]: "error x = sumbot (Inl x)" by simp

lemma [code]:
  "case_sum_bot f g h (sumbot p) = case_sum g h p"
  by (cases p) auto

subsection \<open>Connection to @{theory Partial_Function_MR.Partial_Function_MR}\<close>

lemma sum_bot_map_mono [partial_function_mono]:
  assumes mf: "mono_sum_bot B"
  shows "mono_sum_bot (\<lambda>f. sum_bot_map h (B f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b +\<^sub>\<bottom> 'c"
  assume fg: "fun_ord sum_bot_ord f g"
  with mf have "sum_bot_ord (B f) (B g)" by (rule monotoneD [of _ _ _ f g])
  then show "sum_bot_ord (sum_bot_map h (B f)) (sum_bot_map h (B g))"
    unfolding flat_ord_def by auto
qed

declaration \<open>
Partial_Function_MR.init
  "sum_bot"
  (fn (mt, t_to_ss, mtT, msT, t_to_sTs) =>
      list_comb (Const (@{const_name sum_bot_map}, t_to_sTs ---> mtT --> msT), t_to_ss) $ mt)
  (fn (commonTs, argTs) => Type (@{type_name sum_bot}, commonTs @ argTs))
  (fn mT => Term.dest_Type mT |> #2 |> (fn [err, res] => ([err], [res])))
  @{thms sum_bot.map_comp}
  @{thms sum_bot.map_ident}
\<close>

end