section\<open>Collapsing the levels\<close>
theory Level_Collapse
imports Conc_Impl
begin
text\<open>
The theory up to this point is implemented in a way that separated the different aspects into different levels.
This is highly beneficial for us, since it allows us to tackle the difficulties arising in small chunks.
However, exporting this to the user would be highly impractical.
Thus, this theory collapses all the different levels (i.e. refinement steps) and relates the computations in the heap monad to
@{type boolfunc}.
\<close>

definition "bddmi_rel cs \<equiv> {(a,c)|a b c. (a,b) \<in> bf_ifex_rel \<and> (c,b) \<in> Rmi cs}"
definition bdd_relator :: "(nat boolfunc \<times> nat) set \<Rightarrow> bddi \<Rightarrow> assn" where
"bdd_relator p s \<equiv> \<exists>\<^sub>Acs. is_bdd_impl cs s * \<up>(p \<subseteq> (bddmi_rel cs) \<and> bdd_sane cs) * true"

text\<open>
The @{type assn} predicate @{term bdd_relator} is the interface that is exposed to the user.
(The contents of the definition are not exposed.)
\<close>

lemma bdd_relator_mono[intro!]: "q \<subseteq> p \<Longrightarrow> bdd_relator p s \<Longrightarrow>\<^sub>A bdd_relator q s" unfolding bdd_relator_def by sep_auto

lemma bdd_relator_absorb_true[simp]: "bdd_relator p s * true = bdd_relator p s" unfolding bdd_relator_def by simp

thm bdd_relator_def[unfolded bddmi_rel_def, simplified]
lemma join_hlp1: "is_bdd_impl a s * is_bdd_impl b s \<Longrightarrow>\<^sub>A is_bdd_impl a s * is_bdd_impl b s * \<up>(a = b)"
  apply clarsimp
  apply(rule preciseD[where p=s and R="is_bdd_impl" and F="is_bdd_impl b s" and F'="is_bdd_impl a s"])
   apply(rule is_bdd_impl_prec)
  apply(unfold mod_and_dist)
  apply(rule conjI)
   apply assumption
  apply(simp add: star_aci(2))
done

lemma join_hlp: "is_bdd_impl a s * is_bdd_impl b s = is_bdd_impl b s * is_bdd_impl a s * \<up>(a = b)"
  apply(rule ent_iffI[rotated])
   apply(simp; fail)
  apply(rule ent_trans)
   apply(rule join_hlp1)
  apply(simp; fail)
  done

lemma add_true_asm:
  assumes "<b * true> p <a>\<^sub>t"
  shows "<b> p <a>\<^sub>t"
  apply(rule cons_pre_rule)
   prefer 2
   apply(rule assms)
  apply(simp add: ent_true_drop)
  done

lemma add_anything:
  assumes "<b> p <a>"
  shows "<b * x> p <\<lambda>r. a r * x>\<^sub>t"
proof -
  note [sep_heap_rules] = assms
  show ?thesis by sep_auto
qed

lemma add_true:
  assumes "<b> p <a>\<^sub>t"
  shows "<b * true> p <a>\<^sub>t"
  using assms add_anything[where x=true] by force

definition node_relator where "node_relator x y \<longleftrightarrow> x \<in> y"
text \<open>\<open>sep_auto\<close> behaves sub-optimal when having @{term "(bf,bdd) \<in> computed_pointer_relation"} as assumption in our cases. Using @{const node_relator} instead fixes this behavior with a custom solver for \<open>simp\<close>.\<close>

lemma node_relatorI: "x \<in> y \<Longrightarrow> node_relator x y" unfolding node_relator_def .
lemma node_relatorD: "node_relator x y \<Longrightarrow> x \<in> y" unfolding node_relator_def .

ML\<open>fun TRY' tac = tac ORELSE' K all_tac\<close>

setup \<open>map_theory_simpset (fn ctxt =>
  ctxt addSolver (Simplifier.mk_solver "node_relator"
    (fn ctxt => fn n =>
      let
        val tac =
          resolve_tac ctxt @{thms node_relatorI} THEN'
          REPEAT_ALL_NEW (resolve_tac ctxt @{thms Set.insertI1 Set.insertI2}) THEN'
          TRY' (dresolve_tac ctxt @{thms node_relatorD} THEN' assume_tac ctxt)
      in
        SOLVED' tac n
      end))
)\<close>

text\<open>
This is the general form one wants to work with:
if a function on the bdd is called with a set of already existing and valid pointers, the arguments to the function have to be in that set.
The result is that one more pointer is the set of existing and valid pointers.
\<close>

thm iteci_rule[THEN mp] mi.ite_impl_R ifex_ite_rel_bf

lemma iteci_rule[sep_heap_rules]: "
\<lbrakk>node_relator (ib, ic)  rp; node_relator (tb, tc) rp; node_relator (eb, ec) rp\<rbrakk> \<Longrightarrow>
<bdd_relator rp s>
  iteci_lu ic tc ec s
<\<lambda>(r,s'). bdd_relator (insert (bf_ite ib tb eb,r) rp) s'>"
  apply(unfold bdd_relator_def node_relator_def)
  apply(intro norm_pre_ex_rule)
  apply(clarsimp)
  apply(unfold bddmi_rel_def)
  apply(drule (1) rev_subsetD)+
  apply(clarsimp)
  apply(drule (3) mi.ite_impl_lu_R[where ii=ic and ti=tc and ei=ec, unfolded in_rel_def])
  apply(drule ospecD2)
  apply(clarsimp simp del: ifex_ite.simps)
  apply(rule cons_post_rule)
   apply(rule cons_pre_rule[rotated])
    apply(rule iteci_lu_rule[THEN mp, THEN add_true])
    apply(assumption)
   apply(sep_auto; fail)
  apply(clarsimp simp del: ifex_ite.simps)
  apply(rule ent_ex_postI)
  apply(subst ent_pure_post_iff)
  apply(rule conjI[rotated])
   apply(sep_auto; fail)
  apply(clarsimp simp del: ifex_ite.simps)
  apply(rule conjI[rotated])
   apply(force simp add: mi.les_def)
  apply(rule exI)
  apply(rule conjI)
   apply(erule (2) ifex_ite_opt_rel_bf[unfolded in_rel_def])
  apply assumption
done

lemma tci_rule[sep_heap_rules]:
"<bdd_relator rp s>
  tci s
<\<lambda>(r,s'). bdd_relator (insert (bf_True,r) rp) s'>"
  apply(unfold bdd_relator_def)
  apply(intro norm_pre_ex_rule)
  apply(clarsimp)
  apply(frule mi.Timpl_rule)
  apply(drule ospecD2)
  apply(clarify)
  apply(sep_auto)
   apply(unfold bddmi_rel_def)
   apply(clarsimp)
  apply(force simp add: mi.les_def)
done

lemma fci_rule[sep_heap_rules]:
"<bdd_relator rp s>
  fci s
<\<lambda>(r,s'). bdd_relator (insert (bf_False,r) rp) s'>"
  apply(unfold bdd_relator_def)
  apply(intro norm_pre_ex_rule)
  apply(clarsimp)
  apply(frule mi.Fimpl_rule)
  apply(drule ospecD2)
  apply(clarify)
  apply(sep_auto)
   apply(unfold bddmi_rel_def)
   apply(clarsimp)
  apply(force simp add: mi.les_def)
done

text\<open>IFC/ifmi/ifci require that the variable order is ensured by the user.
Instead of using ifci, a combination of litci and iteci has to be used.\<close>
lemma [sep_heap_rules]:
"\<lbrakk>(tb, tc) \<in> rp; (eb, ec) \<in> rp\<rbrakk> \<Longrightarrow>
<bdd_relator rp s>
  ifci v tc ec s
<\<lambda>(r,s'). bdd_relator (insert (bf_if v tb eb,r) rp) s'>"
text\<open>This probably doesn't hold.\<close>
oops

lemma notci_rule[sep_heap_rules]:
  assumes "node_relator (tb, tc) rp"
  shows "<bdd_relator rp s> notci tc s <\<lambda>(r,s'). bdd_relator (insert (bf_not tb,r) rp) s'>"
using assms
by(sep_auto simp: notci_def)

lemma cirules1[sep_heap_rules]:
  assumes "node_relator (tb, tc) rp" "node_relator (eb, ec) rp"
  shows
    "<bdd_relator rp s> andci tc ec s <\<lambda>(r,s'). bdd_relator (insert (bf_and tb eb,r) rp) s'>"
    "<bdd_relator rp s> orci tc ec s <\<lambda>(r,s'). bdd_relator (insert (bf_or tb eb,r) rp) s'>"
    "<bdd_relator rp s> biimpci tc ec s <\<lambda>(r,s'). bdd_relator (insert (bf_biimp tb eb,r) rp) s'>"
    "<bdd_relator rp s> xorci tc ec s <\<lambda>(r,s'). bdd_relator (insert (bf_xor tb eb,r) rp) s'>"
(* actually, these functions would allow for more insert. I think that would be inconvenient though. *)
using assms
by (sep_auto simp: andci_def orci_def biimpci_def xorci_def)+

lemma cirules2[sep_heap_rules]:
  assumes "node_relator (tb, tc) rp" "node_relator (eb, ec) rp"
  shows
    "<bdd_relator rp s> nandci tc ec s <\<lambda>(r,s'). bdd_relator (insert (bf_nand tb eb,r) rp) s'>"
    "<bdd_relator rp s> norci tc ec s <\<lambda>(r,s'). bdd_relator (insert (bf_nor tb eb,r) rp) s'>"
  using assms
  by(sep_auto simp: nandci_def norci_def)+

lemma litci_rule[sep_heap_rules]:
  "<bdd_relator rp s> litci v s <\<lambda>(r,s'). bdd_relator (insert (bf_lit v,r) rp) s'>"
  apply(unfold litci_def)
  apply(subgoal_tac \<open>\<And>t ab bb. \<comment> \<open>introducing some vars \dots\<close>
         <bdd_relator (insert (bf_False, ab) (insert (bf_True, t) rp)) bb * true>
           ifci v t ab bb
         <\<lambda>r. case r of (r, x) \<Rightarrow> bdd_relator (insert (bf_lit v, r) rp) x>\<close>)
   apply(sep_auto; fail)
  apply(rename_tac tc fc sc)
  apply(unfold bdd_relator_def[abs_def])
  apply(clarsimp)
  apply(intro norm_pre_ex_rule)
  apply(clarsimp)
  apply(unfold bddmi_rel_def)
  apply(clarsimp simp only: bf_ifex_rel_consts_ensured)
  apply(frule mi.IFimpl_rule)
    apply(rename_tac tc fc sc sm a aa b ba fm tm)
    apply(thin_tac "(fm, Falseif) \<in> Rmi sm")
    apply(assumption) (* hack: instantiate the first premise of mi.IFimpl_rule with the second assumption that matches. The other way around would be fine, too. *)
   apply(assumption)
  apply(clarsimp)
  apply(drule ospecD2)
  apply(clarify)
  apply(sep_auto)
  apply(force simp add: mi.les_def)
done

lemma tautci_rule[sep_heap_rules]:
  shows "node_relator (tb, tc) rp \<Longrightarrow> <bdd_relator rp s> tautci tc s <\<lambda>r. bdd_relator rp s * \<up>(r \<longleftrightarrow> tb = bf_True)>"
  apply(unfold node_relator_def)
  apply(unfold tautci_def)
  apply(unfold bdd_relator_def)
  apply(intro norm_pre_ex_rule; clarsimp)
  apply(unfold bddmi_rel_def)
  apply(drule (1) rev_subsetD)
  apply(clarsimp)
  apply(rename_tac sm ti)
  apply(frule (1) mi.DESTRimpl_rule; drule ospecD2; clarify)
  apply(sep_auto split: ifex.splits)
done

lemma emptyci_rule[sep_heap_rules]:
  shows "<emp> emptyci <\<lambda>r. bdd_relator {} r>"
by(sep_auto simp: bdd_relator_def)

(* TODO: make sure that emptyci_rule and firends don't appear duplicate, once concrete-impl style, once level-collapsed. *)

lemmas [simp] = bf_ite_def

text\<open>Efficient comparison of two nodes.\<close>

definition "eqci a b \<equiv> return (a = b)" (* wrapping definition so sep_auto does not run into nowhere *)

lemma iteeq_rule[sep_heap_rules]: "
\<lbrakk>node_relator (xb, xc)  rp; node_relator (yb, yc) rp\<rbrakk> \<Longrightarrow>
<bdd_relator rp s>
  eqci xc yc
<\<lambda>r. \<up>(r \<longleftrightarrow> xb = yb)>\<^sub>t"
  apply(unfold bdd_relator_def node_relator_def eqci_def)
  apply(intro norm_pre_ex_rule)
  apply(clarsimp)
  apply(unfold bddmi_rel_def)
  apply(drule (1) rev_subsetD)+
  apply(rule return_cons_rule)
  apply(clarsimp)
  apply(rule iffI)
   using bf_ifex_eq mi.cmp_rule_eq apply(blast)
  using bf_ifex_eq mi.cmp_rule_eq apply(blast)
done

end


(*  Title:      Labeled_Strands.thy
    Author:     Andreas Viktor Hess, DTU
    Author:     Sebastian A. Mödersheim, DTU
    Author:     Achim D. Brucker, The University of Sheffield
    SPDX-License-Identifier: BSD-3-Clause
*)

section \<open>Labeled Strands\<close>
theory Labeled_Strands
imports Strands_and_Constraints
begin

subsection \<open>Definitions: Labeled Strands and Constraints\<close>
datatype 'l strand_label =
  LabelN (the_LabelN: "'l") ("ln _")
| LabelS ("\<star>")

text \<open>Labeled strands are strands whose steps are equipped with labels\<close>
type_synonym ('a,'b,'c) labeled_strand_step = "'c strand_label \<times> ('a,'b) strand_step"
type_synonym ('a,'b,'c) labeled_strand = "('a,'b,'c) labeled_strand_step list"

abbreviation has_LabelN where "has_LabelN n x \<equiv> fst x = ln n"
abbreviation has_LabelS where "has_LabelS x \<equiv> fst x = \<star>"

definition unlabel where "unlabel S \<equiv> map snd S"
definition proj where "proj n S \<equiv> filter (\<lambda>s. has_LabelN n s \<or> has_LabelS s) S"
abbreviation proj_unl where "proj_unl n S \<equiv> unlabel (proj n S)"

abbreviation wfrestrictedvars\<^sub>l\<^sub>s\<^sub>t where "wfrestrictedvars\<^sub>l\<^sub>s\<^sub>t S \<equiv> wfrestrictedvars\<^sub>s\<^sub>t (unlabel S)"

abbreviation subst_apply_labeled_strand_step (infix "\<cdot>\<^sub>l\<^sub>s\<^sub>t\<^sub>p" 51) where
  "x \<cdot>\<^sub>l\<^sub>s\<^sub>t\<^sub>p \<theta> \<equiv> (case x of (l, s) \<Rightarrow> (l, s \<cdot>\<^sub>s\<^sub>t\<^sub>p \<theta>))"

abbreviation subst_apply_labeled_strand (infix "\<cdot>\<^sub>l\<^sub>s\<^sub>t" 51) where
  "S \<cdot>\<^sub>l\<^sub>s\<^sub>t \<theta> \<equiv> map (\<lambda>x. x \<cdot>\<^sub>l\<^sub>s\<^sub>t\<^sub>p \<theta>) S"

abbreviation trms\<^sub>l\<^sub>s\<^sub>t where "trms\<^sub>l\<^sub>s\<^sub>t S \<equiv> trms\<^sub>s\<^sub>t (unlabel S)"
abbreviation trms_proj\<^sub>l\<^sub>s\<^sub>t where "trms_proj\<^sub>l\<^sub>s\<^sub>t n S \<equiv> trms\<^sub>s\<^sub>t (proj_unl n S)"

abbreviation vars\<^sub>l\<^sub>s\<^sub>t where "vars\<^sub>l\<^sub>s\<^sub>t S \<equiv> vars\<^sub>s\<^sub>t (unlabel S)"
abbreviation vars_proj\<^sub>l\<^sub>s\<^sub>t where "vars_proj\<^sub>l\<^sub>s\<^sub>t n S \<equiv> vars\<^sub>s\<^sub>t (proj_unl n S)"

abbreviation bvars\<^sub>l\<^sub>s\<^sub>t where "bvars\<^sub>l\<^sub>s\<^sub>t S \<equiv> bvars\<^sub>s\<^sub>t (unlabel S)"
abbreviation fv\<^sub>l\<^sub>s\<^sub>t where "fv\<^sub>l\<^sub>s\<^sub>t S \<equiv> fv\<^sub>s\<^sub>t (unlabel S)"

abbreviation wf\<^sub>l\<^sub>s\<^sub>t where "wf\<^sub>l\<^sub>s\<^sub>t V S \<equiv> wf\<^sub>s\<^sub>t V (unlabel S)"

subsection \<open>Lemmata: Projections\<close>
lemma has_LabelS_proj_iff_not_has_LabelN:
  "list_all has_LabelS (proj l A) \<longleftrightarrow> \<not>list_ex (has_LabelN l) A"
by (induct A) (auto simp add: proj_def)

lemma proj_subset_if_no_label:
  assumes "\<not>list_ex (has_LabelN l) A"
  shows "set (proj l A) \<subseteq> set (proj l' A)"
    and "set (proj_unl l A) \<subseteq> set (proj_unl l' A)"
using assms by (induct A) (auto simp add: unlabel_def proj_def)

lemma proj_in_setD:
  assumes a: "a \<in> set (proj l A)"
  obtains k b where "a = (k, b)" "k = (ln l) \<or> k = \<star>"
using that a unfolding proj_def by (cases a) auto

lemma proj_set_mono:
  assumes "set A \<subseteq> set B"
  shows "set (proj n A) \<subseteq> set (proj n B)"
    and "set (proj_unl n A) \<subseteq> set (proj_unl n B)"
using assms unfolding proj_def unlabel_def by auto

lemma unlabel_nil[simp]: "unlabel [] = []"
by (simp add: unlabel_def)

lemma unlabel_mono: "set A \<subseteq> set B \<Longrightarrow> set (unlabel A) \<subseteq> set (unlabel B)"
by (auto simp add: unlabel_def)

lemma unlabel_in: "(l,x) \<in> set A \<Longrightarrow> x \<in> set (unlabel A)"
unfolding unlabel_def by force

lemma unlabel_mem_has_label: "x \<in> set (unlabel A) \<Longrightarrow> \<exists>l. (l,x) \<in> set A"
unfolding unlabel_def by auto

lemma proj_ident:
  assumes "list_all (\<lambda>s. has_LabelN l s \<or> has_LabelS s) S"
  shows "proj l S = S"
using assms unfolding proj_def list_all_iff by fastforce

lemma proj_elims_label:
  assumes "k \<noteq> l"
  shows "\<not>list_ex (has_LabelN l) (proj k S)"
using assms unfolding proj_def list_ex_iff by force

lemma proj_nil[simp]: "proj n [] = []" "proj_unl n [] = []"
unfolding unlabel_def proj_def by auto

lemma singleton_lst_proj[simp]:
  "proj_unl l [(ln l, a)] = [a]"
  "l \<noteq> l' \<Longrightarrow> proj_unl l' [(ln l, a)] = []"
  "proj_unl l [(\<star>, a)] = [a]"
  "unlabel [(l'', a)] = [a]"
unfolding proj_def unlabel_def by simp_all

lemma unlabel_nil_only_if_nil[simp]: "unlabel A = [] \<Longrightarrow> A = []"
unfolding unlabel_def by auto

lemma unlabel_Cons[simp]:
  "unlabel ((l,a)#A) = a#unlabel A"
  "unlabel (b#A) = snd b#unlabel A"
unfolding unlabel_def by simp_all

lemma unlabel_append[simp]: "unlabel (A@B) = unlabel A@unlabel B"
unfolding unlabel_def by auto

lemma proj_Cons[simp]:
  "proj n ((ln n,a)#A) = (ln n,a)#proj n A"
  "proj n ((\<star>,a)#A) = (\<star>,a)#proj n A"
  "m \<noteq> n \<Longrightarrow> proj n ((ln m,a)#A) = proj n A"
  "l = (ln n) \<Longrightarrow> proj n ((l,a)#A) = (l,a)#proj n A"
  "l = \<star> \<Longrightarrow> proj n ((l,a)#A) = (l,a)#proj n A"
  "fst b \<noteq> \<star> \<Longrightarrow> fst b \<noteq> (ln n) \<Longrightarrow> proj n (b#A) = proj n A"
unfolding proj_def by auto

lemma proj_append[simp]:
  "proj l (A'@B') = proj l A'@proj l B'"
  "proj_unl l (A@B) = proj_unl l A@proj_unl l B"
unfolding proj_def unlabel_def by auto

lemma proj_unl_cons[simp]:
  "proj_unl l ((ln l, a)#A) = a#proj_unl l A"
  "l \<noteq> l' \<Longrightarrow> proj_unl l' ((ln l, a)#A) = proj_unl l' A"
  "proj_unl l ((\<star>, a)#A) = a#proj_unl l A"
unfolding proj_def unlabel_def by simp_all

lemma trms_unlabel_proj[simp]:
  "trms\<^sub>s\<^sub>t\<^sub>p (snd (ln l, x)) \<subseteq> trms_proj\<^sub>l\<^sub>s\<^sub>t l [(ln l, x)]"
by auto

lemma trms_unlabel_star[simp]:
  "trms\<^sub>s\<^sub>t\<^sub>p (snd (\<star>, x)) \<subseteq> trms_proj\<^sub>l\<^sub>s\<^sub>t l [(\<star>, x)]"
by auto

lemma trms\<^sub>l\<^sub>s\<^sub>t_union[simp]: "trms\<^sub>l\<^sub>s\<^sub>t A = (\<Union>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l A)"
proof (induction A)
  case (Cons a A)
  obtain l s where ls: "a = (l,s)" by moura
  have "trms\<^sub>l\<^sub>s\<^sub>t [a] = (\<Union>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l [a])"
  proof -
    have *: "trms\<^sub>l\<^sub>s\<^sub>t [a] = trms\<^sub>s\<^sub>t\<^sub>p s" using ls by simp
    show ?thesis
    proof (cases l)
      case (LabelN n)
      hence "trms_proj\<^sub>l\<^sub>s\<^sub>t n [a] = trms\<^sub>s\<^sub>t\<^sub>p s" using ls by simp
      moreover have "\<forall>m. n \<noteq> m \<longrightarrow> trms_proj\<^sub>l\<^sub>s\<^sub>t m [a] = {}" using ls LabelN by auto
      ultimately show ?thesis using * ls by fastforce
    next
      case LabelS
      hence "\<forall>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l [a] = trms\<^sub>s\<^sub>t\<^sub>p s" using ls by auto
      thus ?thesis using * ls by fastforce
    qed
  qed
  moreover have "\<forall>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l (a#A) = trms_proj\<^sub>l\<^sub>s\<^sub>t l [a] \<union> trms_proj\<^sub>l\<^sub>s\<^sub>t l A"
    unfolding unlabel_def proj_def by auto
  hence "(\<Union>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l (a#A)) = (\<Union>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l [a]) \<union> (\<Union>l. trms_proj\<^sub>l\<^sub>s\<^sub>t l A)" by auto
  ultimately show ?case using Cons.IH ls by auto
qed simp

lemma trms\<^sub>l\<^sub>s\<^sub>t_append[simp]: "trms\<^sub>l\<^sub>s\<^sub>t (A@B) = trms\<^sub>l\<^sub>s\<^sub>t A \<union> trms\<^sub>l\<^sub>s\<^sub>t B"
by (metis trms\<^sub>s\<^sub>t_append unlabel_append)

lemma trms_proj\<^sub>l\<^sub>s\<^sub>t_append[simp]: "trms_proj\<^sub>l\<^sub>s\<^sub>t l (A@B) = trms_proj\<^sub>l\<^sub>s\<^sub>t l A \<union> trms_proj\<^sub>l\<^sub>s\<^sub>t l B"
by (metis (no_types, lifting) filter_append proj_def trms\<^sub>l\<^sub>s\<^sub>t_append)

lemma trms_proj\<^sub>l\<^sub>s\<^sub>t_subset[simp]:
  "trms_proj\<^sub>l\<^sub>s\<^sub>t l A \<subseteq> trms_proj\<^sub>l\<^sub>s\<^sub>t l (A@B)"
  "trms_proj\<^sub>l\<^sub>s\<^sub>t l B \<subseteq> trms_proj\<^sub>l\<^sub>s\<^sub>t l (A@B)"
using trms_proj\<^sub>l\<^sub>s\<^sub>t_append[of l] by blast+

lemma trms\<^sub>l\<^sub>s\<^sub>t_subset[simp]:
  "trms\<^sub>l\<^sub>s\<^sub>t A \<subseteq> trms\<^sub>l\<^sub>s\<^sub>t (A@B)"
  "trms\<^sub>l\<^sub>s\<^sub>t B \<subseteq> trms\<^sub>l\<^sub>s\<^sub>t (A@B)"
proof (induction A)
  case (Cons a A)
  obtain l s where *: "a = (l,s)" by moura
  { case 1 thus ?case using Cons * by auto }
  { case 2 thus ?case using Cons * by auto }
qed simp_all

lemma vars\<^sub>l\<^sub>s\<^sub>t_union: "vars\<^sub>l\<^sub>s\<^sub>t A = (\<Union>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l A)"
proof (induction A)
  case (Cons a A)
  obtain l s where ls: "a = (l,s)" by moura
  have "vars\<^sub>l\<^sub>s\<^sub>t [a] = (\<Union>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l [a])"
  proof -
    have *: "vars\<^sub>l\<^sub>s\<^sub>t [a] = vars\<^sub>s\<^sub>t\<^sub>p s" using ls by auto
    show ?thesis
    proof (cases l)
      case (LabelN n)
      hence "vars_proj\<^sub>l\<^sub>s\<^sub>t n [a] = vars\<^sub>s\<^sub>t\<^sub>p s" using ls by simp
      moreover have "\<forall>m. n \<noteq> m \<longrightarrow> vars_proj\<^sub>l\<^sub>s\<^sub>t m [a] = {}" using ls LabelN by auto
      ultimately show ?thesis using * ls by fast
    next
      case LabelS
      hence "\<forall>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l [a] = vars\<^sub>s\<^sub>t\<^sub>p s" using ls by auto
      thus ?thesis using * ls by fast
    qed
  qed
  moreover have "\<forall>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l (a#A) = vars_proj\<^sub>l\<^sub>s\<^sub>t l [a] \<union> vars_proj\<^sub>l\<^sub>s\<^sub>t l A"
    unfolding unlabel_def proj_def by auto
  hence "(\<Union>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l (a#A)) = (\<Union>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l [a]) \<union> (\<Union>l. vars_proj\<^sub>l\<^sub>s\<^sub>t l A)"
    using strand_vars_split(1) by auto
  ultimately show ?case using Cons.IH ls strand_vars_split(1) by auto
qed simp

lemma unlabel_Cons_inv:
  "unlabel A = b#B \<Longrightarrow> \<exists>A'. (\<exists>n. A = (ln n, b)#A') \<or> A = (\<star>, b)#A'"
proof -
  assume *: "unlabel A = b#B"
  then obtain l A' where "A = (l,b)#A'" unfolding unlabel_def by moura
  thus "\<exists>A'. (\<exists>l. A = (ln l, b)#A') \<or> A = (\<star>, b)#A'" by (metis strand_label.exhaust)
qed

lemma unlabel_snoc_inv:
  "unlabel A = B@[b] \<Longrightarrow> \<exists>A'. (\<exists>n. A = A'@[(ln n, b)]) \<or> A = A'@[(\<star>, b)]"
proof -
  assume *: "unlabel A = B@[b]"
  then obtain A' l where "A = A'@[(l,b)]"
    unfolding unlabel_def by (induct A rule: List.rev_induct) auto
  thus "\<exists>A'. (\<exists>n. A = A'@[(ln n, b)]) \<or> A = A'@[(\<star>, b)]" by (cases l) auto
qed

lemma proj_idem[simp]: "proj l (proj l A) = proj l A"
unfolding proj_def by auto

lemma proj_ik\<^sub>s\<^sub>t_is_proj_rcv_set:
  "ik\<^sub>s\<^sub>t (proj_unl n A) =
    {t. \<exists>ts. ((ln n, Receive ts) \<in> set A \<or> (\<star>, Receive ts) \<in> set A) \<and> t \<in> set ts} "
using ik\<^sub>s\<^sub>t_is_rcv_set unfolding unlabel_def proj_def by force

lemma unlabel_ik\<^sub>s\<^sub>t_is_rcv_set:
  "ik\<^sub>s\<^sub>t (unlabel A) = {t | l t ts. (l, Receive ts) \<in> set A \<and> t \<in> set ts}"
using ik\<^sub>s\<^sub>t_is_rcv_set unfolding unlabel_def by force

lemma proj_ik_union_is_unlabel_ik:
  "ik\<^sub>s\<^sub>t (unlabel A) = (\<Union>l. ik\<^sub>s\<^sub>t (proj_unl l A))"
proof
  show "(\<Union>l. ik\<^sub>s\<^sub>t (proj_unl l A)) \<subseteq> ik\<^sub>s\<^sub>t (unlabel A)"
    using unlabel_ik\<^sub>s\<^sub>t_is_rcv_set[of A] proj_ik\<^sub>s\<^sub>t_is_proj_rcv_set[of _ A] by auto

  show "ik\<^sub>s\<^sub>t (unlabel A) \<subseteq> (\<Union>l. ik\<^sub>s\<^sub>t (proj_unl l A))"
  proof
    fix t assume "t \<in> ik\<^sub>s\<^sub>t (unlabel A)"
    then obtain l ts where "(l, Receive ts) \<in> set A" "t \<in> set ts"
      using ik\<^sub>s\<^sub>t_is_rcv_set unlabel_mem_has_label[of _ A]
      by moura
    thus "t \<in> (\<Union>l. ik\<^sub>s\<^sub>t (proj_unl l A))" using proj_ik\<^sub>s\<^sub>t_is_proj_rcv_set[of _ A] by (cases l) auto
  qed
qed

lemma proj_ik_append[simp]:
  "ik\<^sub>s\<^sub>t (proj_unl l (A@B)) = ik\<^sub>s\<^sub>t (proj_unl l A) \<union> ik\<^sub>s\<^sub>t (proj_unl l B)"
using proj_append(2)[of l A B] ik_append by auto

lemma proj_ik_append_subst_all:
  "ik\<^sub>s\<^sub>t (proj_unl l (A@B)) \<cdot>\<^sub>s\<^sub>e\<^sub>t I = (ik\<^sub>s\<^sub>t (proj_unl l A) \<cdot>\<^sub>s\<^sub>e\<^sub>t I) \<union> (ik\<^sub>s\<^sub>t (proj_unl l B) \<cdot>\<^sub>s\<^sub>e\<^sub>t I)"
using proj_ik_append[of l] by auto

lemma ik_proj_subset[simp]: "ik\<^sub>s\<^sub>t (proj_unl n A) \<subseteq> trms_proj\<^sub>l\<^sub>s\<^sub>t n A"
by auto

lemma prefix_unlabel:
  "prefix A B \<Longrightarrow> prefix (unlabel A) (unlabel B)"
unfolding prefix_def unlabel_def by auto

lemma prefix_proj:
  "prefix A B \<Longrightarrow> prefix (proj n A) (proj n B)"
  "prefix A B \<Longrightarrow> prefix (proj_unl n A) (proj_unl n B)"
unfolding prefix_def proj_def by auto

lemma suffix_unlabel:
  "suffix A B \<Longrightarrow> suffix (unlabel A) (unlabel B)"
unfolding suffix_def unlabel_def by auto

lemma suffix_proj:
  "suffix A B \<Longrightarrow> suffix (proj n A) (proj n B)"
  "suffix A B \<Longrightarrow> suffix (proj_unl n A) (proj_unl n B)"
unfolding suffix_def proj_def by auto

subsection \<open>Lemmata: Well-formedness\<close>
lemma wfvarsoccs\<^sub>s\<^sub>t_proj_union:
  "wfvarsoccs\<^sub>s\<^sub>t (unlabel A) = (\<Union>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A))"
proof (induction A)
  case (Cons a A)
  obtain l s where ls: "a = (l,s)" by moura
  have "wfvarsoccs\<^sub>s\<^sub>t (unlabel [a]) = (\<Union>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a]))"
  proof -
    have *: "wfvarsoccs\<^sub>s\<^sub>t (unlabel [a]) = wfvarsoccs\<^sub>s\<^sub>t\<^sub>p s" using ls by auto
    show ?thesis
    proof (cases l)
      case (LabelN n)
      hence "wfvarsoccs\<^sub>s\<^sub>t (proj_unl n [a]) = wfvarsoccs\<^sub>s\<^sub>t\<^sub>p s" using ls by simp
      moreover have "\<forall>m. n \<noteq> m \<longrightarrow> wfvarsoccs\<^sub>s\<^sub>t (proj_unl m [a]) = {}" using ls LabelN by auto
      ultimately show ?thesis using * ls by fast
    next
      case LabelS
      hence "\<forall>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a]) = wfvarsoccs\<^sub>s\<^sub>t\<^sub>p s" using ls by auto
      thus ?thesis using * ls by fast
    qed
  qed
  moreover have
      "wfvarsoccs\<^sub>s\<^sub>t (proj_unl l (a#A)) =
       wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a]) \<union> wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A)"
    for l
    unfolding unlabel_def proj_def by auto
  hence "(\<Union>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l (a#A))) =
         (\<Union>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l [a])) \<union> (\<Union>l. wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A))"
    using strand_vars_split(1) by auto
  ultimately show ?case using Cons.IH ls strand_vars_split(1) by auto
qed simp

lemma wf_if_wf_proj:
  assumes "\<forall>l. wf\<^sub>s\<^sub>t V (proj_unl l A)"
  shows "wf\<^sub>s\<^sub>t V (unlabel A)"
using assms
proof (induction A arbitrary: V rule: List.rev_induct)
  case (snoc a A)
  hence IH: "wf\<^sub>s\<^sub>t V (unlabel A)" using proj_append(2)[of _ A] by auto
  obtain b l where b: "a = (ln l, b) \<or> a = (\<star>, b)" by (cases a, metis strand_label.exhaust)
  hence *: "wf\<^sub>s\<^sub>t V (proj_unl l A@[b])"
    by (metis snoc.prems proj_append(2) singleton_lst_proj(1) proj_unl_cons(1,3))
  thus ?case using IH b snoc.prems proj_append(2)[of l A "[a]"] unlabel_append[of A "[a]"]
  proof (cases b)
    case (Receive ts)
    have "fv\<^sub>s\<^sub>e\<^sub>t (set ts) \<subseteq> wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \<union> V"
    proof
      fix x assume "x \<in> fv\<^sub>s\<^sub>e\<^sub>t (set ts)"
      hence "x \<in> V \<union> wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A)" using wf_append_exec[OF *] b Receive by auto
      thus "x \<in> wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \<union> V" using wfvarsoccs\<^sub>s\<^sub>t_proj_union[of A] by auto
    qed
    hence "fv\<^sub>s\<^sub>e\<^sub>t (set ts) \<subseteq> wfrestrictedvars\<^sub>s\<^sub>t (unlabel A) \<union> V"
      using vars_snd_rcv_strand_subset2(4)[of "unlabel A"] by blast
    hence "wf\<^sub>s\<^sub>t V (unlabel A@[Receive ts])" by (rule wf_rcv_append'''[OF IH])
    thus ?thesis using b Receive unlabel_append[of A "[a]"] by auto
  next
    case (Equality ac s t)
    have "fv t \<subseteq> wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \<union> V" when "ac = Assign"
    proof
      fix x assume "x \<in> fv t"
      hence "x \<in> V \<union> wfvarsoccs\<^sub>s\<^sub>t (proj_unl l A)" using wf_append_exec[OF *] b Equality that by auto
      thus "x \<in> wfvarsoccs\<^sub>s\<^sub>t (unlabel A) \<union> V" using wfvarsoccs\<^sub>s\<^sub>t_proj_union[of A] by auto
    qed
    hence "fv t \<subseteq> wfrestrictedvars\<^sub>l\<^sub>s\<^sub>t A \<union> V" when "ac = Assign"
      using vars_snd_rcv_strand_subset2(4)[of "unlabel A"] that by blast
    hence "wf\<^sub>s\<^sub>t V (unlabel A@[Equality ac s t])"
      by (cases ac) (metis wf_eq_append'''[OF IH], metis wf_eq_check_append''[OF IH])
    thus ?thesis using b Equality unlabel_append[of A "[a]"] by auto
  qed auto
qed simp

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      StateSpace.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section {* State Space Template *}
theory StateSpace imports Main
begin

record 'g state = "globals"::'g

definition
  upd_globals:: "('g \<Rightarrow> 'g) \<Rightarrow> ('g,'z) state_scheme \<Rightarrow> ('g,'z) state_scheme"
where
  "upd_globals upd s = s\<lparr>globals := upd (globals s)\<rparr>"

record ('g, 'n, 'val) stateSP = "'g state" +
  locals :: "'n \<Rightarrow> 'val"

lemma upd_globals_conv: "upd_globals f = (\<lambda>s. s\<lparr>globals := f (globals s)\<rparr>)"
  by (rule ext) (simp add: upd_globals_def)

end


section \<open>CFG\<close>

theory WCFG imports Com "../Basic/BasicDefs" begin

subsection\<open>CFG nodes\<close>

datatype w_node = Node nat ("'('_ _ '_')")
  | Entry ("'('_Entry'_')")
  | Exit ("'('_Exit'_')")

fun label_incr :: "w_node \<Rightarrow> nat \<Rightarrow> w_node" ("_ \<oplus> _" 60)
where "(_ l _) \<oplus> i = (_ l + i _)"
  | "(_Entry_) \<oplus> i = (_Entry_)"
  | "(_Exit_) \<oplus> i  = (_Exit_)"

lemma Exit_label_incr [dest]: "(_Exit_) = n \<oplus> i \<Longrightarrow> n = (_Exit_)"
  by(cases n,auto)

lemma label_incr_Exit [dest]: "n \<oplus> i = (_Exit_) \<Longrightarrow> n = (_Exit_)"
  by(cases n,auto)

lemma Entry_label_incr [dest]: "(_Entry_) = n \<oplus> i \<Longrightarrow> n = (_Entry_)"
  by(cases n,auto)

lemma label_incr_Entry [dest]: "n \<oplus> i = (_Entry_) \<Longrightarrow> n = (_Entry_)"
  by(cases n,auto)

lemma label_incr_inj:
  "n \<oplus> c = n' \<oplus> c \<Longrightarrow> n = n'"
by(cases n)(cases n',auto)+

lemma label_incr_simp:"n \<oplus> i = m \<oplus> (i + j) \<Longrightarrow> n = m \<oplus> j"
by(cases n,auto,cases m,auto)

lemma label_incr_start_Node_smaller:
  "(_ l _) = n \<oplus> i \<Longrightarrow> n = (_(l - i)_)"
by(cases n,auto)

lemma label_incr_ge:"(_ l _) = n \<oplus> i \<Longrightarrow> l \<ge> i"
by(cases n) auto

lemma label_incr_0 [dest]:
  "\<lbrakk>(_0_) = n \<oplus> i; i > 0\<rbrakk> \<Longrightarrow> False"
by(cases n) auto

lemma label_incr_0_rev [dest]:
  "\<lbrakk>n \<oplus> i = (_0_); i > 0\<rbrakk> \<Longrightarrow> False"
by(cases n) auto

subsection\<open>CFG edges\<close>

type_synonym w_edge = "(w_node \<times> state edge_kind \<times> w_node)"

inductive While_CFG :: "cmd \<Rightarrow> w_node \<Rightarrow> state edge_kind \<Rightarrow> w_node \<Rightarrow> bool"
  ("_ \<turnstile> _ -_\<rightarrow> _")
where

WCFG_Entry_Exit:
  "prog \<turnstile> (_Entry_) -(\<lambda>s. False)\<^sub>\<surd>\<rightarrow> (_Exit_)"

| WCFG_Entry:
  "prog \<turnstile> (_Entry_) -(\<lambda>s. True)\<^sub>\<surd>\<rightarrow> (_0_)"

| WCFG_Skip:
  "Skip \<turnstile> (_0_) -\<Up>id\<rightarrow> (_Exit_)"

| WCFG_LAss:
  "V:=e \<turnstile> (_0_) -\<Up>(\<lambda>s. s(V:=(interpret e s)))\<rightarrow> (_1_)"

| WCFG_LAssSkip:
  "V:=e \<turnstile> (_1_) -\<Up>id\<rightarrow> (_Exit_)"

| WCFG_SeqFirst:
  "\<lbrakk>c\<^sub>1 \<turnstile> n -et\<rightarrow> n'; n' \<noteq> (_Exit_)\<rbrakk> \<Longrightarrow> c\<^sub>1;;c\<^sub>2 \<turnstile> n -et\<rightarrow> n'"

| WCFG_SeqConnect:
  "\<lbrakk>c\<^sub>1 \<turnstile> n -et\<rightarrow> (_Exit_); n \<noteq> (_Entry_)\<rbrakk> \<Longrightarrow> c\<^sub>1;;c\<^sub>2 \<turnstile> n -et\<rightarrow> (_0_) \<oplus> #:c\<^sub>1"

| WCFG_SeqSecond:
  "\<lbrakk>c\<^sub>2 \<turnstile> n -et\<rightarrow> n'; n \<noteq> (_Entry_)\<rbrakk> \<Longrightarrow> c\<^sub>1;;c\<^sub>2 \<turnstile> n \<oplus> #:c\<^sub>1 -et\<rightarrow> n' \<oplus> #:c\<^sub>1"

| WCFG_CondTrue:
    "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some true)\<^sub>\<surd>\<rightarrow> (_0_) \<oplus> 1"

| WCFG_CondFalse:
    "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some false)\<^sub>\<surd>\<rightarrow> (_0_) \<oplus> (#:c\<^sub>1 + 1)"

| WCFG_CondThen:
  "\<lbrakk>c\<^sub>1 \<turnstile> n -et\<rightarrow> n'; n \<noteq> (_Entry_)\<rbrakk> \<Longrightarrow> if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n \<oplus> 1 -et\<rightarrow> n' \<oplus> 1"

| WCFG_CondElse:
  "\<lbrakk>c\<^sub>2 \<turnstile> n -et\<rightarrow> n'; n \<noteq> (_Entry_)\<rbrakk>
  \<Longrightarrow> if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n \<oplus> (#:c\<^sub>1 + 1) -et\<rightarrow> n' \<oplus> (#:c\<^sub>1 + 1)"

| WCFG_WhileTrue:
    "while (b) c' \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some true)\<^sub>\<surd>\<rightarrow> (_0_) \<oplus> 2"

| WCFG_WhileFalse:
    "while (b) c' \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some false)\<^sub>\<surd>\<rightarrow> (_1_)"

| WCFG_WhileFalseSkip:
  "while (b) c' \<turnstile> (_1_) -\<Up>id\<rightarrow> (_Exit_)"

| WCFG_WhileBody:
  "\<lbrakk>c' \<turnstile> n -et\<rightarrow> n'; n \<noteq> (_Entry_); n' \<noteq> (_Exit_)\<rbrakk>
  \<Longrightarrow> while (b) c' \<turnstile> n \<oplus> 2 -et\<rightarrow> n' \<oplus> 2"

| WCFG_WhileBodyExit:
  "\<lbrakk>c' \<turnstile> n -et\<rightarrow> (_Exit_); n \<noteq> (_Entry_)\<rbrakk> \<Longrightarrow> while (b) c' \<turnstile> n \<oplus> 2 -et\<rightarrow> (_0_)"

lemmas WCFG_intros = While_CFG.intros[split_format (complete)]
lemmas WCFG_elims = While_CFG.cases[split_format (complete)]
lemmas WCFG_induct = While_CFG.induct[split_format (complete)]

subsection \<open>Some lemmas about the CFG\<close>

lemma WCFG_Exit_no_sourcenode [dest]:
  "prog \<turnstile> (_Exit_) -et\<rightarrow> n' \<Longrightarrow> False"
by(induct prog n\<equiv>"(_Exit_)" et n' rule:WCFG_induct,auto)

lemma WCFG_Entry_no_targetnode [dest]:
  "prog \<turnstile> n -et\<rightarrow> (_Entry_) \<Longrightarrow> False"
by(induct prog n et n'\<equiv>"(_Entry_)" rule:WCFG_induct,auto)

lemma WCFG_targetlabel_less_num_nodes:
  "prog \<turnstile> n -et\<rightarrow> (_ l _) \<Longrightarrow> l < #:prog"
proof(induct prog n et "(_ l _)" arbitrary:l rule:WCFG_induct)
  case (WCFG_SeqFirst c\<^sub>1 n et c\<^sub>2)
  from \<open>l < #:c\<^sub>1\<close> show ?case by simp
next
  case (WCFG_SeqSecond c\<^sub>2 n et n' c\<^sub>1)
  note IH = \<open>\<And>l. n' = (_ l _) \<Longrightarrow> l < #:c\<^sub>2\<close>
  from \<open>n' \<oplus> #:c\<^sub>1 = (_ l _)\<close> obtain l' where "n' = (_ l' _)" by(cases n') auto
  from IH[OF this] have "l' < #:c\<^sub>2" .
  with \<open>n' \<oplus> #:c\<^sub>1 = (_ l _)\<close> \<open>n' = (_ l' _)\<close> show ?case by simp
next
  case (WCFG_CondThen c\<^sub>1 n et n' b c\<^sub>2)
  note IH = \<open>\<And>l. n' = (_ l _) \<Longrightarrow> l < #:c\<^sub>1\<close>
  from \<open>n' \<oplus> 1 = (_ l _)\<close> obtain l' where "n' = (_ l' _)" by(cases n') auto
  from IH[OF this] have "l' < #:c\<^sub>1" .
  with \<open>n' \<oplus> 1 = (_ l _)\<close> \<open>n' = (_ l' _)\<close> show ?case by simp
next
  case (WCFG_CondElse c\<^sub>2 n et n' b c\<^sub>1)
  note IH = \<open>\<And>l. n' = (_ l _) \<Longrightarrow> l < #:c\<^sub>2\<close>
  from \<open>n' \<oplus> (#:c\<^sub>1 + 1) = (_ l _)\<close> obtain l' where "n' = (_ l' _)" by(cases n') auto
  from IH[OF this] have "l' < #:c\<^sub>2" .
  with \<open>n' \<oplus> (#:c\<^sub>1 + 1) = (_ l _)\<close> \<open>n' = (_ l' _)\<close> show ?case by simp
next
  case (WCFG_WhileBody c' n et n' b)
  note IH = \<open>\<And>l. n' = (_ l _) \<Longrightarrow> l < #:c'\<close>
  from \<open>n' \<oplus> 2 = (_ l _)\<close> obtain l' where "n' = (_ l' _)" by(cases n') auto
  from IH[OF this] have "l' < #:c'" .
  with \<open>n' \<oplus> 2 = (_ l _)\<close> \<open>n' = (_ l' _)\<close> show ?case by simp
qed (auto simp:num_inner_nodes_gr_0)

lemma WCFG_EntryD:
  "prog \<turnstile> (_Entry_) -et\<rightarrow> n'
  \<Longrightarrow> (n' = (_Exit_) \<and> et = (\<lambda>s. False)\<^sub>\<surd>) \<or> (n' = (_0_) \<and> et = (\<lambda>s. True)\<^sub>\<surd>)"
by(induct prog n\<equiv>"(_Entry_)" et n' rule:WCFG_induct,auto)

(*<*)declare One_nat_def [simp del] add_2_eq_Suc' [simp del](*>*)

lemma WCFG_edge_det:
  "\<lbrakk>prog \<turnstile> n -et\<rightarrow> n'; prog \<turnstile> n -et'\<rightarrow> n'\<rbrakk> \<Longrightarrow> et = et'"
proof(induct rule:WCFG_induct)
  case WCFG_Entry_Exit thus ?case by(fastforce dest:WCFG_EntryD)
next
  case WCFG_Entry thus ?case by(fastforce dest:WCFG_EntryD)
next
  case WCFG_Skip thus ?case by(fastforce elim:WCFG_elims)
next
  case WCFG_LAss thus ?case by(fastforce elim:WCFG_elims)
next
  case WCFG_LAssSkip thus ?case by(fastforce elim:WCFG_elims)
next
  case (WCFG_SeqFirst c\<^sub>1 n et n' c\<^sub>2)
  note IH = \<open>c\<^sub>1 \<turnstile> n -et'\<rightarrow> n' \<Longrightarrow> et = et'\<close>
  from \<open>c\<^sub>1 \<turnstile> n -et\<rightarrow> n'\<close> \<open>n' \<noteq> (_Exit_)\<close> obtain l where "n' = (_ l _)"
    by (cases n') auto
  with \<open>c\<^sub>1 \<turnstile> n -et\<rightarrow> n'\<close> have "l < #:c\<^sub>1"
    by(fastforce intro:WCFG_targetlabel_less_num_nodes)
  with \<open>c\<^sub>1;;c\<^sub>2 \<turnstile> n -et'\<rightarrow> n'\<close> \<open>n' = (_ l _)\<close> have "c\<^sub>1 \<turnstile> n -et'\<rightarrow> n'"
    by(fastforce elim:WCFG_elims intro:WCFG_intros dest:label_incr_ge)
  from IH[OF this] show ?case .
next
  case (WCFG_SeqConnect c\<^sub>1 n et c\<^sub>2)
  note IH = \<open>c\<^sub>1 \<turnstile> n -et'\<rightarrow> (_Exit_) \<Longrightarrow> et = et'\<close>
  from \<open>c\<^sub>1 \<turnstile> n -et\<rightarrow> (_Exit_)\<close> \<open>n \<noteq> (_Entry_)\<close> obtain l where "n = (_ l _)"
    by (cases n) auto
  with \<open>c\<^sub>1 \<turnstile> n -et\<rightarrow> (_Exit_)\<close> have "l < #:c\<^sub>1"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  with \<open>c\<^sub>1;;c\<^sub>2 \<turnstile> n -et'\<rightarrow> (_ 0 _) \<oplus> #:c\<^sub>1\<close> \<open>n = (_ l _)\<close> have "c\<^sub>1 \<turnstile> n -et'\<rightarrow> (_Exit_)"
    by(fastforce elim:WCFG_elims dest:WCFG_targetlabel_less_num_nodes label_incr_ge)
  from IH[OF this] show ?case .
next
  case (WCFG_SeqSecond c\<^sub>2 n et n' c\<^sub>1)
  note IH = \<open>c\<^sub>2 \<turnstile> n -et'\<rightarrow> n' \<Longrightarrow> et = et'\<close>
  from \<open>c\<^sub>2 \<turnstile> n -et\<rightarrow> n'\<close> \<open>n \<noteq> (_Entry_)\<close> obtain l where "n = (_ l _)"
    by (cases n) auto
  with \<open>c\<^sub>2 \<turnstile> n -et\<rightarrow> n'\<close> have "l < #:c\<^sub>2"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  with \<open>c\<^sub>1;;c\<^sub>2 \<turnstile> n \<oplus> #:c\<^sub>1 -et'\<rightarrow> n' \<oplus> #:c\<^sub>1\<close> \<open>n = (_ l _)\<close> have "c\<^sub>2 \<turnstile> n -et'\<rightarrow> n'"
    by -(erule WCFG_elims,(fastforce dest:WCFG_sourcelabel_less_num_nodes label_incr_ge
                                    dest!:label_incr_inj)+)
  from IH[OF this] show ?case .
next
  case WCFG_CondTrue thus ?case by(fastforce elim:WCFG_elims)
next
  case WCFG_CondFalse thus ?case by(fastforce elim:WCFG_elims)
next
  case (WCFG_CondThen c\<^sub>1 n et n' b c\<^sub>2)
  note IH = \<open>c\<^sub>1 \<turnstile> n -et'\<rightarrow> n' \<Longrightarrow> et = et'\<close>
  from \<open>c\<^sub>1 \<turnstile> n -et\<rightarrow> n'\<close> \<open>n \<noteq> (_Entry_)\<close> obtain l where "n = (_ l _)"
    by (cases n) auto
  with \<open>c\<^sub>1 \<turnstile> n -et\<rightarrow> n'\<close> have "l < #:c\<^sub>1"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  with \<open>if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n \<oplus> 1 -et'\<rightarrow> n' \<oplus> 1\<close> \<open>n = (_ l _)\<close>
  have "c\<^sub>1 \<turnstile> n -et'\<rightarrow> n'"
    by -(erule WCFG_elims,(fastforce dest:label_incr_ge label_incr_inj)+)
  from IH[OF this] show ?case .
next
  case (WCFG_CondElse c\<^sub>2 n et n' b c\<^sub>1)
  note IH = \<open>c\<^sub>2 \<turnstile> n -et'\<rightarrow> n' \<Longrightarrow> et = et'\<close>
  from \<open>c\<^sub>2 \<turnstile> n -et\<rightarrow> n'\<close> \<open>n \<noteq> (_Entry_)\<close> obtain l where "n = (_ l _)"
    by (cases n) auto
  with \<open>c\<^sub>2 \<turnstile> n -et\<rightarrow> n'\<close> have "l < #:c\<^sub>2"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  with \<open>if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n \<oplus> (#:c\<^sub>1 + 1) -et'\<rightarrow> n' \<oplus> (#:c\<^sub>1 + 1)\<close> \<open>n = (_ l _)\<close>
  have "c\<^sub>2 \<turnstile> n -et'\<rightarrow> n'"
    by -(erule WCFG_elims,(fastforce dest:WCFG_sourcelabel_less_num_nodes
                             label_incr_inj label_incr_ge label_incr_simp_rev)+)
  from IH[OF this] show ?case .
next
  case WCFG_WhileTrue thus ?case by(fastforce elim:WCFG_elims)
next
  case WCFG_WhileFalse thus ?case by(fastforce elim:WCFG_elims)
next
  case WCFG_WhileFalseSkip thus ?case by(fastforce elim:WCFG_elims)
next
  case (WCFG_WhileBody c' n et n' b)
  note IH = \<open>c' \<turnstile> n -et'\<rightarrow> n' \<Longrightarrow> et = et'\<close>
  from \<open>c' \<turnstile> n -et\<rightarrow> n'\<close> \<open>n \<noteq> (_Entry_)\<close> obtain l where "n = (_ l _)"
    by (cases n) auto
  moreover
  with \<open>c' \<turnstile> n -et\<rightarrow> n'\<close> have "l < #:c'"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  moreover
  from \<open>c' \<turnstile> n -et\<rightarrow> n'\<close> \<open>n' \<noteq> (_Exit_)\<close> obtain l' where "n' = (_ l' _)"
    by (cases n') auto
  moreover
  with \<open>c' \<turnstile> n -et\<rightarrow> n'\<close> have "l' < #:c'"
    by(fastforce intro:WCFG_targetlabel_less_num_nodes)
  ultimately have "c' \<turnstile> n -et'\<rightarrow> n'" using \<open>while (b) c' \<turnstile> n \<oplus> 2 -et'\<rightarrow> n' \<oplus> 2\<close>
    by(fastforce elim:WCFG_elims dest:label_incr_start_Node_smaller)
  from IH[OF this] show ?case .
next
  case (WCFG_WhileBodyExit c' n et b)
  note IH = \<open>c' \<turnstile> n -et'\<rightarrow> (_Exit_) \<Longrightarrow> et = et'\<close>
  from \<open>c' \<turnstile> n -et\<rightarrow> (_Exit_)\<close> \<open>n \<noteq> (_Entry_)\<close> obtain l where "n = (_ l _)"
    by (cases n) auto
  with \<open>c' \<turnstile> n -et\<rightarrow> (_Exit_)\<close> have "l < #:c'"
    by(fastforce intro:WCFG_sourcelabel_less_num_nodes)
  with \<open>while (b) c' \<turnstile> n \<oplus> 2 -et'\<rightarrow> (_0_)\<close> \<open>n = (_ l _)\<close>
  have "c' \<turnstile> n -et'\<rightarrow> (_Exit_)"
    by -(erule WCFG_elims,auto dest:label_incr_start_Node_smaller)
  from IH[OF this] show ?case .
qed

(*<*)declare One_nat_def [simp] add_2_eq_Suc' [simp](*>*)

lemma less_num_nodes_edge_Exit:
  obtains l et where "l < #:prog" and "prog \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)"
proof -
  have "\<exists>l et. l < #:prog \<and> prog \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)"
  proof(induct prog)
    case Skip
    have "0 < #:Skip" by simp
    moreover have "Skip \<turnstile> (_0_) -\<Up>id\<rightarrow> (_Exit_)" by(rule WCFG_Skip)
    ultimately show ?case by blast
  next
    case (LAss V e)
    have "1 < #:(V:=e)" by simp
    moreover have "V:=e \<turnstile> (_1_) -\<Up>id\<rightarrow> (_Exit_)" by(rule WCFG_LAssSkip)
    ultimately show ?case by blast
  next
    case (Seq prog1 prog2)
    from \<open>\<exists>l et. l < #:prog2 \<and> prog2 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)\<close>
    obtain l et where "l < #:prog2" and "prog2 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)"
      by blast
    from \<open>prog2 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)\<close>
    have "prog1;;prog2 \<turnstile> (_ l _) \<oplus> #:prog1 -et\<rightarrow> (_Exit_) \<oplus> #:prog1"
      by(fastforce intro:WCFG_SeqSecond)
    with \<open>l < #:prog2\<close> show ?case by(rule_tac x="l + #:prog1" in exI,auto)
  next
    case (Cond b prog1 prog2)
    from \<open>\<exists>l et. l < #:prog1 \<and> prog1 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)\<close>
    obtain l et where "l < #:prog1" and "prog1 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)"
      by blast
    from \<open>prog1 \<turnstile> (_ l _) -et\<rightarrow> (_Exit_)\<close>
    have "if (b) prog1 else prog2 \<turnstile> (_ l _) \<oplus> 1 -et\<rightarrow> (_Exit_) \<oplus> 1"
      by(fastforce intro:WCFG_CondThen)
    with \<open>l < #:prog1\<close> show ?case by(rule_tac x="l + 1" in exI,auto)
  next
    case (While b prog')
    have "1 < #:(while (b) prog')" by simp
    moreover have "while (b) prog' \<turnstile> (_1_) -\<Up>id\<rightarrow> (_Exit_)"
      by(rule WCFG_WhileFalseSkip)
    ultimately show ?case by blast
  qed
  with that show ?thesis by blast
qed

lemma less_num_nodes_edge:
  "l < #:prog \<Longrightarrow> \<exists>n et. prog \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog \<turnstile> (_ l _) -et\<rightarrow> n"
proof(induct prog arbitrary:l)
  case Skip
  from \<open>l < #:Skip\<close> have "l = 0" by simp
  hence "Skip \<turnstile> (_ l _) -\<Up>id\<rightarrow> (_Exit_)" by(fastforce intro:WCFG_Skip)
  thus ?case by blast
next
  case (LAss V e)
  from \<open>l < #:V:=e\<close> have "l = 0 \<or> l = 1" by auto
  thus ?case
  proof
    assume "l = 0"
    hence "V:=e \<turnstile> (_Entry_) -(\<lambda>s. True)\<^sub>\<surd>\<rightarrow> (_ l _)" by(fastforce intro:WCFG_Entry)
    thus ?thesis by blast
  next
    assume "l = 1"
    hence "V:=e \<turnstile> (_ l _) -\<Up>id\<rightarrow> (_Exit_)" by(fastforce intro:WCFG_LAssSkip)
    thus ?thesis by blast
  qed
next
  case (Seq prog1 prog2)
  note IH1 = \<open>\<And>l. l < #:prog1 \<Longrightarrow>
              \<exists>n et. prog1 \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog1 \<turnstile> (_ l _) -et\<rightarrow> n\<close>
  note IH2 = \<open>\<And>l. l < #:prog2 \<Longrightarrow>
              \<exists>n et. prog2 \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog2 \<turnstile> (_ l _) -et\<rightarrow> n\<close>
  show ?case
  proof(cases "l < #:prog1")
    case True
    from IH1[OF this] obtain n et
      where "prog1 \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog1 \<turnstile> (_ l _) -et\<rightarrow> n" by blast
    thus ?thesis
    proof
      assume "prog1 \<turnstile> n -et\<rightarrow> (_ l _)"
      hence "prog1;; prog2 \<turnstile> n -et\<rightarrow> (_ l _)" by(fastforce intro:WCFG_SeqFirst)
      thus ?thesis by blast
    next
      assume edge:"prog1 \<turnstile> (_ l _) -et\<rightarrow> n"
      show ?thesis
      proof(cases "n = (_Exit_)")
        case True
        with edge have "prog1;; prog2 \<turnstile> (_ l _) -et\<rightarrow> (_0_) \<oplus> #:prog1"
          by(fastforce intro:WCFG_SeqConnect)
        thus ?thesis by blast
      next
        case False
        with edge have "prog1;; prog2 \<turnstile> (_ l _) -et\<rightarrow> n"
          by(fastforce intro:WCFG_SeqFirst)
        thus ?thesis by blast
      qed
    qed
  next
    case False
    hence "#:prog1 \<le> l" by simp
    then obtain l' where "l = l' + #:prog1" and "l' = l - #:prog1" by simp
    from \<open>l = l' + #:prog1\<close> \<open>l < #:prog1;; prog2\<close> have "l' < #:prog2" by simp
    from IH2[OF this] obtain n et
      where "prog2 \<turnstile> n -et\<rightarrow> (_ l' _) \<or> prog2 \<turnstile> (_ l' _) -et\<rightarrow> n" by blast
    thus ?thesis
    proof
      assume "prog2 \<turnstile> n -et\<rightarrow> (_ l' _)"
      show ?thesis
      proof(cases "n = (_Entry_)")
        case True
        with \<open>prog2 \<turnstile> n -et\<rightarrow> (_ l' _)\<close> have "l' = 0" by(auto dest:WCFG_EntryD)
        obtain l'' et'' where "l'' < #:prog1"
          and "prog1 \<turnstile> (_ l'' _) -et''\<rightarrow> (_Exit_)"
          by(erule less_num_nodes_edge_Exit)
        hence "prog1;;prog2 \<turnstile> (_ l'' _) -et''\<rightarrow> (_0_) \<oplus> #:prog1"
          by(fastforce intro:WCFG_SeqConnect)
        with \<open>l' = 0\<close> \<open>l = l' + #:prog1\<close> show ?thesis by simp blast
      next
        case False
        with \<open>prog2 \<turnstile> n -et\<rightarrow> (_ l' _)\<close>
        have "prog1;;prog2 \<turnstile> n \<oplus> #:prog1 -et\<rightarrow> (_ l' _) \<oplus> #:prog1"
          by(fastforce intro:WCFG_SeqSecond)
        with \<open>l = l' + #:prog1\<close> show ?thesis  by simp blast
      qed
    next
      assume "prog2 \<turnstile> (_ l' _) -et\<rightarrow> n"
      hence "prog1;;prog2 \<turnstile> (_ l' _) \<oplus> #:prog1 -et\<rightarrow> n \<oplus> #:prog1"
        by(fastforce intro:WCFG_SeqSecond)
      with \<open>l = l' + #:prog1\<close> show ?thesis  by simp blast
    qed
  qed
next
  case (Cond b prog1 prog2)
  note IH1 = \<open>\<And>l. l < #:prog1 \<Longrightarrow>
              \<exists>n et. prog1 \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog1 \<turnstile> (_ l _) -et\<rightarrow> n\<close>
  note IH2 = \<open>\<And>l. l < #:prog2 \<Longrightarrow>
              \<exists>n et. prog2 \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog2 \<turnstile> (_ l _) -et\<rightarrow> n\<close>
  show ?case
  proof(cases "l = 0")
    case True
    have "if (b) prog1 else prog2 \<turnstile> (_Entry_) -(\<lambda>s. True)\<^sub>\<surd>\<rightarrow> (_0_)"
      by(rule WCFG_Entry)
    with True show ?thesis by simp blast
  next
    case False
    hence "0 < l" by simp
    then obtain l' where "l = l' + 1" and "l' = l - 1" by simp
    thus ?thesis
    proof(cases "l' < #:prog1")
      case True
      from IH1[OF this] obtain n et
        where "prog1 \<turnstile> n -et\<rightarrow> (_ l' _) \<or> prog1 \<turnstile> (_ l' _) -et\<rightarrow> n" by blast
      thus ?thesis
      proof
        assume edge:"prog1 \<turnstile> n -et\<rightarrow> (_ l' _)"
        show ?thesis
        proof(cases "n = (_Entry_)")
          case True
          with edge have "l' = 0" by(auto dest:WCFG_EntryD)
          have "if (b) prog1 else prog2 \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some true)\<^sub>\<surd>\<rightarrow>
                                          (_0_) \<oplus> 1"
            by(rule WCFG_CondTrue)
          with \<open>l' = 0\<close> \<open>l = l' + 1\<close> show ?thesis by simp blast
        next
          case False
          with edge have "if (b) prog1 else prog2 \<turnstile> n \<oplus> 1 -et\<rightarrow> (_ l' _) \<oplus> 1"
            by(fastforce intro:WCFG_CondThen)
          with \<open>l = l' + 1\<close> show ?thesis by simp blast
        qed
      next
        assume "prog1 \<turnstile> (_ l' _) -et\<rightarrow> n"
        hence "if (b) prog1 else prog2 \<turnstile> (_ l' _) \<oplus> 1 -et\<rightarrow> n \<oplus> 1"
          by(fastforce intro:WCFG_CondThen)
        with \<open>l = l' + 1\<close> show ?thesis by simp blast
      qed
    next
      case False
      hence "#:prog1 \<le> l'" by simp
      then obtain l'' where "l' = l'' + #:prog1" and "l'' = l' - #:prog1"
        by simp
      from \<open>l' = l'' + #:prog1\<close> \<open>l = l' + 1\<close> \<open>l < #:(if (b) prog1 else prog2)\<close>
      have "l'' < #:prog2" by simp
      from IH2[OF this] obtain n et
        where "prog2 \<turnstile> n -et\<rightarrow> (_ l'' _) \<or> prog2 \<turnstile> (_ l'' _) -et\<rightarrow> n" by blast
      thus ?thesis
      proof
        assume "prog2 \<turnstile> n -et\<rightarrow> (_ l'' _)"
        show ?thesis
        proof(cases "n = (_Entry_)")
          case True
          with \<open>prog2 \<turnstile> n -et\<rightarrow> (_ l'' _)\<close> have "l'' = 0" by(auto dest:WCFG_EntryD)
          have "if (b) prog1 else prog2 \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some false)\<^sub>\<surd>\<rightarrow>
                                          (_0_) \<oplus> (#:prog1 + 1)"
            by(rule WCFG_CondFalse)
          with \<open>l'' = 0\<close> \<open>l' = l'' + #:prog1\<close> \<open>l = l' + 1\<close> show ?thesis by simp blast
        next
          case False
          with \<open>prog2 \<turnstile> n -et\<rightarrow> (_ l'' _)\<close>
          have "if (b) prog1 else prog2 \<turnstile> n \<oplus> (#:prog1 + 1) -et\<rightarrow>
                                          (_ l'' _) \<oplus> (#:prog1 + 1)"
            by(fastforce intro:WCFG_CondElse)
          with \<open>l = l' + 1\<close> \<open>l' = l'' + #:prog1\<close> show ?thesis by simp blast
        qed
      next
        assume "prog2 \<turnstile> (_ l'' _) -et\<rightarrow> n"
        hence "if (b) prog1 else prog2 \<turnstile> (_ l'' _) \<oplus> (#:prog1 + 1) -et\<rightarrow>
                                         n \<oplus> (#:prog1 + 1)"
          by(fastforce intro:WCFG_CondElse)
        with \<open>l = l' + 1\<close> \<open>l' = l'' + #:prog1\<close> show ?thesis by simp blast
      qed
    qed
  qed
next
  case (While b prog')
  note IH = \<open>\<And>l. l < #:prog'
             \<Longrightarrow> \<exists>n et. prog' \<turnstile> n -et\<rightarrow> (_ l _) \<or> prog' \<turnstile> (_ l _) -et\<rightarrow> n\<close>
  show ?case
  proof(cases "l < 1")
    case True
    have "while (b) prog' \<turnstile> (_Entry_) -(\<lambda>s. True)\<^sub>\<surd>\<rightarrow> (_0_)" by(rule WCFG_Entry)
    with True show ?thesis by simp blast
  next
    case False
    hence "1 \<le> l" by simp
    thus ?thesis
    proof(cases "l < 2")
      case True
      with \<open>1 \<le> l\<close> have "l = 1" by simp
      have "while (b) prog' \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some false)\<^sub>\<surd>\<rightarrow> (_1_)"
        by(rule WCFG_WhileFalse)
      with \<open>l = 1\<close> show ?thesis by simp blast
    next
      case False
      with \<open>1 \<le> l\<close> have "2 \<le> l" by simp
      then obtain l' where "l = l' + 2" and "l' = l - 2"
        by(simp del:add_2_eq_Suc')
      from \<open>l = l' + 2\<close> \<open>l < #:while (b) prog'\<close> have "l' < #:prog'" by simp
      from IH[OF this] obtain n et
        where "prog' \<turnstile> n -et\<rightarrow> (_ l' _) \<or> prog' \<turnstile> (_ l' _) -et\<rightarrow> n" by blast
      thus ?thesis
      proof
        assume "prog' \<turnstile> n -et\<rightarrow> (_ l' _)"
        show ?thesis
        proof(cases "n = (_Entry_)")
          case True
          with \<open>prog' \<turnstile> n -et\<rightarrow> (_ l' _)\<close> have "l' = 0" by(auto dest:WCFG_EntryD)
          have "while (b) prog' \<turnstile> (_0_) -(\<lambda>s. interpret b s = Some true)\<^sub>\<surd>\<rightarrow>
                                  (_0_) \<oplus> 2"
            by(rule WCFG_WhileTrue)
          with \<open>l' = 0\<close> \<open>l = l' + 2\<close> show ?thesis by simp blast
        next
          case False
          with \<open>prog' \<turnstile> n -et\<rightarrow> (_ l' _)\<close>
          have "while (b) prog' \<turnstile> n \<oplus> 2 -et\<rightarrow> (_ l' _) \<oplus> 2"
            by(fastforce intro:WCFG_WhileBody)
          with \<open>l = l' + 2\<close> show ?thesis by simp blast
        qed
      next
        assume "prog' \<turnstile> (_ l' _) -et\<rightarrow> n"
        show ?thesis
        proof(cases "n = (_Exit_)")
          case True
          with \<open>prog' \<turnstile> (_ l' _) -et\<rightarrow> n\<close>
          have "while (b) prog' \<turnstile> (_ l' _) \<oplus> 2 -et\<rightarrow> (_0_)"
            by(fastforce intro:WCFG_WhileBodyExit)
          with \<open>l = l' + 2\<close> show ?thesis by simp blast
        next
          case False
          with \<open>prog' \<turnstile> (_ l' _) -et\<rightarrow> n\<close>
          have "while (b) prog' \<turnstile> (_ l' _) \<oplus> 2 -et\<rightarrow> n \<oplus> 2"
            by(fastforce intro:WCFG_WhileBody)
          with \<open>l = l' + 2\<close> show ?thesis by simp blast
        qed
      qed
    qed
  qed
qed

(*<*)declare One_nat_def [simp del](*>*)

lemma WCFG_deterministic:
  "\<lbrakk>prog \<turnstile> n\<^sub>1 -et\<^sub>1\<rightarrow> n\<^sub>1'; prog \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n\<^sub>1 = n\<^sub>2; n\<^sub>1' \<noteq> n\<^sub>2'\<rbrakk>
  \<Longrightarrow> \<exists>Q Q'. et\<^sub>1 = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))"
proof(induct arbitrary:n\<^sub>2 n\<^sub>2' rule:WCFG_induct)
  case (WCFG_Entry_Exit prog)
  from \<open>prog \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>(_Entry_) = n\<^sub>2\<close> \<open>(_Exit_) \<noteq> n\<^sub>2'\<close>
  have "et\<^sub>2 = (\<lambda>s. True)\<^sub>\<surd>" by(fastforce dest:WCFG_EntryD)
  thus ?case by simp
next
  case (WCFG_Entry prog)
  from \<open>prog \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>(_Entry_) = n\<^sub>2\<close> \<open>(_0_) \<noteq> n\<^sub>2'\<close>
  have "et\<^sub>2 = (\<lambda>s. False)\<^sub>\<surd>" by(fastforce dest:WCFG_EntryD)
  thus ?case by simp
next
  case WCFG_Skip
  from \<open>Skip \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>(_0_) = n\<^sub>2\<close> \<open>(_Exit_) \<noteq> n\<^sub>2'\<close>
  have False by(fastforce elim:WCFG.While_CFG.cases)
  thus ?case by simp
next
  case (WCFG_LAss V e)
  from \<open>V:=e \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>(_0_) = n\<^sub>2\<close> \<open>(_1_) \<noteq> n\<^sub>2'\<close>
  have False by -(erule WCFG.While_CFG.cases,auto)
  thus ?case by simp
next
  case (WCFG_LAssSkip V e)
  from \<open>V:=e \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>(_1_) = n\<^sub>2\<close> \<open>(_Exit_) \<noteq> n\<^sub>2'\<close>
  have False by -(erule WCFG.While_CFG.cases,auto)
  thus ?case by simp
next
  case (WCFG_SeqFirst c\<^sub>1 n et n' c\<^sub>2)
  note IH = \<open>\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; n' \<noteq> n\<^sub>2'\<rbrakk>
  \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))\<close>
  from \<open>c\<^sub>1;;c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>c\<^sub>1 \<turnstile> n -et\<rightarrow> n'\<close> \<open>n = n\<^sub>2\<close> \<open>n' \<noteq> n\<^sub>2'\<close>
  have "c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2' \<or> (c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> (_Exit_) \<and> n\<^sub>2' = (_0_) \<oplus> #:c\<^sub>1)"
    apply hypsubst_thin apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
    by(case_tac n,auto dest:WCFG_sourcelabel_less_num_nodes)+
  thus ?case
  proof
    assume "c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'"
    from IH[OF this \<open>n = n\<^sub>2\<close> \<open>n' \<noteq> n\<^sub>2'\<close>] show ?case .
  next
    assume "c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> (_Exit_) \<and> n\<^sub>2' = (_0_) \<oplus> #:c\<^sub>1"
    hence edge:"c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> (_Exit_)" and n2':"n\<^sub>2' = (_0_) \<oplus> #:c\<^sub>1" by simp_all
    from IH[OF edge \<open>n = n\<^sub>2\<close> \<open>n' \<noteq> (_Exit_)\<close>] show ?case .
  qed
next
  case (WCFG_SeqConnect c\<^sub>1 n et c\<^sub>2)
  note IH = \<open>\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; (_Exit_) \<noteq> n\<^sub>2'\<rbrakk>
  \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))\<close>
  from \<open>c\<^sub>1;;c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>c\<^sub>1 \<turnstile> n -et\<rightarrow> (_Exit_)\<close> \<open>n = n\<^sub>2\<close> \<open>n \<noteq> (_Entry_)\<close>
    \<open>(_0_) \<oplus> #:c\<^sub>1 \<noteq> n\<^sub>2'\<close> have "c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2' \<and> (_Exit_) \<noteq> n\<^sub>2'"
    apply hypsubst_thin apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
    by(case_tac n,auto dest:WCFG_sourcelabel_less_num_nodes)+
  from IH[OF this[THEN conjunct1] \<open>n = n\<^sub>2\<close> this[THEN conjunct2]]
  show ?case .
next
  case (WCFG_SeqSecond c\<^sub>2 n et n' c\<^sub>1)
  note IH = \<open>\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; n' \<noteq> n\<^sub>2'\<rbrakk>
  \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))\<close>
  from \<open>c\<^sub>1;;c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>c\<^sub>2 \<turnstile> n -et\<rightarrow> n'\<close> \<open>n \<oplus> #:c\<^sub>1 = n\<^sub>2\<close>
    \<open>n' \<oplus> #:c\<^sub>1 \<noteq> n\<^sub>2'\<close> \<open>n \<noteq> (_Entry_)\<close>
  obtain nx where "c\<^sub>2 \<turnstile> n -et\<^sub>2\<rightarrow> nx \<and> nx \<oplus> #:c\<^sub>1 = n\<^sub>2'"
    apply - apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
      apply(cases n,auto dest:WCFG_sourcelabel_less_num_nodes)
     apply(cases n,auto dest:WCFG_sourcelabel_less_num_nodes)
    by(fastforce dest:label_incr_inj)
  with \<open>n' \<oplus> #:c\<^sub>1 \<noteq> n\<^sub>2'\<close> have edge:"c\<^sub>2 \<turnstile> n -et\<^sub>2\<rightarrow> nx" and neq:"n' \<noteq> nx"
    by auto
  from IH[OF edge _ neq] show ?case by simp
next
  case (WCFG_CondTrue b c\<^sub>1 c\<^sub>2)
  from \<open>if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>(_0_) = n\<^sub>2\<close> \<open>(_0_) \<oplus> 1 \<noteq> n\<^sub>2'\<close>
  show ?case by -(erule WCFG.While_CFG.cases,auto)
next
  case (WCFG_CondFalse b c\<^sub>1 c\<^sub>2)
  from \<open>if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>(_0_) = n\<^sub>2\<close> \<open>(_0_) \<oplus> #:c\<^sub>1 + 1 \<noteq> n\<^sub>2'\<close>
  show ?case by -(erule WCFG.While_CFG.cases,auto)
next
  case (WCFG_CondThen c\<^sub>1 n et n' b c\<^sub>2)
  note IH = \<open>\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c\<^sub>1 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; n' \<noteq> n\<^sub>2'\<rbrakk>
    \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))\<close>
  from \<open>if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>c\<^sub>1 \<turnstile> n -et\<rightarrow> n'\<close> \<open>n \<noteq> (_Entry_)\<close>
    \<open>n \<oplus> 1 = n\<^sub>2\<close> \<open>n' \<oplus> 1 \<noteq> n\<^sub>2'\<close>
  obtain nx where "c\<^sub>1 \<turnstile> n -et\<^sub>2\<rightarrow> nx \<and> n' \<noteq> nx"
    apply - apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
     apply(drule label_incr_inj) apply auto
    apply(drule label_incr_simp_rev[OF sym])
    by(case_tac na,auto dest:WCFG_sourcelabel_less_num_nodes)
  from IH[OF this[THEN conjunct1] _ this[THEN conjunct2]] show ?case by simp
next
  case (WCFG_CondElse c\<^sub>2 n et n' b c\<^sub>1)
  note IH = \<open>\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; n' \<noteq> n\<^sub>2'\<rbrakk>
    \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))\<close>
  from \<open>if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>c\<^sub>2 \<turnstile> n -et\<rightarrow> n'\<close> \<open>n \<noteq> (_Entry_)\<close>
    \<open>n \<oplus> #:c\<^sub>1 + 1 = n\<^sub>2\<close> \<open>n' \<oplus> #:c\<^sub>1 + 1 \<noteq> n\<^sub>2'\<close>
  obtain nx where "c\<^sub>2 \<turnstile> n -et\<^sub>2\<rightarrow> nx \<and> n' \<noteq> nx"
    apply - apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
     apply(drule label_incr_simp_rev)
     apply(case_tac na,auto,cases n,auto dest:WCFG_sourcelabel_less_num_nodes)
    by(fastforce dest:label_incr_inj)
  from IH[OF this[THEN conjunct1] _ this[THEN conjunct2]] show ?case by simp
next
  case (WCFG_WhileTrue b c')
  from \<open>while (b) c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>(_0_) = n\<^sub>2\<close> \<open>(_0_) \<oplus> 2 \<noteq> n\<^sub>2'\<close>
  show ?case by -(erule WCFG.While_CFG.cases,auto)
next
  case (WCFG_WhileFalse b c')
  from \<open>while (b) c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>(_0_) = n\<^sub>2\<close> \<open>(_1_) \<noteq> n\<^sub>2'\<close>
  show ?case by -(erule WCFG.While_CFG.cases,auto)
next
  case (WCFG_WhileFalseSkip b c')
  from \<open>while (b) c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>(_1_) = n\<^sub>2\<close> \<open>(_Exit_) \<noteq> n\<^sub>2'\<close>
  show ?case by -(erule WCFG.While_CFG.cases,auto dest:label_incr_ge)
next
  case (WCFG_WhileBody c' n et n' b)
  note IH = \<open>\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; n' \<noteq> n\<^sub>2'\<rbrakk>
    \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))\<close>
  from \<open>while (b) c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>c' \<turnstile> n -et\<rightarrow> n'\<close> \<open>n \<noteq> (_Entry_)\<close>
    \<open>n' \<noteq> (_Exit_)\<close> \<open>n \<oplus> 2 = n\<^sub>2\<close> \<open>n' \<oplus> 2 \<noteq> n\<^sub>2'\<close>
  obtain nx where "c' \<turnstile> n -et\<^sub>2\<rightarrow> nx \<and> n' \<noteq> nx"
    apply - apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
      apply(fastforce dest:label_incr_ge[OF sym])
     apply(fastforce dest:label_incr_inj)
    by(fastforce dest:label_incr_inj)
  from IH[OF this[THEN conjunct1] _ this[THEN conjunct2]] show ?case by simp
next
  case (WCFG_WhileBodyExit c' n et b)
  note IH = \<open>\<And>n\<^sub>2 n\<^sub>2'. \<lbrakk>c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'; n = n\<^sub>2; (_Exit_) \<noteq> n\<^sub>2'\<rbrakk>
    \<Longrightarrow> \<exists>Q Q'. et = (Q)\<^sub>\<surd> \<and> et\<^sub>2 = (Q')\<^sub>\<surd> \<and> (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))\<close>
  from \<open>while (b) c' \<turnstile> n\<^sub>2 -et\<^sub>2\<rightarrow> n\<^sub>2'\<close> \<open>c' \<turnstile> n -et\<rightarrow> (_Exit_)\<close> \<open>n \<noteq> (_Entry_)\<close>
    \<open>n \<oplus> 2 = n\<^sub>2\<close> \<open>(_0_) \<noteq> n\<^sub>2'\<close>
  obtain nx where "c' \<turnstile> n -et\<^sub>2\<rightarrow> nx \<and> (_Exit_) \<noteq> nx"
    apply - apply(erule WCFG.While_CFG.cases)
    apply(auto intro:WCFG.While_CFG.intros)
     apply(fastforce dest:label_incr_ge[OF sym])
    by(fastforce dest:label_incr_inj)
  from IH[OF this[THEN conjunct1] _ this[THEN conjunct2]] show ?case by simp
qed

(*<*)declare One_nat_def [simp](*>*)

end


theory Logical_Equivalence
imports
  Validity
begin

section \<open>(Strong) Logical Equivalence\<close>

text \<open>The definition of formulas is parametric in the index type, but from now on we want to work
with a fixed (sufficiently large) index type.\<close>

locale indexed_nominal_ts = nominal_ts satisfies transition
  for satisfies :: "'state::fs \<Rightarrow> 'pred::fs \<Rightarrow> bool" (infix "\<turnstile>" 70)
  and transition :: "'state \<Rightarrow> ('act::bn,'state) residual \<Rightarrow> bool" (infix "\<rightarrow>" 70) +
  assumes card_idx_perm: "|UNIV::perm set| <o |UNIV::'idx set|"
      and card_idx_state: "|UNIV::'state set| <o |UNIV::'idx set|"
begin

  definition logically_equivalent :: "'state \<Rightarrow> 'state \<Rightarrow> bool" where
    "logically_equivalent P Q \<equiv> (\<forall>x::('idx,'pred,'act) formula. P \<Turnstile> x \<longleftrightarrow> Q \<Turnstile> x)"

  notation logically_equivalent (infix "=\<cdot>" 50)

  lemma logically_equivalent_eqvt:
    assumes "P =\<cdot> Q" shows "p \<bullet> P =\<cdot> p \<bullet> Q"
  using assms unfolding logically_equivalent_def
  by (metis (mono_tags) permute_minus_cancel(1) valid_eqvt)

end

end