subsubsection \<open>Monitor\<close>

theory Simple_RM
imports "../../Reference_Monitor" Simple_Lang
begin

text \<open>We now define the implementation of a reference monitor for our simple programming language
(and a given flow policy).\<close>

locale Simple_RM =
  fixes s0 :: "'var state"
    and observe :: "'dom \<Rightarrow> 'var set"
    and alter :: "'dom \<Rightarrow> 'var set"
    and FP :: "'dom rel"
  assumes refl_FP: "refl FP"
      and trans_FP: "trans FP"
      and FP_observe: "(u, v) \<in> FP \<Longrightarrow> observe u \<subseteq> observe v"
      and alter_observe_FP: "n \<in> alter u \<Longrightarrow> n \<in> observe v \<Longrightarrow> (u, v) \<in> FP"
begin

text \<open>The @{text check} function returns true for an assignment @{text "v :=\<^bsub>d\<^esub> e"} if @{text v}
is writable by @{text d} and the variables in @{text e} are readable for @{text d}.\<close>

fun check :: "('var, 'dom) cmd \<Rightarrow> bool" where
  "check (v :=\<^bsub>d\<^esub> e) = (v \<in> alter d \<and> Vars e \<subseteq> observe d)"

text \<open>If the check is successful, the state is updated and the evaluation of the expressions is
given as output; otherwise, the state remains unchanged, and 0 is given as output.\<close>

fun step :: "'var state \<Rightarrow> ('var, 'dom) cmd \<Rightarrow> 'var state" where
  "step s (v :=\<^bsub>d\<^esub> e) = (if check (v :=\<^bsub>d\<^esub> e)
                         then execute s (v :=\<^bsub>d\<^esub> e)
                         else s)"

fun out :: "'var state \<Rightarrow> ('var, 'dom) cmd \<Rightarrow> integer" where
  "out s (v :=\<^bsub>d\<^esub> e) = (if check (v :=\<^bsub>d\<^esub> e)
                        then \<E> e s
                        else 0)"

definition contents :: "'var state \<Rightarrow> 'var \<Rightarrow> integer" where
 [simp]: "contents s v = s v"

sublocale Automaton s0 step out .

text \<open>We currently assume that the consistency conditions for the implementation of the flow policy
hold (we will have to prove this later for concrete instantiations).\<close>

sublocale FP_Implementation s0 step out contents FP dom observe alter
using refl_FP trans_FP FP_observe alter_observe_FP
by unfold_locales

notation view'' ("_ \<sim>\<^bsub>_\<^esub> _")

text \<open>We can, however, already prove generally that the reference monitor assumptions hold.

As a helper lemma, we prove that expressions used in assignments allowed for
@{text d} are evaluated to the same value in states equivalent for @{text d}.\<close>

lemma view_coincidence:
  assumes "s \<sim>\<^bsub>d\<^esub> t"
      and "check (v :=\<^bsub>d\<^esub> e)"
  shows "\<E> e s = \<E> e t"
proof (intro coincidence)
  from assms(2) have "Vars e \<subseteq> observe d" by auto
  with assms(1) show "\<forall>v \<in> Vars e. s v = t v" unfolding view_def by auto
qed

text \<open>We then prove the three reference monitor assumptions.\<close>

sublocale Reference_Monitor s0 step out contents FP dom observe alter
proof
  \<comment> \<open>RMA1\<close>
  fix s t fix a :: "('var, 'dom) cmd"
  obtain v d e where [simp]: "a = (v :=\<^bsub>d\<^esub> e)" by (cases a)
  assume "s \<sim>\<^bsub>dom a\<^esub> t"
  then show "out s a = out t a"
  proof (cases "check a")
    case True
      then have "\<E> e s = \<E> e t" using `s \<sim>\<^bsub>dom a\<^esub> t`
        by (intro view_coincidence) auto
      then show "out s a = out t a" using True by auto
  next
    case False
      then have "out s a = 0" and "out t a = 0" by auto
      then show "out s a = out t a" by auto
  qed
next
  \<comment> \<open>RMA2\<close>
  fix s t n fix a :: "('var, 'dom) cmd"
  obtain v d e where [simp]: "a = (v :=\<^bsub>d\<^esub> e)" by (cases a)
  assume "s \<sim>\<^bsub>dom a\<^esub> t"
     and "contents (step s a) n \<noteq> contents s n \<or>
          contents (step t a) n \<noteq> contents t n"
  then have "check a"
        and "contents (step s a) n = \<E> e s"
        and "contents (step t a) n = \<E> e t"
    by (auto split: if_splits)
  then show "contents (step s a) n = contents (step t a) n"
    using `s \<sim>\<^bsub>dom a\<^esub> t`
    by (auto intro: view_coincidence)
next
  \<comment> \<open>RMA3\<close>
  fix s n fix a :: "('var, 'dom) cmd"
  obtain v d e where [simp]: "a = (v :=\<^bsub>d\<^esub> e)" by (cases a)
  assume "contents (step s a) n \<noteq> contents s n"
  then have "check a" and "v = n" by (auto split: if_splits)
  then show "n \<in> alter (dom a)" by simp
qed

end

end


section \<open>Type Classes for ZFC\<close>

theory ZFC_Typeclasses
  imports ZFC_Cardinals Complex_Main

begin

subsection\<open>The class of embeddable types\<close>

class embeddable =
  assumes ex_inj: "\<exists>V_of :: 'a \<Rightarrow> V. inj V_of"

context countable
begin

subclass embeddable
proof -
  have "inj (ord_of_nat \<circ> to_nat)" if "inj to_nat"
    for to_nat :: "'a \<Rightarrow> nat"
    using that by (simp add: inj_compose inj_ord_of_nat)
  then show "class.embeddable TYPE('a)"
    by intro_classes (meson local.ex_inj)
qed

end

instance unit :: embeddable ..
instance bool :: embeddable ..
instance nat :: embeddable ..
instance int :: embeddable ..
instance rat :: embeddable ..
instance char :: embeddable ..
instance String.literal :: embeddable ..
instance typerep :: embeddable ..

lemma embeddable_classI:
  fixes f :: "'a \<Rightarrow> V"
  assumes "\<And>x y. f x = f y \<Longrightarrow> x = y"
  shows "OFCLASS('a, embeddable_class)"
proof (intro_classes, rule exI)
  show "inj f"
    by (rule injI [OF assms]) assumption
qed

instance V :: embeddable
  by (rule embeddable_classI [where f=id]) auto

instance prod :: (embeddable,embeddable) embeddable
proof -
  have "inj (\<lambda>(x,y). \<langle>V_of1 x, V_of2 y\<rangle>)" if "inj V_of1" "inj V_of2"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V"
    using that by (auto simp: inj_on_def)
  then show "OFCLASS('a \<times> 'b, embeddable_class)"
    by intro_classes (meson embeddable_class.ex_inj)
qed

instance sum :: (embeddable,embeddable) embeddable
proof -
  have "inj (case_sum (Inl \<circ> V_of1) (Inr \<circ> V_of2))" if "inj V_of1" "inj V_of2"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V"
    using that by (auto simp: inj_on_def split: sum.split_asm)
  then show "OFCLASS('a + 'b, embeddable_class)"
    by intro_classes (meson embeddable_class.ex_inj)
qed

instance option :: (embeddable) embeddable
proof -
  have "inj (case_option 0 (\<lambda>x. ZFC_in_HOL.set{V_of x}))" if "inj V_of"
    for V_of :: "'a \<Rightarrow> V"
    using that by (auto simp: inj_on_def split: option.split_asm)
  then show "OFCLASS('a option, embeddable_class)"
    by intro_classes (meson embeddable_class.ex_inj)
qed

primrec V_of_list where
  "V_of_list V_of Nil = 0"
| "V_of_list V_of (x#xs) = \<langle>V_of x, V_of_list V_of xs\<rangle>"

lemma inj_V_of_list:
  assumes "inj V_of"
  shows "inj (V_of_list V_of)"
proof -
  note inj_eq [OF assms, simp]
  have "x = y" if "V_of_list V_of x = V_of_list V_of y" for x y
    using that
  proof (induction x arbitrary: y)
    case Nil
    then show ?case
      by (cases y) auto
  next
    case (Cons a x)
    then show ?case
      by (cases y) auto
  qed
  then show ?thesis
    by (auto simp: inj_on_def)
qed

instance list :: (embeddable) embeddable
proof -
  have "inj (rec_list 0 (\<lambda>x xs r. \<langle>V_of x, r\<rangle>))" (is "inj ?f")
    if V_of: "inj V_of" for V_of :: "'a \<Rightarrow> V"
  proof -
    note inj_eq [OF V_of, simp]
    have "x = y" if "?f x = ?f y" for x y
      using that
    proof (induction x arbitrary: y)
      case Nil
      then show ?case
        by (cases y) auto
    next
      case (Cons a x)
      then show ?case
        by (cases y) auto
    qed
    then show ?thesis
      by (auto simp: inj_on_def)
  qed
  then show "OFCLASS('a list, embeddable_class)"
    by intro_classes (meson embeddable_class.ex_inj)
qed

subsection\<open>The class of small types\<close>

class small =
  assumes small: "small (UNIV::'a set)"
begin

subclass embeddable
  by intro_classes (meson local.small small_def)

lemma TC_small [iff]:
  fixes A :: "'a set"
  shows "small A"
  using small smaller_than_small by blast

end

context countable
begin

subclass small
proof -
  have *: "inj (ord_of_nat \<circ> to_nat)" if "inj to_nat"
    for to_nat :: "'a \<Rightarrow> nat"
    using that by (simp add: inj_compose inj_ord_of_nat)
  then show "class.small TYPE('a)"
    by intro_classes (metis small_image_nat local.ex_inj the_inv_into_onto)
qed

end

lemma lepoll_UNIV_imp_small: "X \<lesssim> (UNIV::'a::small set) \<Longrightarrow> small X"
  by (meson lepoll_iff replacement small smaller_than_small)

lemma lepoll_imp_small:
  fixes A :: "'a::small set"
  assumes "X \<lesssim> A"
  shows "small X"
  by (metis lepoll_UNIV_imp_small UNIV_I assms lepoll_def subsetI)

instance unit :: small ..
instance bool :: small ..
instance nat :: small ..
instance int :: small ..
instance rat :: small ..
instance char :: small ..
instance String.literal :: small ..
instance typerep :: small ..

instance prod :: (small,small) small
proof -
  have "inj (\<lambda>(x,y). \<langle>V_of1 x, V_of2 y\<rangle>)"
       "range (\<lambda>(x,y). \<langle>V_of1 x, V_of2 y\<rangle>) \<le> elts (VSigma A (\<lambda>x. B))"
    if "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A" "range V_of2 \<le> elts B"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A B
    using that by (auto simp: inj_on_def)
  with small [where 'a='a] small [where 'a='b]
  show "OFCLASS('a \<times> 'b, small_class)"
    apply intro_classes
    unfolding small_def
    apply clarify
    by (metis down_raw dual_order.refl)
qed

instance sum :: (small,small) small
proof -
  have "inj (case_sum (Inl \<circ> V_of1) (Inr \<circ> V_of2))"
       "range (case_sum (Inl \<circ> V_of1) (Inr \<circ> V_of2)) \<le> elts (A \<Uplus> B)"
    if "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A" "range V_of2 \<le> elts B"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A B
    using that by (force simp: inj_on_def split: sum.split)+
  with small [where 'a='a] small [where 'a='b]
  show "OFCLASS('a + 'b, small_class)"
    apply intro_classes
    unfolding small_def
    apply clarify
    by (metis down_raw dual_order.refl)
qed

instance option :: (small) small
proof -
  have "inj (\<lambda>x. case x of None \<Rightarrow> 0 | Some x \<Rightarrow> ZFC_in_HOL.set {V_of x})"
       "range (\<lambda>x. case x of None \<Rightarrow> 0 | Some x \<Rightarrow> ZFC_in_HOL.set {V_of x}) \<le> insert 0 (elts (VPow A))"
    if "inj V_of" "range V_of \<le> elts A"
    for V_of :: "'a \<Rightarrow> V" and A
    using that  by (auto simp: inj_on_def split: option.split_asm)
  with small [where 'a='a]
  show "OFCLASS('a option, small_class)"
    apply intro_classes
    unfolding small_def
    apply clarify
    by (metis down_raw elts_vinsert subset_insertI)
qed

instance list :: (small) small
proof -
  have "small (range (V_of_list V_of))"
    if "inj V_of" "range V_of \<le> elts A"
    for V_of :: "'a \<Rightarrow> V" and A
  proof -
    have "range (V_of_list V_of) \<approx> (UNIV :: 'a list set)"
      using that by (simp add: inj_V_of_list)
    also have "\<dots> \<approx> lists (UNIV :: 'a set)"
      by simp
    also have "\<dots> \<lesssim> (UNIV :: 'a set) \<times> (UNIV :: nat set)"
    proof (cases "finite (range (V_of::'a \<Rightarrow> V))")
      case True
      then have "lists (UNIV :: 'a set) \<lesssim> (UNIV :: nat set)"
        using countable_iff_lepoll countable_image_inj_on that(1) uncountable_infinite by blast
      then show ?thesis
        by (blast intro: lepoll_trans [OF _ lepoll_times2])
    next
      case False
      then have "lists (UNIV :: 'a set) \<lesssim> (UNIV :: 'a set)"
        using \<open>infinite (range V_of)\<close> eqpoll_imp_lepoll infinite_eqpoll_lists by blast
      then show ?thesis
        using lepoll_times1 lepoll_trans by fastforce
    qed
    finally show ?thesis
      by (simp add: lepoll_imp_small)
  qed
  with small [where 'a='a]
  show "OFCLASS('a list, small_class)"
    apply intro_classes
    unfolding small_def
    apply clarify
    by (metis inj_V_of_list order_refl small_def small_iff_range)
qed

instance "fun" :: (small,embeddable) embeddable
proof -
  have "inj (\<lambda>f. VLambda A (\<lambda>x. V_of2 (f (inv V_of1 x))))"
    if *: "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A
  proof -
    have "f u = f' u"
      if "VLambda A (\<lambda>u. V_of2 (f (inv V_of1 u))) = VLambda A (\<lambda>x. V_of2 (f' (inv V_of1 x)))"
      for f f' :: "'a \<Rightarrow> 'b" and u
      by (metis inv_f_f rangeI subsetD VLambda_eq_D2 [OF that, of "V_of1 u"] *)
    then show ?thesis
      by (auto simp: inj_on_def)
  qed
  then show "OFCLASS('a \<Rightarrow> 'b, embeddable_class)"
    by intro_classes (metis embeddable_class.ex_inj small order_refl replacement small_iff)
qed

instance "fun" :: (small,small) small
proof -
  have "inj (\<lambda>f. VLambda A (\<lambda>x. V_of2 (f (inv V_of1 x))))"   (is "inj ?\<phi>")
       "range (\<lambda>f. VLambda A (\<lambda>x. V_of2 (f (inv V_of1 x)))) \<le> elts (VPi A (\<lambda>x. B))"
    if *: "inj V_of1" "inj V_of2" "range V_of1 \<le> elts A" and "range V_of2 \<le> elts B"
    for V_of1 :: "'a \<Rightarrow> V" and V_of2 :: "'b \<Rightarrow> V" and A B
  proof -
    have "f u = f' u"
      if "VLambda A (\<lambda>u. V_of2 (f (inv V_of1 u))) = VLambda A (\<lambda>x. V_of2 (f' (inv V_of1 x)))"
      for f f' :: "'a \<Rightarrow> 'b" and u
      by (metis inv_f_f rangeI subsetD VLambda_eq_D2 [OF that, of "V_of1 u"] *)
    then show "inj ?\<phi>"
      by (auto simp: inj_on_def)
    show "range ?\<phi> \<le> elts (VPi A (\<lambda>x. B))"
      using that by (simp add: VPi_I subset_eq)
  qed
  with small [where 'a='a] small [where 'a='b]
  show "OFCLASS('a \<Rightarrow> 'b, small_class)"
    apply intro_classes
    unfolding small_def
    apply clarify
    by (metis down_raw dual_order.refl)
qed

instance set :: (small) small
proof -
  have 1: "inj (\<lambda>x. ZFC_in_HOL.set (V_of ` x))"
    if "inj V_of" for V_of :: "'a \<Rightarrow> V"
    by (simp add: inj_on_def inj_image_eq_iff [OF that])
  have 2: "range (\<lambda>x. ZFC_in_HOL.set (V_of ` x)) \<le> elts (VPow A)"
    if "range V_of \<le> elts A" for V_of :: "'a \<Rightarrow> V" and A
    using that by (auto simp: inj_on_def image_subset_iff)
  from small [where 'a='a]
  show "OFCLASS('a set, small_class)"
    apply intro_classes
    unfolding small_def
    apply clarify
    by (metis 1 2 down_raw subsetI)
qed

instance real :: small
proof -
  have "small (range (Rep_real))"
    by simp
  then show "OFCLASS(real, small_class)"
    by intro_classes (metis Rep_real_inverse image_inv_f_f inj_on_def replacement)
qed

instance complex :: small
proof -
  have "\<And>c. c \<in> range (\<lambda>(x,y). Complex x y)"
    by (metis case_prod_conv complex.exhaust_sel rangeI)
  then show "OFCLASS(complex, small_class)"
    by intro_classes (meson TC_small replacement smaller_than_small subset_eq)
qed

end


(* Author: Alexander Maletzky *)

section \<open>Utilities\<close>

theory Utils
  imports Main Well_Quasi_Orders.Almost_Full_Relations
begin

lemma subset_imageE_inj:
  assumes "B \<subseteq> f ` A"
  obtains C where "C \<subseteq> A" and "B = f ` C" and "inj_on f C"
proof -
  define g where "g = (\<lambda>x. SOME a. a \<in> A \<and> f a = x)"
  have "g b \<in> A \<and> f (g b) = b" if "b \<in> B" for b
  proof -
    from that assms have "b \<in> f ` A" ..
    then obtain a where "a \<in> A" and "b = f a" ..
    hence "a \<in> A \<and> f a = b" by simp
    thus ?thesis unfolding g_def by (rule someI)
  qed
  hence 1: "\<And>b. b \<in> B \<Longrightarrow> g b \<in> A" and 2: "\<And>b. b \<in> B \<Longrightarrow> f (g b) = b" by simp_all
  let ?C = "g ` B"
  show ?thesis
  proof
    show "?C \<subseteq> A" by (auto intro: 1)
  next
    show "B = f ` ?C"
    proof (rule set_eqI)
      fix b
      show "b \<in> B \<longleftrightarrow> b \<in> f ` ?C"
      proof
        assume "b \<in> B"
        moreover from this have "f (g b) = b" by (rule 2)
        ultimately show "b \<in> f ` ?C" by force
      next
        assume "b \<in> f ` ?C"
        then obtain b' where "b' \<in> B" and "b = f (g b')" unfolding image_image ..
        moreover from this(1) have "f (g b') = b'" by (rule 2)
        ultimately show "b \<in> B" by simp
      qed
    qed
  next
    show "inj_on f ?C"
    proof
      fix x y
      assume "x \<in> ?C"
      then obtain bx where "bx \<in> B" and x: "x = g bx" ..
      moreover from this(1) have "f (g bx) = bx" by (rule 2)
      ultimately have *: "f x = bx" by simp
      assume "y \<in> ?C"
      then obtain "by" where "by \<in> B" and y: "y = g by" ..
      moreover from this(1) have "f (g by) = by" by (rule 2)
      ultimately have "f y = by" by simp
      moreover assume "f x = f y"
      ultimately have "bx = by" using * by simp
      thus "x = y" by (simp only: x y)
    qed
  qed
qed

lemma wfP_chain:
  assumes "\<not>(\<exists>f. \<forall>i. r (f (Suc i)) (f i))"
  shows "wfP r"
proof -
  from assms wf_iff_no_infinite_down_chain[of "{(x, y). r x y}"] have "wf {(x, y). r x y}" by auto
  thus "wfP r" unfolding wfP_def .
qed

lemma transp_sequence:
  assumes "transp r" and "\<And>i. r (seq (Suc i)) (seq i)" and "i < j"
  shows "r (seq j) (seq i)"
proof -
  have "\<And>k. r (seq (i + Suc k)) (seq i)"
  proof -
    fix k::nat
    show "r (seq (i + Suc k)) (seq i)"
    proof (induct k)
      case 0
      from assms(2) have "r (seq (Suc i)) (seq i)" .
      thus ?case by simp
    next
      case (Suc k)
      note assms(1)
      moreover from assms(2) have "r (seq (Suc (Suc i + k))) (seq (Suc (i + k)))" by simp
      moreover have "r (seq (Suc (i + k))) (seq i)" using Suc.hyps by simp
      ultimately have "r (seq (Suc (Suc i + k))) (seq i)" by (rule transpD)
      thus ?case by simp
    qed
  qed
  hence "r (seq (i + Suc(j - i - 1))) (seq i)" .
  thus "r (seq j) (seq i)" using \<open>i < j\<close> by simp
qed

lemma almost_full_on_finite_subsetE:
  assumes "reflp P" and "almost_full_on P S"
  obtains T where "finite T" and "T \<subseteq> S" and "\<And>s. s \<in> S \<Longrightarrow> (\<exists>t\<in>T. P t s)"
proof -
  define crit where "crit = (\<lambda>U s. s \<in> S \<and> (\<forall>u\<in>U. \<not> P u s))"
  have critD: "s \<notin> U" if "crit U s" for U s
  proof
    assume "s \<in> U"
    from \<open>crit U s\<close> have "\<forall>u\<in>U. \<not> P u s" unfolding crit_def ..
    from this \<open>s \<in> U\<close> have "\<not> P s s" ..
    moreover from assms(1) have "P s s" by (rule reflpD)
    ultimately show False ..
  qed
  define "fun"
    where "fun = (\<lambda>U. (if (\<exists>s. crit U s) then
                        insert (SOME s. crit U s) U
                      else
                        U
                      ))"
  define seq where "seq = rec_nat {} (\<lambda>_. fun)"
  have seq_Suc: "seq (Suc i) = fun (seq i)" for i by (simp add: seq_def)

  have seq_incr_Suc: "seq i \<subseteq> seq (Suc i)" for i by (auto simp add: seq_Suc fun_def)
  have seq_incr: "i \<le> j \<Longrightarrow> seq i \<subseteq> seq j" for i j
  proof -
    assume "i \<le> j"
    hence "i = j \<or> i < j" by auto
    thus "seq i \<subseteq> seq j"
    proof
      assume "i = j"
      thus ?thesis by simp
    next
      assume "i < j"
      with _ seq_incr_Suc show ?thesis by (rule transp_sequence, simp add: transp_def)
    qed
  qed
  have sub: "seq i \<subseteq> S" for i
  proof (induct i, simp add: seq_def, simp add: seq_Suc fun_def, rule)
    fix i
    assume "Ex (crit (seq i))"
    hence "crit (seq i) (Eps (crit (seq i)))" by (rule someI_ex)
    thus "Eps (crit (seq i)) \<in> S" by (simp add: crit_def)
  qed
  have "\<exists>i. seq (Suc i) = seq i"
  proof (rule ccontr, simp)
    assume "\<forall>i. seq (Suc i) \<noteq> seq i"
    with seq_incr_Suc have "seq i \<subset> seq (Suc i)" for i by blast
    define seq1 where "seq1 = (\<lambda>n. (SOME s. s \<in> seq (Suc n) \<and> s \<notin> seq n))"
    have seq1: "seq1 n \<in> seq (Suc n) \<and> seq1 n \<notin> seq n" for n unfolding seq1_def
    proof (rule someI_ex)
      from \<open>seq n \<subset> seq (Suc n)\<close> show "\<exists>x. x \<in> seq (Suc n) \<and> x \<notin> seq n" by blast
    qed
    have "seq1 i \<in> S" for i
    proof
      from seq1[of i] show "seq1 i \<in> seq (Suc i)" ..
    qed (fact sub)
    with assms(2) obtain a b where "a < b" and "P (seq1 a) (seq1 b)" by (rule almost_full_onD)
    from \<open>a < b\<close> have "Suc a \<le> b" by simp
    from seq1 have "seq1 a \<in> seq (Suc a)" ..
    also from \<open>Suc a \<le> b\<close> have "... \<subseteq> seq b" by (rule seq_incr)
    finally have "seq1 a \<in> seq b" .
    from seq1 have "seq1 b \<in> seq (Suc b)" and "seq1 b \<notin> seq b" by blast+
    hence "crit (seq b) (seq1 b)" by (simp add: seq_Suc fun_def someI split: if_splits)
    hence "\<forall>u\<in>seq b. \<not> P u (seq1 b)" by (simp add: crit_def)
    from this \<open>seq1 a \<in> seq b\<close> have "\<not> P (seq1 a) (seq1 b)" ..
    from this \<open>P (seq1 a) (seq1 b)\<close> show False ..
  qed
  then obtain i where "seq (Suc i) = seq i" ..
  show ?thesis
  proof
    show "finite (seq i)" by (induct i, simp_all add: seq_def fun_def)
  next
    fix s
    assume "s \<in> S"
    let ?s = "Eps (crit (seq i))"
    show "\<exists>t\<in>seq i. P t s"
    proof (rule ccontr, simp)
      assume "\<forall>t\<in>seq i. \<not> P t s"
      with \<open>s \<in> S\<close> have "crit (seq i) s" by (simp only: crit_def)
      hence "crit (seq i) ?s" and eq: "seq (Suc i) = insert ?s (seq i)"
        by (auto simp add: seq_Suc fun_def intro: someI)
      from this(1) have "?s \<notin> seq i" by (rule critD)
      hence "seq (Suc i) \<noteq> seq i" unfolding eq by blast
      from this \<open>seq (Suc i) = seq i\<close> show False ..
    qed
  qed (fact sub)
qed

subsection \<open>Lists\<close>

lemma map_upt: "map (\<lambda>i. f (xs ! i)) [0..<length xs] = map f xs"
  by (auto intro: nth_equalityI)

lemma map_upt_zip:
  assumes "length xs = length ys"
  shows "map (\<lambda>i. f (xs ! i) (ys ! i)) [0..<length ys] = map (\<lambda>(x, y). f x y) (zip xs ys)" (is "?l = ?r")
proof -
  have len_l: "length ?l = length ys" by simp
  from assms have len_r: "length ?r = length ys" by simp
  show ?thesis
  proof (simp only: list_eq_iff_nth_eq len_l len_r, rule, rule, intro allI impI)
    fix i
    assume "i < length ys"
    hence "i < length ?l" and "i < length ?r" by (simp_all only: len_l len_r)
    thus "map (\<lambda>i. f (xs ! i) (ys ! i)) [0..<length ys] ! i = map (\<lambda>(x, y). f x y) (zip xs ys) ! i"
      by simp
  qed
qed

lemma distinct_sorted_wrt_irrefl:
  assumes "irreflp rel" and "transp rel" and "sorted_wrt rel xs"
  shows "distinct xs"
  using assms(3)
proof (induct xs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  from Cons(2) have "sorted_wrt rel xs" and *: "\<forall>y\<in>set xs. rel x y"
    by (simp_all)
  from this(1) have "distinct xs" by (rule Cons(1))
  show ?case
  proof (simp add: \<open>distinct xs\<close>, rule)
    assume "x \<in> set xs"
    with * have "rel x x" ..
    with assms(1) show False by (simp add: irreflp_def)
  qed
qed

lemma distinct_sorted_wrt_imp_sorted_wrt_strict:
  assumes "distinct xs" and "sorted_wrt rel xs"
  shows "sorted_wrt (\<lambda>x y. rel x y \<and> \<not> x = y) xs"
  using assms
proof (induct xs)
  case Nil
  show ?case by simp
next
  case step: (Cons x xs)
  show ?case
  proof (cases "xs")
    case Nil
    thus ?thesis by simp
  next
    case (Cons y zs)
    from step(2) have "x \<noteq> y" and 1: "distinct (y # zs)" by (simp_all add: Cons)
    from step(3) have "rel x y" and 2: "sorted_wrt rel (y # zs)" by (simp_all add: Cons)
    from 1 2 have "sorted_wrt (\<lambda>x y. rel x y \<and> x \<noteq> y) (y # zs)" by (rule step(1)[simplified Cons])
    with \<open>x \<noteq> y\<close> \<open>rel x y\<close> show ?thesis using step.prems by (auto simp: Cons)
  qed
qed

lemma sorted_wrt_distinct_set_unique:
  assumes "antisymp rel"
  assumes "sorted_wrt rel xs" "distinct xs" "sorted_wrt rel ys" "distinct ys" "set xs = set ys"
  shows "xs = ys"
proof -
  from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)
  from assms(2-6) show ?thesis
  proof(induct rule:list_induct2[OF 1])
    case 1
    show ?case by simp
  next
    case (2 x xs y ys)
    from 2(4) have "x \<notin> set xs" and "distinct xs" by simp_all
    from 2(6) have "y \<notin> set ys" and "distinct ys" by simp_all
    have "x = y"
    proof (rule ccontr)
      assume "x \<noteq> y"
      from 2(3) have "\<forall>z\<in>set xs. rel x z" by (simp)
      moreover from \<open>x \<noteq> y\<close> have "y \<in> set xs" using 2(7) by auto
      ultimately have *: "rel x y" ..
      from 2(5) have "\<forall>z\<in>set ys. rel y z" by (simp)
      moreover from \<open>x \<noteq> y\<close> have "x \<in> set ys" using 2(7) by auto
      ultimately have "rel y x" ..
      with assms(1) * have "x = y" by (rule antisympD)
      with \<open>x \<noteq> y\<close> show False ..
    qed
    from 2(3) have "sorted_wrt rel xs" by (simp)
    moreover note \<open>distinct xs\<close>
    moreover from 2(5) have "sorted_wrt rel ys" by (simp)
    moreover note \<open>distinct ys\<close>
    moreover from 2(7) \<open>x \<notin> set xs\<close> \<open>y \<notin> set ys\<close> have "set xs = set ys" by (auto simp add: \<open>x = y\<close>)
    ultimately have "xs = ys" by (rule 2(2))
    with \<open>x = y\<close> show ?case by simp
  qed
qed

lemma sorted_wrt_refl_nth_mono:
  assumes "reflp P" and "sorted_wrt P xs" and "i \<le> j" and "j < length xs"
  shows "P (xs ! i) (xs ! j)"
proof (cases "i < j")
  case True
  from assms(2) this assms(4) show ?thesis by (rule sorted_wrt_nth_less)
next
  case False
  with assms(3) have "i = j" by simp
  from assms(1) show ?thesis unfolding \<open>i = j\<close> by (rule reflpD)
qed

fun merge_wrt :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "merge_wrt _ xs [] = xs"|
  "merge_wrt rel [] ys = ys"|
  "merge_wrt rel (x # xs) (y # ys) =
    (if x = y then
      y # (merge_wrt rel xs ys)
    else if rel x y then
      x # (merge_wrt rel xs (y # ys))
    else
      y # (merge_wrt rel (x # xs) ys)
    )"

lemma set_merge_wrt: "set (merge_wrt rel xs ys) = set xs \<union> set ys"
proof (induct rel xs ys rule: merge_wrt.induct)
  case (1 rel xs)
  show ?case by simp
next
  case (2 rel y ys)
  show ?case by simp
next
  case (3 rel x xs y ys)
  show ?case
  proof (cases "x = y")
    case True
    thus ?thesis by (simp add: 3(1))
  next
    case False
    show ?thesis
    proof (cases "rel x y")
      case True
      with \<open>x \<noteq> y\<close> show ?thesis by (simp add: 3(2) insert_commute)
    next
      case False
      with \<open>x \<noteq> y\<close> show ?thesis by (simp add: 3(3))
    qed
  qed
qed

lemma sorted_merge_wrt:
  assumes "transp rel" and "\<And>x y. x \<noteq> y \<Longrightarrow> rel x y \<or> rel y x"
    and "sorted_wrt rel xs" and "sorted_wrt rel ys"
  shows "sorted_wrt rel (merge_wrt rel xs ys)"
  using assms
proof (induct rel xs ys rule: merge_wrt.induct)
  case (1 rel xs)
  from 1(3) show ?case by simp
next
  case (2 rel y ys)
  from 2(4) show ?case by simp
next
  case (3 rel x xs y ys)
  show ?case
  proof (cases "x = y")
    case True
    show ?thesis
    proof (auto simp add: True)
      fix z
      assume "z \<in> set (merge_wrt rel xs ys)"
      hence "z \<in> set xs \<union> set ys" by (simp only: set_merge_wrt)
      thus "rel y z"
      proof
        assume "z \<in> set xs"
        with 3(6) show ?thesis by (simp add: True)
      next
        assume "z \<in> set ys"
        with 3(7) show ?thesis by (simp)
      qed
    next
      note True 3(4, 5)
      moreover from 3(6) have "sorted_wrt rel xs" by (simp)
      moreover from 3(7) have "sorted_wrt rel ys" by (simp)
      ultimately show "sorted_wrt rel (merge_wrt rel xs ys)" by (rule 3(1))
    qed
  next
    case False
    show ?thesis
    proof (cases "rel x y")
      case True
      show ?thesis
      proof (auto simp add: False True)
        fix z
        assume "z \<in> set (merge_wrt rel xs (y # ys))"
        hence "z \<in> insert y (set xs \<union> set ys)" by (simp add: set_merge_wrt)
        thus "rel x z"
        proof
          assume "z = y"
          with True show ?thesis by simp
        next
          assume "z \<in> set xs \<union> set ys"
          thus ?thesis
          proof
            assume "z \<in> set xs"
            with 3(6) show ?thesis by (simp)
          next
            assume "z \<in> set ys"
            with 3(7) have "rel y z" by (simp)
            with 3(4) True show ?thesis by (rule transpD)
          qed
        qed
      next
        note False True 3(4, 5)
        moreover from 3(6) have "sorted_wrt rel xs" by (simp)
        ultimately show "sorted_wrt rel (merge_wrt rel xs (y # ys))" using 3(7) by (rule 3(2))
      qed
    next
      assume "\<not> rel x y"
      from \<open>x \<noteq> y\<close> have "rel x y \<or> rel y x" by (rule 3(5))
      with \<open>\<not> rel x y\<close> have *: "rel y x" by simp
      show ?thesis
      proof (auto simp add: False \<open>\<not> rel x y\<close>)
        fix z
        assume "z \<in> set (merge_wrt rel (x # xs) ys)"
        hence "z \<in> insert x (set xs \<union> set ys)" by (simp add: set_merge_wrt)
        thus "rel y z"
        proof
          assume "z = x"
          with * show ?thesis by simp
        next
          assume "z \<in> set xs \<union> set ys"
          thus ?thesis
          proof
            assume "z \<in> set xs"
            with 3(6) have "rel x z" by (simp)
            with 3(4) * show ?thesis by (rule transpD)
          next
            assume "z \<in> set ys"
            with 3(7) show ?thesis by (simp)
          qed
        qed
      next
        note False \<open>\<not> rel x y\<close> 3(4, 5, 6)
        moreover from 3(7) have "sorted_wrt rel ys" by (simp)
        ultimately show "sorted_wrt rel (merge_wrt rel (x # xs) ys)" by (rule 3(3))
      qed
    qed
  qed
qed

lemma set_fold:
  assumes "\<And>x ys. set (f (g x) ys) = set (g x) \<union> set ys"
  shows "set (fold (\<lambda>x. f (g x)) xs ys) = (\<Union>x\<in>set xs. set (g x)) \<union> set ys"
proof (induct xs arbitrary: ys)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  have eq: "set (fold (\<lambda>x. f (g x)) xs (f (g x) ys)) = (\<Union>x\<in>set xs. set (g x)) \<union> set (f (g x) ys)"
    by (rule Cons)
  show ?case by (simp add: o_def assms set_merge_wrt eq ac_simps)
qed

subsection \<open>Sums and Products\<close>

lemma additive_implies_homogenous:
  assumes "\<And>x y. f (x + y) = f x + ((f (y::'a::monoid_add))::'b::cancel_comm_monoid_add)"
  shows "f 0 = 0"
proof -
  have "f (0 + 0) = f 0 + f 0" by (rule assms)
  hence "f 0 = f 0 + f 0" by simp
  thus "f 0 = 0" by simp
qed

lemma fun_sum_commute_canc:
  assumes "\<And>x y. f (x + y) = f x + ((f y)::'a::cancel_comm_monoid_add)"
  shows "f (sum g A) = (\<Sum>a\<in>A. f (g a))"
  by (rule fun_sum_commute, rule additive_implies_homogenous, fact+)

lemma fun_sum_list_commute:
  assumes "f 0 = 0" and "\<And>x y. f (x + y) = f x + f y"
  shows "f (sum_list xs) = sum_list (map f xs)"
proof (induct xs)
  case Nil
  thus ?case by (simp add: assms(1))
next
  case (Cons x xs)
  thus ?case by (simp add: assms(2))
qed

lemma fun_sum_list_commute_canc:
  assumes "\<And>x y. f (x + y) = f x + ((f y)::'a::cancel_comm_monoid_add)"
  shows "f (sum_list xs) = sum_list (map f xs)"
  by (rule fun_sum_list_commute, rule additive_implies_homogenous, fact+)

lemma sum_set_upt_eq_sum_list: "(\<Sum>i = m..<n. f i) = (\<Sum>i\<leftarrow>[m..<n]. f i)"
  using sum_set_upt_conv_sum_list_nat by auto

lemma sum_list_upt: "(\<Sum>i\<leftarrow>[0..<(length xs)]. f (xs ! i)) = (\<Sum>x\<leftarrow>xs. f x)"
  by (simp only: map_upt)

lemma sum_list_upt_zip:
  assumes "length xs = length ys"
  shows "(\<Sum>i\<leftarrow>[0..<(length ys)]. f (xs ! i) (ys ! i)) = (\<Sum>(x, y)\<leftarrow>(zip xs ys). f x y)"
  by (simp only: map_upt_zip[OF assms])

lemma sum_list_zeroI:
  assumes "set xs \<subseteq> {0}"
  shows "sum_list xs = 0"
  using assms by (induct xs, auto)

end (* theory *)


section {*FUNCTION\_\_CFG\_TRIM*}
theory
  FUNCTION__CFG_TRIM

imports
  PRJ_12_04_06_05__ENTRY

begin

definition F_CFG_TRIM__SpecInput :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> bool"
  where
    "F_CFG_TRIM__SpecInput G \<equiv>
  valid_cfg G"

definition F_CFG_TRIM__SpecOutput :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> ('nonterminal, 'event) cfg option
  \<Rightarrow> bool"
  where
    "F_CFG_TRIM__SpecOutput Gi Go \<equiv>
  case Go of
    None \<Rightarrow> cfgLM.marked_language Gi = {}
    | Some Go \<Rightarrow>
      valid_cfg Go
      \<and> cfg_sub Go Gi
      \<and> cfgLM.marked_language Go = cfgLM.marked_language Gi
      \<and> cfgLM.initial_marking_derivations Go = cfgLM.initial_marking_derivations Gi
      \<and> cfg_nonterminals Go = cfgLM_language_relevant_nonterminals Gi
      \<and> cfg_nonterminals Go = cfgLM_accessible_nonterminals Go \<inter> cfgSTD_Nonblockingness_nonterminals Go
      \<and> cfg_nonterminals Go = cfgLM_language_relevant_nonterminals Go
      \<and> cfg_productions Go = cfgLM_language_relevant_productions Go
      \<and> cfgLM.marked_language Go \<noteq> {}"

theorem F_CFG_TRIM__SOUND: "
  F_CFG_TRIM__SpecInput G
  \<Longrightarrow> F_CFG_TRIM__SpecOutput G (F_CFG_TRIM G)"
  apply(simp add: F_CFG_TRIM__SpecOutput_def F_CFG_TRIM__SpecInput_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G" in F_CFG_EB__SOUND)
   apply(simp add: F_CFG_EB__SpecInput_def)
  apply(simp add: F_CFG_TRIM_def)
  apply(simp add: F_CFG_EB__SpecOutput_def)
  apply(case_tac "F_CFG_EB G")
   apply(clarsimp)
  apply(clarsimp)
  apply(rename_tac G')
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G'" in SOUND_FUN_CFGLMACX_STD)
   apply(simp add: F_CFG_EASTD__SpecInput_def)
  apply(simp add: F_CFG_EASTD__SpecOutput_def)
  apply(rule conjI)
   apply(rule cfg_sub__trans)
    apply(force)
   apply(force)
  apply(rule conjI)
   prefer 2
   apply(force)
  apply(subgoal_tac "cfgLM_accessible_nonterminals G' \<subseteq> cfg_nonterminals G'")
   prefer 2
   apply(simp add: cfgLM_accessible_nonterminals_def)
   apply(force)
  apply(subgoal_tac "cfgLM_accessible_nonterminals G \<subseteq> cfg_nonterminals G")
   prefer 2
   apply(simp add: cfgLM_accessible_nonterminals_def)
   apply(force)
  apply(subgoal_tac "cfgSTD_Nonblockingness_nonterminals G \<subseteq> cfg_nonterminals G")
   prefer 2
   apply(simp add: cfgSTD_Nonblockingness_nonterminals_def)
   apply(force)
  apply(subgoal_tac "cfgSTD_Nonblockingness_nonterminals G' \<subseteq> cfg_nonterminals G'")
   prefer 2
   apply(simp add: cfgSTD_Nonblockingness_nonterminals_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac ?G2.0="G" in cfg_sub_preserves_cfgLM_accessible_nonterminals)
     prefer 2
     apply(force)
    prefer 2
    apply(force)
   apply(force)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac ?G2.0="G'" in cfg_sub_preserves_cfgLM_accessible_nonterminals)
     prefer 2
     apply(force)
    prefer 2
    apply(force)
   apply(force)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G" in F_CFG_EB__SOUND)
   apply(simp add: F_CFG_EB__SpecInput_def)
  apply(simp add: F_CFG_TRIM_def)
  apply(simp add: F_CFG_EB__SpecOutput_def)
  apply(clarsimp)
  apply(rule_tac t="cfgSTD_Nonblockingness_nonterminals G" and s="cfgSTD_Nonblockingness_nonterminals G'" in ssubst)
   apply(force)
  apply(rule_tac t="cfgLM_language_relevant_nonterminals G" and s="cfgLM_language_relevant_nonterminals G'" in ssubst)
   apply(rule F_CFG_EB_preserves_cfgLM_language_relevant_nonterminals)
       apply(force)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(rule cfgLM_language_relevant_nonterminals_vs_cfgLM_accessible_nonterminals_and_cfgSTD_Nonblockingness_nonterminals_in_cfgSTD_Nonblockingness_nonterminals_grammar)
     apply(force)
    apply(force)
   apply(force)
  apply(force)
  done

lemma cfg_equal_trim_by_cfg_sub_and_equal_marked_language: "
  valid_cfg G1
  \<Longrightarrow> valid_cfg G2
  \<Longrightarrow> cfg_events G1 = cfg_events G2
  \<Longrightarrow> cfg_sub G1 G2
  \<Longrightarrow> cfgLM.marked_language G1 = cfgLM.marked_language G2
  \<Longrightarrow> cfgLM.initial_marking_derivations G2 = cfgLM.initial_marking_derivations G1
  \<Longrightarrow> F_CFG_TRIM G1 = F_CFG_TRIM G2"
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac ?G1.0="G1" and ?G2.0="G2" in cfg_cfgLM_initial_marking_derivations_equal_implies_cfgLM_language_relevant_nonterminals_equal)
     apply(force)
    apply(force)
   apply(force)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac ?G1.0="G1" and ?G2.0="G2" in cfg_cfgLM_initial_marking_derivations_equal_implies_cfgLM_language_relevant_productions_equal)
     apply(force)
    apply(force)
   apply(force)
  apply(thin_tac "cfgLM.initial_marking_derivations G2 = cfgLM.initial_marking_derivations G1")
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G1" in F_CFG_TRIM__SOUND)
   apply(simp add: F_CFG_TRIM__SpecInput_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G2" in F_CFG_TRIM__SOUND)
   apply(simp add: F_CFG_TRIM__SpecInput_def)
  apply(simp add: F_CFG_TRIM__SpecOutput_def)
  apply(case_tac "F_CFG_TRIM G1")
   apply(clarsimp)
   apply(case_tac "F_CFG_TRIM G2")
    apply(clarsimp)
   apply(clarsimp)
  apply(clarsimp)
  apply(case_tac "F_CFG_TRIM G2")
   apply(clarsimp)
  apply(clarsimp)
  apply(rename_tac GX1 GX2)
  apply(subgoal_tac "cfgLM_language_relevant_nonterminals GX2 =
       cfgLM_language_relevant_nonterminals G2")
   prefer 2
   apply(rule_tac t="cfgLM_language_relevant_nonterminals GX2" and s="cfgLM_accessible_nonterminals GX2 \<inter> cfgSTD_Nonblockingness_nonterminals GX2" in ssubst)
    apply (metis cfgLM_language_relevant_nonterminals_vs_cfgLM_accessible_nonterminals_and_cfgSTD_Nonblockingness_nonterminals)
   apply(force)
  apply(subgoal_tac "cfgLM_language_relevant_nonterminals GX1 =
       cfgLM_language_relevant_nonterminals G1")
   prefer 2
   apply(rule_tac t="cfgLM_language_relevant_nonterminals GX1" and s="cfgLM_accessible_nonterminals GX1 \<inter> cfgSTD_Nonblockingness_nonterminals GX1" in ssubst)
    apply (metis cfgLM_language_relevant_nonterminals_vs_cfgLM_accessible_nonterminals_and_cfgSTD_Nonblockingness_nonterminals)
   apply(force)
  apply(subgoal_tac "cfg_events GX1 = cfg_events GX2")
   prefer 2
   apply(simp add: F_CFG_TRIM_def)
   apply(simp add: cfg_sub_def)
   apply(case_tac "F_CFG_EB G1")
    apply(force)
   apply(clarsimp)
   apply(rename_tac GX1)
   apply(case_tac "F_CFG_EB G2")
    apply(force)
   apply(clarsimp)
   apply(rename_tac GX2)
   apply(simp add: F_CFG_EB_def F_CFG_EASTD_def Let_def)
   apply(case_tac "cfg_initial G2 \<in> F_CFG_EB__fp G1 {}")
    prefer 2
    apply(force)
   apply(clarsimp)
   apply(case_tac "cfg_initial G2 \<in> F_CFG_EB__fp G2 {}")
    prefer 2
    apply(force)
   apply(clarsimp)
  apply(thin_tac "X \<noteq> {}" for X)
  apply(thin_tac "cfgLM.marked_language X = Y" for X Y)
  apply(thin_tac "cfgLM.marked_language X = Y" for X Y)
  apply(thin_tac "cfgLM.marked_language X = Y" for X Y)
  apply(thin_tac "F_CFG_TRIM Y = Some X" for X Y)
  apply(thin_tac "F_CFG_TRIM Y = Some X" for X Y)
  apply(subgoal_tac "cfg_nonterminals GX1 = cfg_nonterminals GX2")
   prefer 2
   apply(force)
  apply(subgoal_tac "cfg_productions GX1 = cfg_productions GX2")
   apply(case_tac GX1)
   apply(case_tac GX2)
   apply(simp add: cfg_sub_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac ?G1.0="G1" and ?G2.0="GX1" in cfg_cfgLM_initial_marking_derivations_equal_implies_cfgLM_language_relevant_productions_equal)
     apply(force)
    apply(force)
   apply(force)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac ?G1.0="G2" and ?G2.0="GX2" in cfg_cfgLM_initial_marking_derivations_equal_implies_cfgLM_language_relevant_productions_equal)
     apply(force)
    apply(force)
   apply(force)
  apply(force)
  done

end


section \<open>Shared Utilities for all Generator\<close>

text \<open>In this theory we mainly provide some Isabelle/ML infrastructure
  that is used by several generators. It consists of a uniform interface
  to access all the theorems, terms, etc.\ from the BNF package, and
  some auxiliary functions which provide recursors on datatypes, common tactics, etc.\<close>

theory Generator_Aux
imports
  Main
begin

ML_file "bnf_access.ML"
ML_file "generator_aux.ML"

lemma in_set_simps:
  "x \<in> set (y # z # ys) = (x = y \<or> x \<in> set (z # ys))"
  "x \<in> set ([y]) = (x = y)"
  "x \<in> set [] = False"
  "Ball (set []) P = True"
  "Ball (set [x]) P = P x"
  "Ball (set (x # y # zs)) P = (P x \<and> Ball (set (y # zs)) P)"
  by auto

lemma conj_weak_cong: "a = b \<Longrightarrow> c = d \<Longrightarrow> (a \<and> c) = (b \<and> d)" by auto

lemma refl_True: "(x = x) = True" by simp

end