(*  Title:      HOL/Library/Cardinality.thy
    Author:     Brian Huffman, Andreas Lochbihler
*)

section \<open>Cardinality of types\<close>

theory Cardinality
imports Phantom_Type
begin

subsection \<open>Preliminary lemmas\<close>
(* These should be moved elsewhere *)

lemma (in type_definition) univ:
  "UNIV = Abs ` A"
proof
  show "Abs ` A \<subseteq> UNIV" by (rule subset_UNIV)
  show "UNIV \<subseteq> Abs ` A"
  proof
    fix x :: 'b
    have "x = Abs (Rep x)" by (rule Rep_inverse [symmetric])
    moreover have "Rep x \<in> A" by (rule Rep)
    ultimately show "x \<in> Abs ` A" by (rule image_eqI)
  qed
qed

lemma (in type_definition) card: "card (UNIV :: 'b set) = card A"
  by (simp add: univ card_image inj_on_def Abs_inject)

subsection \<open>Cardinalities of types\<close>

syntax "_type_card" :: "type => nat" ("(1CARD/(1'(_')))")

translations "CARD('t)" => "CONST card (CONST UNIV :: 't set)"

print_translation \<open>
  let
    fun card_univ_tr' ctxt [Const (\<^const_syntax>\<open>UNIV\<close>, Type (_, [T]))] =
      Syntax.const \<^syntax_const>\<open>_type_card\<close> $ Syntax_Phases.term_of_typ ctxt T
  in [(\<^const_syntax>\<open>card\<close>, card_univ_tr')] end
\<close>

lemma card_prod [simp]: "CARD('a \<times> 'b) = CARD('a) * CARD('b)"
  unfolding UNIV_Times_UNIV [symmetric] by (simp only: card_cartesian_product)

lemma card_UNIV_sum: "CARD('a + 'b) = (if CARD('a) \<noteq> 0 \<and> CARD('b) \<noteq> 0 then CARD('a) + CARD('b) else 0)"
unfolding UNIV_Plus_UNIV[symmetric]
by(auto simp add: card_eq_0_iff card_Plus simp del: UNIV_Plus_UNIV)

lemma card_sum [simp]: "CARD('a + 'b) = CARD('a::finite) + CARD('b::finite)"
by(simp add: card_UNIV_sum)

lemma card_UNIV_option: "CARD('a option) = (if CARD('a) = 0 then 0 else CARD('a) + 1)"
proof -
  have "(None :: 'a option) \<notin> range Some" by clarsimp
  thus ?thesis
    by (simp add: UNIV_option_conv card_eq_0_iff finite_range_Some card_image)
qed

lemma card_option [simp]: "CARD('a option) = Suc CARD('a::finite)"
by(simp add: card_UNIV_option)

lemma card_UNIV_set: "CARD('a set) = (if CARD('a) = 0 then 0 else 2 ^ CARD('a))"
by(simp add: card_eq_0_iff card_Pow flip: Pow_UNIV)

lemma card_set [simp]: "CARD('a set) = 2 ^ CARD('a::finite)"
by(simp add: card_UNIV_set)

lemma card_nat [simp]: "CARD(nat) = 0"
  by (simp add: card_eq_0_iff)

lemma card_fun: "CARD('a \<Rightarrow> 'b) = (if CARD('a) \<noteq> 0 \<and> CARD('b) \<noteq> 0 \<or> CARD('b) = 1 then CARD('b) ^ CARD('a) else 0)"
proof -
  {  assume "0 < CARD('a)" and "0 < CARD('b)"
    hence fina: "finite (UNIV :: 'a set)" and finb: "finite (UNIV :: 'b set)"
      by(simp_all only: card_ge_0_finite)
    from finite_distinct_list[OF finb] obtain bs
      where bs: "set bs = (UNIV :: 'b set)" and distb: "distinct bs" by blast
    from finite_distinct_list[OF fina] obtain as
      where as: "set as = (UNIV :: 'a set)" and dista: "distinct as" by blast
    have cb: "CARD('b) = length bs"
      unfolding bs[symmetric] distinct_card[OF distb] ..
    have ca: "CARD('a) = length as"
      unfolding as[symmetric] distinct_card[OF dista] ..
    let ?xs = "map (\<lambda>ys. the \<circ> map_of (zip as ys)) (List.n_lists (length as) bs)"
    have "UNIV = set ?xs"
    proof(rule UNIV_eq_I)
      fix f :: "'a \<Rightarrow> 'b"
      from as have "f = the \<circ> map_of (zip as (map f as))"
        by(auto simp add: map_of_zip_map)
      thus "f \<in> set ?xs" using bs by(auto simp add: set_n_lists)
    qed
    moreover have "distinct ?xs" unfolding distinct_map
    proof(intro conjI distinct_n_lists distb inj_onI)
      fix xs ys :: "'b list"
      assume xs: "xs \<in> set (List.n_lists (length as) bs)"
        and ys: "ys \<in> set (List.n_lists (length as) bs)"
        and eq: "the \<circ> map_of (zip as xs) = the \<circ> map_of (zip as ys)"
      from xs ys have [simp]: "length xs = length as" "length ys = length as"
        by(simp_all add: length_n_lists_elem)
      have "map_of (zip as xs) = map_of (zip as ys)"
      proof
        fix x
        from as bs have "\<exists>y. map_of (zip as xs) x = Some y" "\<exists>y. map_of (zip as ys) x = Some y"
          by(simp_all add: map_of_zip_is_Some[symmetric])
        with eq show "map_of (zip as xs) x = map_of (zip as ys) x"
          by(auto dest: fun_cong[where x=x])
      qed
      with dista show "xs = ys" by(simp add: map_of_zip_inject)
    qed
    hence "card (set ?xs) = length ?xs" by(simp only: distinct_card)
    moreover have "length ?xs = length bs ^ length as" by(simp add: length_n_lists)
    ultimately have "CARD('a \<Rightarrow> 'b) = CARD('b) ^ CARD('a)" using cb ca by simp }
  moreover {
    assume cb: "CARD('b) = 1"
    then obtain b where b: "UNIV = {b :: 'b}" by(auto simp add: card_Suc_eq)
    have eq: "UNIV = {\<lambda>x :: 'a. b ::'b}"
    proof(rule UNIV_eq_I)
      fix x :: "'a \<Rightarrow> 'b"
      { fix y
        have "x y \<in> UNIV" ..
        hence "x y = b" unfolding b by simp }
      thus "x \<in> {\<lambda>x. b}" by(auto)
    qed
    have "CARD('a \<Rightarrow> 'b) = 1" unfolding eq by simp }
  ultimately show ?thesis
    by(auto simp del: One_nat_def)(auto simp add: card_eq_0_iff dest: finite_fun_UNIVD2 finite_fun_UNIVD1)
qed

corollary finite_UNIV_fun:
  "finite (UNIV :: ('a \<Rightarrow> 'b) set) \<longleftrightarrow>
   finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set) \<or> CARD('b) = 1"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  have "?lhs \<longleftrightarrow> CARD('a \<Rightarrow> 'b) > 0" by(simp add: card_gt_0_iff)
  also have "\<dots> \<longleftrightarrow> CARD('a) > 0 \<and> CARD('b) > 0 \<or> CARD('b) = 1"
    by(simp add: card_fun)
  also have "\<dots> = ?rhs" by(simp add: card_gt_0_iff)
  finally show ?thesis .
qed

lemma card_literal: "CARD(String.literal) = 0"
by(simp add: card_eq_0_iff infinite_literal)

subsection \<open>Classes with at least 1 and 2\<close>

text \<open>Class finite already captures "at least 1"\<close>

lemma zero_less_card_finite [simp]: "0 < CARD('a::finite)"
  unfolding neq0_conv [symmetric] by simp

lemma one_le_card_finite [simp]: "Suc 0 \<le> CARD('a::finite)"
  by (simp add: less_Suc_eq_le [symmetric])

class CARD_1 =
  assumes CARD_1: "CARD ('a) = 1"
begin

subclass finite
proof
  from CARD_1 show "finite (UNIV :: 'a set)"
    using finite_UNIV_fun by fastforce
qed

end

text \<open>Class for cardinality "at least 2"\<close>

class card2 = finite +
  assumes two_le_card: "2 \<le> CARD('a)"

lemma one_less_card: "Suc 0 < CARD('a::card2)"
  using two_le_card [where 'a='a] by simp

lemma one_less_int_card: "1 < int CARD('a::card2)"
  using one_less_card [where 'a='a] by simp

subsection \<open>A type class for deciding finiteness of types\<close>

type_synonym 'a finite_UNIV = "('a, bool) phantom"

class finite_UNIV =
  fixes finite_UNIV :: "('a, bool) phantom"
  assumes finite_UNIV: "finite_UNIV = Phantom('a) (finite (UNIV :: 'a set))"

lemma finite_UNIV_code [code_unfold]:
  "finite (UNIV :: 'a :: finite_UNIV set)
  \<longleftrightarrow> of_phantom (finite_UNIV :: 'a finite_UNIV)"
by(simp add: finite_UNIV)

subsection \<open>A type class for computing the cardinality of types\<close>

definition is_list_UNIV :: "'a list \<Rightarrow> bool"
where "is_list_UNIV xs = (let c = CARD('a) in if c = 0 then False else size (remdups xs) = c)"

lemma is_list_UNIV_iff: "is_list_UNIV xs \<longleftrightarrow> set xs = UNIV"
by(auto simp add: is_list_UNIV_def Let_def card_eq_0_iff List.card_set[symmetric]
   dest: subst[where P="finite", OF _ finite_set] card_eq_UNIV_imp_eq_UNIV)

type_synonym 'a card_UNIV = "('a, nat) phantom"

class card_UNIV = finite_UNIV +
  fixes card_UNIV :: "'a card_UNIV"
  assumes card_UNIV: "card_UNIV = Phantom('a) CARD('a)"

subsection \<open>Instantiations for \<open>card_UNIV\<close>\<close>

instantiation nat :: card_UNIV begin
definition "finite_UNIV = Phantom(nat) False"
definition "card_UNIV = Phantom(nat) 0"
instance by intro_classes (simp_all add: finite_UNIV_nat_def card_UNIV_nat_def)
end

instantiation int :: card_UNIV begin
definition "finite_UNIV = Phantom(int) False"
definition "card_UNIV = Phantom(int) 0"
instance by intro_classes (simp_all add: card_UNIV_int_def finite_UNIV_int_def)
end

instantiation natural :: card_UNIV begin
definition "finite_UNIV = Phantom(natural) False"
definition "card_UNIV = Phantom(natural) 0"
instance
  by standard
    (auto simp add: finite_UNIV_natural_def card_UNIV_natural_def card_eq_0_iff
      type_definition.univ [OF type_definition_natural] natural_eq_iff
      dest!: finite_imageD intro: inj_onI)
end

instantiation integer :: card_UNIV begin
definition "finite_UNIV = Phantom(integer) False"
definition "card_UNIV = Phantom(integer) 0"
instance
  by standard
    (auto simp add: finite_UNIV_integer_def card_UNIV_integer_def card_eq_0_iff
      type_definition.univ [OF type_definition_integer]
      dest!: finite_imageD intro: inj_onI)
end

instantiation list :: (type) card_UNIV begin
definition "finite_UNIV = Phantom('a list) False"
definition "card_UNIV = Phantom('a list) 0"
instance by intro_classes (simp_all add: card_UNIV_list_def finite_UNIV_list_def infinite_UNIV_listI)
end

instantiation unit :: card_UNIV begin
definition "finite_UNIV = Phantom(unit) True"
definition "card_UNIV = Phantom(unit) 1"
instance by intro_classes (simp_all add: card_UNIV_unit_def finite_UNIV_unit_def)
end

instantiation bool :: card_UNIV begin
definition "finite_UNIV = Phantom(bool) True"
definition "card_UNIV = Phantom(bool) 2"
instance by(intro_classes)(simp_all add: card_UNIV_bool_def finite_UNIV_bool_def)
end

instantiation char :: card_UNIV begin
definition "finite_UNIV = Phantom(char) True"
definition "card_UNIV = Phantom(char) 256"
instance by intro_classes (simp_all add: card_UNIV_char_def card_UNIV_char finite_UNIV_char_def)
end

instantiation prod :: (finite_UNIV, finite_UNIV) finite_UNIV begin
definition "finite_UNIV = Phantom('a \<times> 'b)
  (of_phantom (finite_UNIV :: 'a finite_UNIV) \<and> of_phantom (finite_UNIV :: 'b finite_UNIV))"
instance by intro_classes (simp add: finite_UNIV_prod_def finite_UNIV finite_prod)
end

instantiation prod :: (card_UNIV, card_UNIV) card_UNIV begin
definition "card_UNIV = Phantom('a \<times> 'b)
  (of_phantom (card_UNIV :: 'a card_UNIV) * of_phantom (card_UNIV :: 'b card_UNIV))"
instance by intro_classes (simp add: card_UNIV_prod_def card_UNIV)
end

instantiation sum :: (finite_UNIV, finite_UNIV) finite_UNIV begin
definition "finite_UNIV = Phantom('a + 'b)
  (of_phantom (finite_UNIV :: 'a finite_UNIV) \<and> of_phantom (finite_UNIV :: 'b finite_UNIV))"
instance
  by intro_classes (simp add: finite_UNIV_sum_def finite_UNIV)
end

instantiation sum :: (card_UNIV, card_UNIV) card_UNIV begin
definition "card_UNIV = Phantom('a + 'b)
  (let ca = of_phantom (card_UNIV :: 'a card_UNIV);
       cb = of_phantom (card_UNIV :: 'b card_UNIV)
   in if ca \<noteq> 0 \<and> cb \<noteq> 0 then ca + cb else 0)"
instance by intro_classes (auto simp add: card_UNIV_sum_def card_UNIV card_UNIV_sum)
end

instantiation "fun" :: (finite_UNIV, card_UNIV) finite_UNIV begin
definition "finite_UNIV = Phantom('a \<Rightarrow> 'b)
  (let cb = of_phantom (card_UNIV :: 'b card_UNIV)
   in cb = 1 \<or> of_phantom (finite_UNIV :: 'a finite_UNIV) \<and> cb \<noteq> 0)"
instance
  by intro_classes (auto simp add: finite_UNIV_fun_def Let_def card_UNIV finite_UNIV finite_UNIV_fun card_gt_0_iff)
end

instantiation "fun" :: (card_UNIV, card_UNIV) card_UNIV begin
definition "card_UNIV = Phantom('a \<Rightarrow> 'b)
  (let ca = of_phantom (card_UNIV :: 'a card_UNIV);
       cb = of_phantom (card_UNIV :: 'b card_UNIV)
   in if ca \<noteq> 0 \<and> cb \<noteq> 0 \<or> cb = 1 then cb ^ ca else 0)"
instance by intro_classes (simp add: card_UNIV_fun_def card_UNIV Let_def card_fun)
end

instantiation option :: (finite_UNIV) finite_UNIV begin
definition "finite_UNIV = Phantom('a option) (of_phantom (finite_UNIV :: 'a finite_UNIV))"
instance by intro_classes (simp add: finite_UNIV_option_def finite_UNIV)
end

instantiation option :: (card_UNIV) card_UNIV begin
definition "card_UNIV = Phantom('a option)
  (let c = of_phantom (card_UNIV :: 'a card_UNIV) in if c \<noteq> 0 then Suc c else 0)"
instance by intro_classes (simp add: card_UNIV_option_def card_UNIV card_UNIV_option)
end

instantiation String.literal :: card_UNIV begin
definition "finite_UNIV = Phantom(String.literal) False"
definition "card_UNIV = Phantom(String.literal) 0"
instance
  by intro_classes (simp_all add: card_UNIV_literal_def finite_UNIV_literal_def infinite_literal card_literal)
end

instantiation set :: (finite_UNIV) finite_UNIV begin
definition "finite_UNIV = Phantom('a set) (of_phantom (finite_UNIV :: 'a finite_UNIV))"
instance by intro_classes (simp add: finite_UNIV_set_def finite_UNIV Finite_Set.finite_set)
end

instantiation set :: (card_UNIV) card_UNIV begin
definition "card_UNIV = Phantom('a set)
  (let c = of_phantom (card_UNIV :: 'a card_UNIV) in if c = 0 then 0 else 2 ^ c)"
instance by intro_classes (simp add: card_UNIV_set_def card_UNIV_set card_UNIV)
end

lemma UNIV_finite_1: "UNIV = set [finite_1.a\<^sub>1]"
by(auto intro: finite_1.exhaust)

lemma UNIV_finite_2: "UNIV = set [finite_2.a\<^sub>1, finite_2.a\<^sub>2]"
by(auto intro: finite_2.exhaust)

lemma UNIV_finite_3: "UNIV = set [finite_3.a\<^sub>1, finite_3.a\<^sub>2, finite_3.a\<^sub>3]"
by(auto intro: finite_3.exhaust)

lemma UNIV_finite_4: "UNIV = set [finite_4.a\<^sub>1, finite_4.a\<^sub>2, finite_4.a\<^sub>3, finite_4.a\<^sub>4]"
by(auto intro: finite_4.exhaust)

lemma UNIV_finite_5:
  "UNIV = set [finite_5.a\<^sub>1, finite_5.a\<^sub>2, finite_5.a\<^sub>3, finite_5.a\<^sub>4, finite_5.a\<^sub>5]"
by(auto intro: finite_5.exhaust)

instantiation Enum.finite_1 :: card_UNIV begin
definition "finite_UNIV = Phantom(Enum.finite_1) True"
definition "card_UNIV = Phantom(Enum.finite_1) 1"
instance
  by intro_classes (simp_all add: UNIV_finite_1 card_UNIV_finite_1_def finite_UNIV_finite_1_def)
end

instantiation Enum.finite_2 :: card_UNIV begin
definition "finite_UNIV = Phantom(Enum.finite_2) True"
definition "card_UNIV = Phantom(Enum.finite_2) 2"
instance
  by intro_classes (simp_all add: UNIV_finite_2 card_UNIV_finite_2_def finite_UNIV_finite_2_def)
end

instantiation Enum.finite_3 :: card_UNIV begin
definition "finite_UNIV = Phantom(Enum.finite_3) True"
definition "card_UNIV = Phantom(Enum.finite_3) 3"
instance
  by intro_classes (simp_all add: UNIV_finite_3 card_UNIV_finite_3_def finite_UNIV_finite_3_def)
end

instantiation Enum.finite_4 :: card_UNIV begin
definition "finite_UNIV = Phantom(Enum.finite_4) True"
definition "card_UNIV = Phantom(Enum.finite_4) 4"
instance
  by intro_classes (simp_all add: UNIV_finite_4 card_UNIV_finite_4_def finite_UNIV_finite_4_def)
end

instantiation Enum.finite_5 :: card_UNIV begin
definition "finite_UNIV = Phantom(Enum.finite_5) True"
definition "card_UNIV = Phantom(Enum.finite_5) 5"
instance
  by intro_classes (simp_all add: UNIV_finite_5 card_UNIV_finite_5_def finite_UNIV_finite_5_def)
end

end


section\<open>Tangles: Definition as a type and basic functions on tangles\<close>
theory Tangles
imports Preliminaries
begin

(* Time to split the file: Links and Tangles in another file*)

text\<open>well-defined wall as a type called diagram. The morphisms Abs\_diagram maps a well defined wall to
its diagram type and Rep\_diagram maps the diagram back to the wall\<close>

typedef Tangle_Diagram = "{(x::wall). is_tangle_diagram x}"
 by (rule_tac x = "prod (cup#[]) (basic (cap#[]))" in exI) (auto)

typedef Link_Diagram = "{(x::wall). is_link_diagram x}"
 by (rule_tac x = "prod (cup#[]) (basic (cap#[]))" in exI) (auto simp
 add:is_link_diagram_def abs_def)

text\<open>The next few lemmas list the properties of well defined diagrams\<close>

text\<open>For a well defined diagram, the morphism Rep\_diagram acts as an inverse of Abs\_diagram
the morphism which maps a well defined wall to its representative in the type diagram\<close>

lemma Abs_Rep_well_defined:
 assumes " is_tangle_diagram x"
 shows "Rep_Tangle_Diagram (Abs_Tangle_Diagram x) = x"
 using Rep_Tangle_Diagram Abs_Tangle_Diagram_inverse assms mem_Collect_eq  by auto

text\<open>The map Abs\_diagram is injective\<close>
lemma Rep_Abs_well_defined:
 assumes "is_tangle_diagram x"
     and "is_tangle_diagram y"
     and  "(Abs_Tangle_Diagram x) = (Abs_Tangle_Diagram y)"
 shows "x = y"
 using Rep_Tangle_Diagram Abs_Tangle_Diagram_inverse assms mem_Collect_eq
 by metis

text\<open>restating the property of well-defined wall in terms of diagram\<close>

text\<open>In order to locally defined moves, it helps to prove that if composition of two wall is a
well defined wall then the number of outgoing strands of the wall below are equal to the number of
incoming strands of the wall above. The following lemmas prove that for a well defined wall, t
he number of incoming and outgoing strands are zero\<close>

(*is-tangle-compose*)
lemma is_tangle_left_compose:
 "is_tangle_diagram (x \<circ> y) \<Longrightarrow> is_tangle_diagram x"
proof (induct x)
 case (basic z)
  have "is_tangle_diagram (basic z)" using is_tangle_diagram.simps(1)  by auto
  then show ?case using basic by auto
 next
 case (prod z zs)
  have "(z*zs)\<circ>y = (z*(zs \<circ> y))" by auto
  then have " is_tangle_diagram (z*(zs\<circ>y))" using prod by auto
  moreover then have 1: "is_tangle_diagram zs"
        using is_tangle_diagram.simps(2) prod.hyps prod.prems  by metis
  ultimately have "domain_wall (zs \<circ> y) = codomain_block z"
        by (metis is_tangle_diagram.simps(2))
  moreover have "domain_wall (zs \<circ> y) = domain_wall zs"
        using domain_wall_def domain_wall_compose by auto
  ultimately have "domain_wall zs = codomain_block z" by auto
  then have "is_tangle_diagram (z*zs)"
        by (metis "1" is_tangle_diagram.simps(2))
  then show ?case by auto
qed

lemma is_tangle_right_compose:
 "is_tangle_diagram (x \<circ> y) \<Longrightarrow> is_tangle_diagram y"
proof (induct x)
 case (basic z)
  have "(basic z) \<circ> y = (z*y) " using basic  by auto
  then have "is_tangle_diagram y"
         unfolding is_tangle_diagram.simps(2) using basic.prems by (metis is_tangle_diagram.simps(2))
  then show ?case using basic.prems by auto
 next
 case (prod z zs)
  have "((z*zs) \<circ> y) = (z *(zs \<circ> y))" by auto
  then have "is_tangle_diagram (z*(zs \<circ> y))" using prod by auto
  then have "is_tangle_diagram (zs \<circ> y)" using is_tangle_diagram.simps(2) by metis
  then have "is_tangle_diagram y"  using prod.hyps by auto
  then show ?case by auto
qed

(*tangle diagrams using composition*)

lemma comp_of_tangle_dgms:
 assumes"is_tangle_diagram y"
 shows "((is_tangle_diagram x)
         \<and>(codomain_wall x = domain_wall y))
              \<Longrightarrow> is_tangle_diagram (x \<circ> y)"
proof(induct x)
 case (basic z)
  have "codomain_block z = codomain_wall (basic z)"
      using domain_wall_def by auto
  moreover have "(basic z)\<circ>y= z*y"
      using compose_def by auto
  ultimately have "codomain_block z = domain_wall y"
      using basic.prems by auto
  moreover have "is_tangle_diagram y"
      using assms by auto
  ultimately have "is_tangle_diagram (z*y)"
      unfolding is_tangle_diagram_def by auto
   then show ?case by auto
 next
 case (prod z zs)
  have "is_tangle_diagram (z*zs)"
       using prod.prems by metis
  then have "codomain_block z = domain_wall zs"
      using is_tangle_diagram.simps(2) prod.prems  by metis
  then have "codomain_block z = domain_wall (zs \<circ> y)"
      using domain_wall.simps domain_wall_compose by auto
  moreover have "is_tangle_diagram (zs \<circ> y)"
      using prod.hyps by (metis codomain_wall.simps(2) is_tangle_diagram.simps(2) prod.prems)
  ultimately have "is_tangle_diagram (z*(zs \<circ> y))"
     unfolding is_tangle_diagram_def by auto
  then show ?case by auto
qed

lemma composition_of_tangle_diagrams:
 assumes "is_tangle_diagram x"
     and "is_tangle_diagram y"
     and "(domain_wall y = codomain_wall x)"
 shows "is_tangle_diagram (x \<circ> y)"
 using comp_of_tangle_dgms using assms by auto

lemma converse_composition_of_tangle_diagrams:
  "is_tangle_diagram (x \<circ> y) \<Longrightarrow> (domain_wall y) = (codomain_wall x)"
proof(induct x)
 case (basic z)
  have "(basic z) \<circ> y = z * y"
      using compose_def basic by auto
  then have
    "is_tangle_diagram ((basic z) \<circ> y) \<Longrightarrow>
              (is_tangle_diagram y)\<and> (codomain_block z = domain_wall y)"
     using is_tangle_diagram.simps(2)  by (metis)
  then have "(codomain_block z) = (domain_wall y)"
      using basic.prems by auto
  moreover have "codomain_wall (basic z) = codomain_block z"
      using domain_wall_compose by auto
  ultimately have "(codomain_wall (basic z)) = (domain_wall y)"
      by auto
  then show ?case by simp
 next
 case (prod z zs)
  have "codomain_wall zs = domain_wall y"
          using prod.hyps prod.prems
          by (metis compose_Nil compose_leftassociativity is_tangle_right_compose)
  moreover have "codomain_wall zs = codomain_wall (z*zs)"
          using domain_wall_compose by auto
  ultimately show ?case by metis
qed

(*defining compose for diagrams*)

definition compose_Tangle::"Tangle_Diagram \<Rightarrow> Tangle_Diagram \<Rightarrow> Tangle_Diagram"
                                                                     (infixl "\<circ>" 65)
 where
"compose_Tangle x y = Abs_Tangle_Diagram
                                  ((Rep_Tangle_Diagram x) \<circ> (Rep_Tangle_Diagram y))"

theorem well_defined_compose:
 assumes "is_tangle_diagram x"
     and "is_tangle_diagram y"
     and "domain_wall x = codomain_wall y"
 shows "(Abs_Tangle_Diagram x) \<circ> (Abs_Tangle_Diagram y)
                          = (Abs_Tangle_Diagram (x \<circ> y))"
 using  Abs_Tangle_Diagram_inverse assms(1) assms(2) compose_Tangle_def
        mem_Collect_eq
 by auto

(*defining domain and co-domain of tangles*)
definition domain_Tangle::"Tangle_Diagram \<Rightarrow> int"
where
"domain_Tangle x = domain_wall(Rep_Tangle_Diagram x)"

definition codomain_Tangle::"Tangle_Diagram \<Rightarrow> int"
where
"codomain_Tangle x = codomain_wall(Rep_Tangle_Diagram x)"

end


theory HOML imports Main  (*C. Benzmüller, 2021*)
begin
(*unimportant*) declare [[smt_solver=cvc4,smt_oracle]]
(*unimportant*) declare[[syntax_ambiguity_warning=false]]
(*unimportant*) nitpick_params[user_axioms,card=2]
(*Type declarations and type abbreviations*)
typedecl i (*Possible worlds*)
typedecl e (*Individuals*)
type_synonym \<sigma> = "i\<Rightarrow>bool" (*World-lifted propositions*)
type_synonym \<gamma> = "e\<Rightarrow>\<sigma>" (*Lifted predicates*)
type_synonym \<mu> = "\<sigma>\<Rightarrow>\<sigma>" (*Unary modal connectives*)
type_synonym \<nu> = "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (*Binary modal connectives*)

(*Modal logic connectives (operating on truth-sets)*)
abbreviation c1::\<sigma> ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation c2::\<sigma> ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation c3::\<mu> ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w.\<not>(\<phi> w)"
abbreviation c4::\<nu> (infix"\<^bold>\<and>"50) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<and>(\<psi> w)"
abbreviation c5::\<nu> (infix"\<^bold>\<or>"49) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<or>(\<psi> w)"
abbreviation c6::\<nu> (infix"\<^bold>\<rightarrow>"48) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<longrightarrow>(\<psi> w)"
abbreviation c7::\<nu> (infix"\<^bold>\<leftrightarrow>"47) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<longleftrightarrow>(\<psi> w)"
consts R::"i\<Rightarrow>i\<Rightarrow>bool" ("_\<^bold>r_")  (*Accessibility relation*)
abbreviation c8::\<mu> ("\<^bold>\<box>_"[54]55) where "\<^bold>\<box>\<phi> \<equiv> \<lambda>w.\<forall>v.(w\<^bold>rv)\<longrightarrow>(\<phi> v)"
abbreviation c9::\<mu> ("\<^bold>\<diamond>_"[54]55) where "\<^bold>\<diamond>\<phi> \<equiv> \<lambda>w.\<exists>v.(w\<^bold>rv)\<and>(\<phi> v)"
abbreviation c10::"\<gamma>\<Rightarrow>\<gamma>" ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<Phi> \<equiv> \<lambda>x.\<lambda>w.\<not>(\<Phi> x w)"
abbreviation c11::"e\<Rightarrow>e\<Rightarrow>\<sigma>" ("_\<^bold>=_") where "x\<^bold>=y \<equiv> \<lambda>w.(x=y)"
abbreviation c12::"e\<Rightarrow>e\<Rightarrow>\<sigma>" ("_\<^bold>\<noteq>_") where "x\<^bold>\<noteq>y \<equiv> \<lambda>w.(x\<noteq>y)"

(*Polymorphic possibilist quantification*)
abbreviation q1::"('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x.(\<Phi> x w)"
abbreviation q2 (binder"\<^bold>\<forall>"[10]11) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation q3::"('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x.(\<Phi> x w)"
abbreviation q4 (binder"\<^bold>\<exists>"[10]11) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

(*Actualist quantification for individuals*)
consts existsAt::\<gamma> ("_\<^bold>@_")
abbreviation q5::"\<gamma>\<Rightarrow>\<sigma>" ("\<^bold>\<forall>\<^sup>E") where "\<^bold>\<forall>\<^sup>E\<Phi> \<equiv> \<lambda>w.\<forall>x.(x\<^bold>@w)\<longrightarrow>(\<Phi> x w)"
abbreviation q6 (binder"\<^bold>\<forall>\<^sup>E"[8]9) where "\<^bold>\<forall>\<^sup>Ex. \<phi>(x) \<equiv> \<^bold>\<forall>\<^sup>E\<phi>"
abbreviation q7::"\<gamma>\<Rightarrow>\<sigma>" ("\<^bold>\<exists>\<^sup>E") where "\<^bold>\<exists>\<^sup>E\<Phi> \<equiv> \<lambda>w.\<exists>x.(x\<^bold>@w)\<and>(\<Phi> x w)"
abbreviation q8 (binder"\<^bold>\<exists>\<^sup>E"[8]9) where "\<^bold>\<exists>\<^sup>Ex. \<phi>(x) \<equiv> \<^bold>\<exists>\<^sup>E\<phi>"

(*Meta-logical predicate for global validity*)
abbreviation g1::"\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>") where "\<lfloor>\<psi>\<rfloor> \<equiv>  \<forall>w. \<psi> w"
end

(*
(*Consistency, Barcan and converse Barcan formula*)
lemma True nitpick[satisfy] oops  (*Model found by Nitpick*)
lemma "\<lfloor>(\<^bold>\<forall>\<^sup>Ex.\<^bold>\<box>(\<phi> x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ex.(\<phi> x))\<rfloor>" nitpick oops (*Ctm*)
lemma "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>\<^sup>Ex.(\<phi> x)) \<^bold>\<rightarrow> (\<^bold>\<forall>\<^sup>Ex.\<^bold>\<box>(\<phi> x))\<rfloor>" nitpick oops (*Ctm*)
lemma "\<lfloor>(\<^bold>\<forall>x.\<^bold>\<box>(\<phi> x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. \<phi> x)\<rfloor>" by simp
lemma "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>x.(\<phi> x)) \<^bold>\<rightarrow> (\<^bold>\<forall>x.\<^bold>\<box>(\<phi> x))\<rfloor>" by simp
end
*)


(* Title:      Domain
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Domain\<close>

theory Domain

imports Stone_Relation_Algebras.Semirings Tests

begin

context idempotent_left_semiring
begin

sublocale ils: il_semiring where inf = times and sup = sup and bot = bot and less_eq = less_eq and less = less and top = 1
  apply unfold_locales
  apply (simp add: sup_assoc)
  apply (simp add: sup_commute)
  apply simp
  apply simp
  apply (simp add: mult_assoc)
  apply (simp add: mult_right_dist_sup)
  apply simp
  apply simp
  apply simp
  apply (simp add: mult_right_isotone)
  apply (simp add: le_iff_sup)
  by (simp add: less_le_not_le)

end

class left_zero_domain_semiring = idempotent_left_zero_semiring + dom +
  assumes d_restrict: "x \<squnion> d(x) * x = d(x) * x"
  assumes d_mult_d  : "d(x * y) = d(x * d(y))"
  assumes d_plus_one: "d(x) \<squnion> 1 = 1"
  assumes d_zero    : "d(bot) = bot"
  assumes d_dist_sup: "d(x \<squnion> y) = d(x) \<squnion> d(y)"
begin

text \<open>Many lemmas in this class are taken from Georg Struth's theories.\<close>

lemma d_restrict_equals:
  "x = d(x) * x"
  by (metis sup_commute d_plus_one d_restrict mult_left_one mult_right_dist_sup)

lemma d_involutive:
  "d(d(x)) = d(x)"
  by (metis d_mult_d mult_left_one)

lemma d_fixpoint:
  "(\<exists>y . x = d(y)) \<longleftrightarrow> x = d(x)"
  using d_involutive by auto

lemma d_type:
  "\<forall>P . (\<forall>x . x = d(x) \<longrightarrow> P(x)) \<longleftrightarrow> (\<forall>x . P(d(x)))"
  by (metis d_involutive)

lemma d_mult_sub:
  "d(x * y) \<le> d(x)"
  by (metis d_dist_sup d_mult_d d_plus_one le_iff_sup mult_left_sub_dist_sup_left mult_1_right)

lemma d_sub_one:
  "x \<le> 1 \<Longrightarrow> x \<le> d(x)"
  by (metis d_restrict_equals mult_right_isotone mult_1_right)

lemma d_strict:
  "d(x) = bot \<longleftrightarrow> x = bot"
  by (metis d_restrict_equals d_zero mult_left_zero)

lemma d_one:
  "d(1) = 1"
  by (metis d_restrict_equals mult_1_right)

lemma d_below_one:
  "d(x) \<le> 1"
  by (simp add: d_plus_one le_iff_sup)

lemma d_isotone:
  "x \<le> y \<Longrightarrow> d(x) \<le> d(y)"
  by (metis d_dist_sup le_iff_sup)

lemma d_plus_left_upper_bound:
  "d(x) \<le> d(x \<squnion> y)"
  by (simp add: d_isotone)

lemma d_export:
  "d(d(x) * y) = d(x) * d(y)"
  apply (rule order.antisym)
  apply (metis d_below_one d_involutive d_mult_sub d_restrict_equals d_isotone d_mult_d mult_isotone mult_left_one)
  by (metis d_below_one d_sub_one coreflexive_mult_closed d_mult_d)

lemma d_idempotent:
  "d(x) * d(x) = d(x)"
  by (metis d_export d_restrict_equals)

lemma d_commutative:
  "d(x) * d(y) = d(y) * d(x)"
  by (metis ils.il_inf_associative order.antisym d_export d_mult_d d_mult_sub d_one d_restrict_equals mult_isotone mult_left_one)

lemma d_least_left_preserver:
  "x \<le> d(y) * x \<longleftrightarrow> d(x) \<le> d(y)"
  by (metis d_below_one d_involutive d_mult_sub d_restrict_equals order.eq_iff mult_left_isotone mult_left_one)

lemma d_weak_locality:
  "x * y = bot \<longleftrightarrow> x * d(y) = bot"
  by (metis d_mult_d d_strict)

lemma d_sup_closed:
  "d(d(x) \<squnion> d(y)) = d(x) \<squnion> d(y)"
  by (simp add: d_involutive d_dist_sup)

lemma d_mult_closed:
  "d(d(x) * d(y)) = d(x) * d(y)"
  using d_export d_mult_d by auto

lemma d_mult_left_lower_bound:
  "d(x) * d(y) \<le> d(x)"
  by (metis d_export d_involutive d_mult_sub)

lemma d_mult_greatest_lower_bound:
  "d(x) \<le> d(y) * d(z) \<longleftrightarrow> d(x) \<le> d(y) \<and> d(x) \<le> d(z)"
  by (metis d_commutative d_idempotent d_mult_left_lower_bound mult_isotone order_trans)

lemma d_mult_left_absorb_sup:
  "d(x) * (d(x) \<squnion> d(y)) = d(x)"
  by (metis sup_commute d_idempotent d_plus_one mult_left_dist_sup mult_1_right)

lemma d_sup_left_absorb_mult:
  "d(x) \<squnion> d(x) * d(y) = d(x)"
  using d_mult_left_lower_bound sup.absorb_iff1 by auto

lemma d_sup_left_dist_mult:
  "d(x) \<squnion> d(y) * d(z) = (d(x) \<squnion> d(y)) * (d(x) \<squnion> d(z))"
  by (smt sup_assoc d_commutative d_idempotent d_mult_left_absorb_sup mult_left_dist_sup mult_right_dist_sup)

lemma d_order:
  "d(x) \<le> d(y) \<longleftrightarrow> d(x) = d(x) * d(y)"
  by (metis d_mult_greatest_lower_bound d_mult_left_absorb_sup le_iff_sup order_refl)

lemma d_mult_below:
  "d(x) * y \<le> y"
  by (metis sup_left_divisibility d_plus_one mult_left_one mult_right_dist_sup)

lemma d_preserves_equation:
  "d(y) * x \<le> x * d(y) \<longleftrightarrow> d(y) * x = d(y) * x * d(y)"
  by (simp add: d_below_one d_idempotent test_preserves_equation)

end

class left_zero_antidomain_semiring = idempotent_left_zero_semiring + dom + uminus +
  assumes a_restrict   : "-x * x = bot"
  assumes a_plus_mult_d: "-(x * y) \<squnion> -(x * --y) = -(x * --y)"
  assumes a_complement : "--x \<squnion> -x = 1"
  assumes d_def        : "d(x) = --x"
begin

sublocale aa: a_algebra where minus = "\<lambda>x y . -(-x \<squnion> y)" and uminus = uminus and inf = times and sup = sup and bot = bot and less_eq = less_eq and less = less and top = 1
  apply unfold_locales
  apply (simp add: a_restrict)
  using a_complement sup_commute apply fastforce
  apply (simp add: a_plus_mult_d le_iff_sup)
  by simp

subclass left_zero_domain_semiring
  apply unfold_locales
  apply (simp add: d_def aa.double_complement_above)
  apply (simp add: aa.a_d.d3_eq d_def)
  apply (simp add: d_def)
  apply (simp add: d_def)
  by (simp add: d_def aa.l15)

subclass tests
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (simp add: aa.sba_dual.sub_commutative)
  apply (simp add: aa.sba_dual.sub_complement)
  using aa.sba_dual.sub_sup_closed apply simp
  apply simp
  apply simp
  apply (simp add: aa.sba_dual.sub_inf_def)
  apply (simp add: aa.less_eq_inf)
  by (simp add: less_le_not_le)

text \<open>Many lemmas in this class are taken from Georg Struth's theories.\<close>

notation
  uminus ("a")

lemma a_greatest_left_absorber:
  "a(x) * y = bot \<longleftrightarrow> a(x) \<le> a(y)"
  by (simp add: aa.l10_iff)

lemma a_mult_d:
  "a(x * y) = a(x * d(y))"
  by (simp add: d_def aa.sba3_complement_inf_double_complement)

lemma a_d_closed:
  "d(a(x)) = a(x)"
  by (simp add: d_def)

lemma a_plus_left_lower_bound:
  "a(x \<squnion> y) \<le> a(x)"
  by (simp add: aa.l9)

lemma a_mult_sup:
  "a(x) * (y \<squnion> x) = a(x) * y"
  by (simp add: aa.sba3_inf_complement_bot semiring.distrib_left)

lemma a_3:
  "a(x) * a(y) * d(x \<squnion> y) = bot"
  using d_weak_locality aa.l12 aa.sba3_inf_complement_bot by force

lemma a_export:
  "a(a(x) * y) = d(x) \<squnion> a(y)"
  using a_mult_d d_def aa.sba_dual.sub_inf_def by auto

lemma a_fixpoint:
  "\<forall>x . (a(x) = x \<longrightarrow> (\<forall>y . y = bot))"
  by (metis aa.a_d.d_fully_strict aa.sba2_bot_unit aa.sup_idempotent aa.sup_right_zero_var)

lemma a_strict:
  "a(x) = 1 \<longleftrightarrow> x = bot"
  using aa.a_d.d_fully_strict one_def by fastforce

lemma d_complement_zero:
  "d(x) * a(x) = bot"
  by (simp add: aa.sba3_inf_complement_bot d_def)

lemma a_complement_zero:
  "a(x) * d(x) = bot"
  by (simp add: d_def)

lemma a_shunting_zero:
  "a(x) * d(y) = bot \<longleftrightarrow> a(x) \<le> a(y)"
  by (simp add: aa.less_eq_inf_bot d_def)

lemma a_antitone:
  "x \<le> y \<Longrightarrow> a(y) \<le> a(x)"
  by (simp add: aa.l9)

lemma a_mult_deMorgan:
  "a(a(x) * a(y)) = d(x \<squnion> y)"
  by (simp add: aa.sup_demorgan d_def)

lemma a_mult_deMorgan_1:
  "a(a(x) * a(y)) = d(x) \<squnion> d(y)"
  by (simp add: a_export d_def)

lemma a_mult_deMorgan_2:
  "a(d(x) * d(y)) = a(x) \<squnion> a(y)"
  by (simp add: d_def sup_def)

lemma a_plus_deMorgan:
  "a(a(x) \<squnion> a(y)) = d(x) * d(y)"
  by (simp add: aa.sub_sup_demorgan d_def)

lemma a_plus_deMorgan_1:
  "a(d(x) \<squnion> d(y)) = a(x) * a(y)"
  by (simp add: aa.sup_demorgan d_def)

lemma a_mult_left_upper_bound:
  "a(x) \<le> a(x * y)"
  using aa.l5 d_def d_mult_sub by auto

lemma d_a_closed:
  "a(d(x)) = a(x)"
  by (simp add: d_def)

lemma a_export_d:
  "a(d(x) * y) = a(x) \<squnion> a(y)"
  using a_mult_d a_mult_deMorgan_2 by auto

lemma a_7:
  "d(x) * a(d(y) \<squnion> d(z)) = d(x) * a(y) * a(z)"
  by (simp add: a_plus_deMorgan_1 mult_assoc)

lemma d_a_shunting:
  "d(x) * a(y) \<le> d(z) \<longleftrightarrow> d(x) \<le> d(z) \<squnion> d(y)"
  using aa.sba_dual.shunting_right d_def by auto

lemma d_d_shunting:
  "d(x) * d(y) \<le> d(z) \<longleftrightarrow> d(x) \<le> d(z) \<squnion> a(y)"
  using d_a_shunting d_def by auto

lemma d_cancellation_1:
  "d(x) \<le> d(y) \<squnion> (d(x) * a(y))"
  by (metis a_d_closed aa.sba2_export aa.sup_demorgan d_def eq_refl le_supE sup_commute)

lemma d_cancellation_2:
  "(d(z) \<squnion> d(y)) * a(y) \<le> d(z)"
  by (metis d_a_shunting d_dist_sup eq_refl)

lemma a_sup_closed:
  "d(a(x) \<squnion> a(y)) = a(x) \<squnion> a(y)"
  using aa.sub_sup_closed d_def by auto

lemma a_mult_closed:
  "d(a(x) * a(y)) = a(x) * a(y)"
  using a_d_closed aa.l12 by auto

lemma d_a_shunting_zero:
  "d(x) * a(y) = bot \<longleftrightarrow> d(x) \<le> d(y)"
  by (simp add: aa.l10_iff d_def)

lemma d_d_shunting_zero:
  "d(x) * d(y) = bot \<longleftrightarrow> d(x) \<le> a(y)"
  by (simp add: aa.l10_iff d_def)

lemma d_compl_intro:
  "d(x) \<squnion> d(y) = d(x) \<squnion> a(x) * d(y)"
  by (simp add: aa.sup_complement_intro d_def)

lemma a_compl_intro:
  "a(x) \<squnion> a(y) = a(x) \<squnion> d(x) * a(y)"
  by (simp add: aa.sup_complement_intro d_def)

lemma kat_2:
  "y * a(z) \<le> a(x) * y \<Longrightarrow> d(x) * y * a(z) = bot"
  by (smt a_export a_plus_left_lower_bound le_sup_iff d_d_shunting_zero d_export d_strict le_iff_sup mult_assoc)

lemma kat_3:
  "d(x) * y * a(z) = bot \<Longrightarrow> d(x) * y = d(x) * y * d(z)"
  by (metis a_export_d aa.complement_bot d_complement_zero d_def mult_1_right mult_left_dist_sup sup_bot_left)

lemma kat_4:
  "d(x) * y = d(x) * y * d(z) \<Longrightarrow> d(x) * y \<le> y * d(z)"
  using d_mult_below mult_assoc by auto

lemma kat_2_equiv:
  "y * a(z) \<le> a(x) * y \<longleftrightarrow> d(x) * y * a(z) = bot"
  apply (rule iffI)
  apply (simp add: kat_2)
  by (metis aa.top_greatest a_complement sup_bot_left d_def mult_left_one mult_right_dist_sup mult_right_isotone mult_1_right)

lemma kat_4_equiv:
  "d(x) * y = d(x) * y * d(z) \<longleftrightarrow> d(x) * y \<le> y * d(z)"
  apply (rule iffI)
  apply (simp add: kat_4)
  apply (rule order.antisym)
  apply (metis d_idempotent le_iff_sup mult_assoc mult_left_dist_sup)
  by (metis d_plus_one le_iff_sup mult_left_dist_sup mult_1_right)

lemma kat_3_equiv_opp:
  "a(z) * y * d(x) = bot \<longleftrightarrow> y * d(x) = d(z) * y * d(x)"
  by (metis a_complement a_restrict sup_bot_left d_a_closed d_def mult_assoc mult_left_one mult_left_zero mult_right_dist_sup)

lemma kat_4_equiv_opp:
  "y * d(x) = d(z) * y * d(x) \<longleftrightarrow> y * d(x) \<le> d(z) * y"
  using kat_2_equiv kat_3_equiv_opp d_def by auto

lemma d_restrict_iff:
  "(x \<le> y) \<longleftrightarrow> (x \<le> d(x) * y)"
  by (metis d_mult_below d_restrict_equals mult_isotone order_lesseq_imp)

lemma d_restrict_iff_1:
  "(d(x) * y \<le> z) \<longleftrightarrow> (d(x) * y \<le> d(x) * z)"
  by (metis sup_commute d_export d_mult_left_lower_bound d_plus_one d_restrict_iff mult_left_isotone mult_left_one mult_right_sub_dist_sup_right order_trans)

end

end


section {*I\_cfg\_base*}
theory
  I_cfg_base

imports
  PRJ_09__PRE

begin

record ('nonterminal, 'event) cfg_step_label =
  prod_lhs :: "'nonterminal"
  prod_rhs :: "('nonterminal, 'event) DT_two_elements list"

record ('nonterminal, 'event) cfg =
  cfg_nonterminals :: "'nonterminal set"
  cfg_events :: "'event set"
  cfg_initial :: "'nonterminal"
  cfg_productions :: "('nonterminal, 'event) cfg_step_label set"

definition valid_cfg_step_label :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> ('nonterminal, 'event) cfg_step_label
  \<Rightarrow> bool"
  where
    "valid_cfg_step_label G e \<equiv>
  prod_lhs e \<in> cfg_nonterminals G
  \<and> setA (prod_rhs e) \<subseteq> cfg_nonterminals G
  \<and> setB (prod_rhs e) \<subseteq> cfg_events G"
declare valid_cfg_step_label_def [simp add]

definition valid_cfg :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> bool"
  where
    "valid_cfg G \<equiv>
  finite (cfg_events G)
  \<and> finite (cfg_nonterminals G)
  \<and> cfg_initial G \<in> cfg_nonterminals G
  \<and> finite (cfg_productions G)
  \<and> (\<forall>e \<in> cfg_productions G. valid_cfg_step_label G e)"

record ('nonterminal, 'event) cfg_configuration =
  cfg_conf :: "('nonterminal, 'event) DT_two_elements list"

definition cfg_configurations :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> ('nonterminal, 'event) cfg_configuration set"
  where
    "cfg_configurations G \<equiv>
  {\<lparr>cfg_conf = c\<rparr> |c.
  setA c \<subseteq> cfg_nonterminals G
  \<and> setB c \<subseteq> cfg_events G}"

definition cfg_initial_configurations :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> ('nonterminal, 'event) cfg_configuration set"
  where
    "cfg_initial_configurations G \<equiv>
  {\<lparr>cfg_conf = [teA (cfg_initial G)]\<rparr>}
  \<inter> cfg_configurations G"

definition cfg_marking_configuration :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> ('nonterminal, 'event) cfg_configuration set"
  where
    "cfg_marking_configuration G \<equiv>
  {c. setA (cfg_conf c) = {}}
  \<inter> cfg_configurations G"

definition cfg_marking_condition :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> (('nonterminal, 'event)cfg_step_label, ('nonterminal, 'event)cfg_configuration)derivation
  \<Rightarrow> bool"
  where
    "cfg_marking_condition G d \<equiv>
  \<exists>i e c.
    d i = Some (pair e c)
    \<and> c \<in> cfg_marking_configuration G"

definition cfg_step_labels :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> ('nonterminal, 'event) cfg_step_label set"
  where
    "cfg_step_labels G \<equiv>
  cfg_productions G"

definition cfg_effects :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> 'event list set" where
  "cfg_effects G \<equiv>
  {w. set w \<subseteq> cfg_events G}"

definition cfg_marked_effect :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> (('nonterminal, 'event)cfg_step_label, ('nonterminal, 'event)cfg_configuration)derivation
  \<Rightarrow> 'event list set"
  where
    "cfg_marked_effect G d \<equiv>
  {w. \<exists>e c i.
      d i = Some (pair e c)
      \<and> setA (cfg_conf c) = {}
      \<and> liftB w = cfg_conf c}"

definition cfg_marked_effect_ALT :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> (('nonterminal, 'event)cfg_step_label, ('nonterminal, 'event)cfg_configuration)derivation
  \<Rightarrow> 'event list set"
  where
    "cfg_marked_effect_ALT G d \<equiv>
  {w. \<exists>e c i.
      d i = Some (pair e c)
      \<and> liftB w = cfg_conf c}"

lemma cfg_marked_effect_ALT_vs_cfg_marked_effect: "
  cfg_marked_effect_ALT G d = cfg_marked_effect G d"
  apply(simp add: cfg_marked_effect_ALT_def cfg_marked_effect_def)
  apply(rule antisym)
   prefer 2
   apply(force)
  apply(clarsimp)
  apply(rename_tac x e c i)(*strict*)
  apply(rule_tac
      x="e"
      in exI)
  apply(rule_tac
      x="c"
      in exI)
  apply(clarsimp)
  apply(rule conjI)
   apply(rename_tac x e c i)(*strict*)
   apply(force)
  apply(rename_tac x e c i)(*strict*)
  apply(case_tac c)
  apply(rename_tac x e c i cfg_confa)(*strict*)
  apply(clarsimp)
  apply(rename_tac x e i)(*strict*)
  apply (metis setA_liftB_empty)
  done

definition cfg_unmarked_effect :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> (('nonterminal, 'event) cfg_step_label, ('nonterminal, 'event) cfg_configuration) derivation
  \<Rightarrow> 'event list set" where
  "cfg_unmarked_effect G d \<equiv>
  {w. \<exists>e c i.
      d i = Some (pair e c)
      \<and> (\<exists>z. liftB w @ z = cfg_conf c)}"

datatype ('nonterminal, 'event) cfg_destination =
  dest_nonterminal "'nonterminal"
  | dest_production "('nonterminal, 'event)cfg_step_label"

definition cfg_destination :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> ('nonterminal, 'event) cfg_destination set"
  where
    "cfg_destination G \<equiv>
  dest_nonterminal ` cfg_nonterminals G
  \<union> dest_production ` cfg_productions G"

definition cfg_get_destinations :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> (('nonterminal, 'event)cfg_step_label, ('nonterminal, 'event)cfg_configuration)derivation_configuration
  \<Rightarrow> ('nonterminal, 'event) cfg_destination set"
  where
    "cfg_get_destinations G der_conf \<equiv>
  case der_conf of pair e c \<Rightarrow>
    dest_nonterminal ` setA (cfg_conf c)
    \<union> (case e of None \<Rightarrow> {} | Some e' \<Rightarrow> {dest_production e'})"

definition valid_right_regular_grammar :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> bool"
  where
    "valid_right_regular_grammar G \<equiv>
  valid_cfg G
  \<and> (\<forall>e \<in> cfg_productions G. \<exists>\<alpha> A.
      prod_rhs e = liftB \<alpha> @ [teA A]
      \<or> prod_rhs e = liftB \<alpha>)"

definition valid_left_regular_grammar :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> bool"
  where
    "valid_left_regular_grammar G \<equiv>
  valid_cfg G
  \<and> (\<forall>e \<in> cfg_productions G. \<exists>\<alpha> A.
      prod_rhs e = [teA A] @ liftB \<alpha>
      \<or> prod_rhs e = liftB \<alpha>)"

definition cfg_marked_configuration_effect :: "
  ('nonterminal, 'event)cfg
  \<Rightarrow> ('nonterminal, 'event)cfg_configuration
  \<Rightarrow> 'event list set"
  where
    "cfg_marked_configuration_effect G c \<equiv>
  {w. cfg_conf c = liftB w}"

definition cfg_unmarked_configuration_effect :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> ('nonterminal, 'event)cfg_configuration
  \<Rightarrow> 'event list set"
  where
    "cfg_unmarked_configuration_effect G c =
  {w. \<exists>w'. cfg_conf c = liftB w @ w'}"

definition cfg_get_history :: "
  ('nonterminal, 'event) cfg_configuration
  \<Rightarrow> 'event list"
  where
    "cfg_get_history c \<equiv>
  maxTermPrefix (cfg_conf c)"

lemma cfgBASE_inst_AX_initial_configuration_belongs: "
  (\<forall>X. cfg_initial_configurations X \<subseteq> cfg_configurations X)"
  apply(simp add: cfg_initial_configurations_def cfg_configurations_def)
  done

lemma cfgBASE_inst_AX_effect_inclusion1: "
  (\<forall>M f. cfg_marking_condition M f \<longrightarrow> cfg_marked_effect M f \<subseteq> cfg_unmarked_effect M f)"
  apply(rule allI)+
  apply(rename_tac M f)(*strict*)
  apply(simp add: cfg_marked_effect_def cfg_unmarked_effect_def)
  apply(clarsimp)
  apply(rename_tac M f x e c i)(*strict*)
  apply(rule_tac
      x="e"
      in exI)
  apply(rule_tac
      x="c"
      in exI)
  apply(rule conjI)
   apply(rename_tac M f x e c i)(*strict*)
   apply(rule_tac
      x="i"
      in exI)
   apply(clarsimp)
  apply(rename_tac M f x e c i)(*strict*)
  apply(case_tac c)
  apply(rename_tac M f x e c i cfg_confa)(*strict*)
  apply(clarsimp)
  done

definition empty_cfg :: "
  'nonterminal
  \<Rightarrow> 'event set
  \<Rightarrow> ('nonterminal, 'event) cfg"
  where
    "empty_cfg S A \<equiv>
  \<lparr>cfg_nonterminals = {S},
    cfg_events = A,
    cfg_initial = S,
    cfg_productions = {}\<rparr>"

definition cfg_has_production :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> bool"
  where
    "cfg_has_production G \<equiv>
  cfg_productions G \<noteq> {}"

definition cfg_every_nonterminal_on_some_left_hand_side :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> bool"
  where
    "cfg_every_nonterminal_on_some_left_hand_side G \<equiv>
  \<forall>A \<in> cfg_nonterminals G.
  \<exists>e \<in> cfg_productions G.
  prod_lhs e = A"

definition cfg_sub :: "
  ('nonterminal, 'event) cfg
  \<Rightarrow> ('nonterminal, 'event) cfg
  \<Rightarrow> bool"
  where
    "cfg_sub G1 G2 \<equiv>
  cfg_events G1 \<subseteq> cfg_events G2
  \<and> cfg_nonterminals G1 \<subseteq> cfg_nonterminals G2
  \<and> cfg_productions G1 \<subseteq> cfg_productions G2
  \<and> cfg_initial G1 = cfg_initial G2"

lemma cfg_initial_in_nonterms: "
  valid_cfg G
  \<Longrightarrow> cfg_initial G \<in> cfg_nonterminals G"
  apply(simp add: valid_cfg_def)
  done

lemma prod_rhs_in_nonterms: "
  valid_cfg G
  \<Longrightarrow> \<lparr>prod_lhs = a, prod_rhs = w\<rparr> \<in> cfg_productions G
  \<Longrightarrow> setA w \<subseteq> cfg_nonterminals G"
  apply(simp add: valid_cfg_def)
  apply(auto)
  apply(rename_tac x)(*strict*)
  apply(erule_tac
      x = "\<lparr>prod_lhs = a, prod_rhs = w\<rparr>"
      in ballE)
   apply(rename_tac x)(*strict*)
   apply(auto)
  done

lemma prod_rhs_in_cfg_events: "
  valid_cfg G
  \<Longrightarrow> \<lparr>prod_lhs = a, prod_rhs = w\<rparr> \<in> cfg_productions G
  \<Longrightarrow> setB w \<subseteq> cfg_events G"
  apply(simp add: valid_cfg_def)
  apply(auto)
  apply(rename_tac x)(*strict*)
  apply(erule_tac
      x = "\<lparr>prod_lhs = a, prod_rhs = w\<rparr>"
      in ballE)
   apply(rename_tac x)(*strict*)
   apply(auto)
  done

lemma prod_lhs_in_nonterms: "
  valid_cfg G
  \<Longrightarrow> \<lparr>prod_lhs = a, prod_rhs = w\<rparr> \<in> cfg_productions G
  \<Longrightarrow> a \<in> cfg_nonterminals G"
  apply(simp add: valid_cfg_def)
  apply(auto)
  done

lemma cfg_sub_inherits_cfg_events: "
  cfg_sub G1 G2
  \<Longrightarrow> cfg_events G1 \<subseteq> cfg_events G2"
  apply(simp add: cfg_sub_def)
  done

lemma only_terminals_in_postfix_closure: "
  valid_cfg G
  \<Longrightarrow> e \<in> cfg_productions G
  \<Longrightarrow> teB b # w \<in> suffixes (prod_rhs e)
  \<Longrightarrow> b \<in> cfg_events G"
  apply(subgoal_tac "\<exists>x. x @ (Cons (teB b) w) = prod_rhs e")
   defer
   apply(rule suffixes_intro2_rev)
   apply(blast)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: valid_cfg_def)
  apply(clarsimp)
  apply(erule_tac
      x = "e"
      in ballE)
   apply(rename_tac x)(*strict*)
   defer
   apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      A="setB (x @ teB b # w)"
      in set_mp)
   apply(rename_tac x)(*strict*)
   apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(rule setB_selects_sound1)
  done

lemma prod_rhs_in_cfg_events2: "
  valid_cfg G
  \<Longrightarrow> \<lparr>prod_lhs = a, prod_rhs = w\<rparr> \<in> cfg_productions G
  \<Longrightarrow> setB w \<subseteq> cfg_events G"
  apply(simp add: valid_cfg_def)
  apply(auto)
  apply(rename_tac x)(*strict*)
  apply(erule_tac
      x = "\<lparr>prod_lhs = a, prod_rhs = w\<rparr>"
      in ballE)
   apply(rename_tac x)(*strict*)
   apply(auto)
  done

lemma CFGprod_lhs_in_nonterms: "
  valid_cfg G
  \<Longrightarrow> p \<in> cfg_productions G
  \<Longrightarrow> x=prod_lhs p
  \<Longrightarrow> x\<in> cfg_nonterminals G"
  apply(simp add: valid_cfg_def)
  done

lemma cfg_insert_symbol: "
  valid_cfg G
  \<Longrightarrow> valid_cfg (G\<lparr>cfg_events:=cfg_events G \<union> {a}\<rparr>)"
  apply(simp add: valid_cfg_def)
  apply(auto)
  done

lemma prod_lhs_in_nonterms2: "
  valid_cfg G
  \<Longrightarrow> p \<in> cfg_productions G
  \<Longrightarrow> prod_lhs p = x
  \<Longrightarrow> x \<in> cfg_nonterminals G"
  apply(simp add: valid_cfg_def)
  apply(clarsimp)
  done

lemma cfg_has_nonempty_two_elements_construct_domain: "
  valid_cfg G
  \<Longrightarrow> two_elements_construct_domain (cfg_nonterminals G) (cfg_events G) = {}
  \<Longrightarrow> P"
  apply(simp add: valid_cfg_def)
  apply(simp add: two_elements_construct_domain_def)
  done

lemma cfg_prod_in_two_elements_construct_domain_subset_trans: "
  valid_cfg G
  \<Longrightarrow> \<lparr>prod_lhs=x, prod_rhs=W\<rparr> \<in> cfg_productions G
  \<Longrightarrow> two_elements_construct_domain (cfg_nonterminals G) (cfg_events G) \<subseteq> A
  \<Longrightarrow> set W \<subseteq> A"
  apply(simp add: valid_cfg_def)
  apply(erule conjE)+
  apply(rule_tac
      B="two_elements_construct_domain (cfg_nonterminals G) (cfg_events G)"
      in subset_trans)
   apply(erule_tac
      x="\<lparr>prod_lhs = x, prod_rhs = W\<rparr>"
      in ballE)
    apply(rule SetxBiElem_check_vs_set_two_elements_construct_domain_check)
     apply(force)
    apply(force)
   apply(force)
  apply(force)
  done

lemma cfg_prod_in_two_elements_construct_domain_subset_trans2: "
  valid_cfg G
  \<Longrightarrow> \<lparr>prod_lhs=x, prod_rhs=W\<rparr> \<in> cfg_productions G
  \<Longrightarrow> two_elements_construct_domain (cfg_nonterminals G) (cfg_events G) \<subseteq> A
  \<Longrightarrow> teA x \<in> A"
  apply(subgoal_tac "set[teA x]\<subseteq> A")
   apply(force)
  apply(simp only: valid_cfg_def)
  apply(erule conjE)+
  apply(rule_tac
      B="two_elements_construct_domain (cfg_nonterminals G) (cfg_events G)"
      in subset_trans)
   apply(erule_tac
      x="\<lparr>prod_lhs = x, prod_rhs = W\<rparr>"
      in ballE)
    apply(rule SetxBiElem_check_vs_set_two_elements_construct_domain_check)
     apply(force)
    apply(force)
   apply(force)
  apply(force)
  done

lemma cfg_unmarked_effect_one_position_derivation: "
  cfg_unmarked_effect M (\<lambda>n. if n = 0 then Some (pair None c) else None) = prefix_closure{maxTermPrefix (cfg_conf c)}"
  apply(rule order_antisym)
   apply(clarsimp)
   apply(rename_tac x)(*strict*)
   apply(simp add: cfg_unmarked_effect_def prefix_closure_def prefix_def)
   apply(clarsimp)
   apply(rename_tac x e ca i z)(*strict*)
   apply(case_tac i)
    apply(rename_tac x e ca i z)(*strict*)
    apply(clarsimp)
    apply(rename_tac x z)(*strict*)
    prefer 2
    apply(rename_tac x e ca i z nat)(*strict*)
    apply(clarsimp)
   apply(rename_tac x z)(*strict*)
   apply(rule_tac
      t="cfg_conf c"
      and s="liftB x @ z"
      in ssubst)
    apply(rename_tac x z)(*strict*)
    apply(force)
   apply(rename_tac x z)(*strict*)
   apply(rule_tac
      t="maxTermPrefix (liftB x @ z)"
      and s="x@maxTermPrefix z"
      in ssubst)
    apply(rename_tac x z)(*strict*)
    apply(rule maxTermPrefix_shift)
   apply(rename_tac x z)(*strict*)
   apply(force)
  apply(simp add: cfg_unmarked_effect_def prefix_closure_def prefix_def)
  apply(clarsimp)
  apply(rename_tac x ca)(*strict*)
  apply(case_tac c)
  apply(rename_tac x ca cfg_confa)(*strict*)
  apply(clarsimp)
  apply(rename_tac x c cfg_conf)(*strict*)
  apply(subgoal_tac "\<exists>w1 w2. liftB w1 @ w2 = cfg_conf \<and> (case w2 of teB b#list \<Rightarrow> False | _ \<Rightarrow> True)")
   apply(rename_tac x c cfg_conf)(*strict*)
   prefer 2
   apply(rule maxSplit)
  apply(rename_tac x c cfg_conf)(*strict*)
  apply(clarsimp)
  apply(rename_tac x c w1 w2)(*strict*)
  apply(subgoal_tac "x@c=w1")
   apply(rename_tac x c w1 w2)(*strict*)
   prefer 2
   apply(rule_tac
      t="w1"
      and s="maxTermPrefix (liftB w1 @ w2)"
      in subst)
    apply(rename_tac x c w1 w2)(*strict*)
    apply(rule maxTermPrefix_on_maxSplit)
    apply(force)
   apply(rename_tac x c w1 w2)(*strict*)
   apply(force)
  apply(rename_tac x c w1 w2)(*strict*)
  apply(clarsimp)
  apply(rename_tac x c w2)(*strict*)
  apply(rule_tac
      t="liftB (x @ c)"
      and s="liftB x@liftB c"
      in ssubst)
   apply(rename_tac x c w2)(*strict*)
   apply(rule liftB_commutes_over_concat)
  apply(rename_tac x c w2)(*strict*)
  apply(force)
  done

lemma cfgSTD_inst_AX_unmarked_effect_persists: "
  \<forall>M d n. cfg_unmarked_effect M (derivation_take d n) \<subseteq> cfg_unmarked_effect M d"
  apply(clarsimp)
  apply(rename_tac M d n x)(*strict*)
  apply(simp add: cfg_unmarked_effect_def)
  apply(rename_tac d n x)(*strict*)
  apply(simp add: derivation_take_def)
  apply(clarsimp)
  apply(rename_tac d n x e c i z)(*strict*)
  apply(case_tac "i\<le>n")
   apply(rename_tac d n x e c i z)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      x="e"
      in exI)
   apply(rule_tac
      x="c"
      in exI)
   apply(rule conjI)
    apply(rename_tac d n x e c i z)(*strict*)
    apply(rule_tac
      x="i"
      in exI)
    apply(force)
   apply(rename_tac d n x e c i z)(*strict*)
   apply(force)
  apply(rename_tac d n x e c i z)(*strict*)
  apply(force)
  done

lemma cfgSTD_inst_AX_marking_can_not_be_disabled: "
  (\<forall>G d. (\<exists>n. cfg_marking_condition G (derivation_take d n)) \<longrightarrow> cfg_marking_condition G d)"
  apply(clarsimp)
  apply(rename_tac G d n)(*strict*)
  apply(simp add: cfg_marking_condition_def derivation_take_def)
  apply(clarsimp)
  apply(rename_tac G d n i e c)(*strict*)
  apply(case_tac "i\<le>n")
   apply(rename_tac G d n i e c)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac G d n i e c)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      x="i"
      in exI)
  apply(rule_tac
      x="e"
      in exI)
  apply(rule_tac
      x="c"
      in exI)
  apply(force)
  done

lemma cfgSTD_inst_AX_marked_effect_persists: "
  \<forall>G d n. cfg_marked_effect G (derivation_take d n) \<subseteq> cfg_marked_effect G d"
  apply(clarsimp)
  apply(rename_tac G d n x)(*strict*)
  apply(simp add: cfg_marked_effect_def derivation_take_def)
  apply(rename_tac d n x)(*strict*)
  apply(clarsimp)
  apply(rename_tac d n x e c i)(*strict*)
  apply(rule_tac
      x="e"
      in exI)
  apply(rule_tac
      x="c"
      in exI)
  apply(clarsimp)
  apply(case_tac "i\<le>n")
   apply(rename_tac d n x e c i)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac d n x e c i)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      x="i"
      in exI)
  apply(force)
  done

lemma cfgLM_inst_AX_unmarked_effect_persists: "
  \<forall>M d n. cfg_unmarked_effect M (derivation_take d n) \<subseteq> cfg_unmarked_effect M d"
  apply(clarsimp)
  apply(rename_tac M d n x)(*strict*)
  apply(simp add: cfg_unmarked_effect_def)
  apply(rename_tac d n x)(*strict*)
  apply(simp add: derivation_take_def)
  apply(clarsimp)
  apply(rename_tac d n x e c i z)(*strict*)
  apply(case_tac "i\<le>n")
   apply(rename_tac d n x e c i z)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      x="e"
      in exI)
   apply(rule_tac
      x="c"
      in exI)
   apply(rule conjI)
    apply(rename_tac d n x e c i z)(*strict*)
    apply(rule_tac
      x="i"
      in exI)
    apply(force)
   apply(rename_tac d n x e c i z)(*strict*)
   apply(force)
  apply(rename_tac d n x e c i z)(*strict*)
  apply(force)
  done

lemma cfgRM_inst_AX_unmarked_effect_persists: "
  \<forall>M d n. cfg_unmarked_effect M (derivation_take d n) \<subseteq> cfg_unmarked_effect M d"
  apply(clarsimp)
  apply(rename_tac M d n x)(*strict*)
  apply(simp add: cfg_unmarked_effect_def)
  apply(rename_tac d n x)(*strict*)
  apply(simp add: derivation_take_def)
  apply(clarsimp)
  apply(rename_tac d n x e c i z)(*strict*)
  apply(case_tac "i\<le>n")
   apply(rename_tac d n x e c i z)(*strict*)
   apply(clarsimp)
   apply(rule_tac
      x="e"
      in exI)
   apply(rule_tac
      x="c"
      in exI)
   apply(rule conjI)
    apply(rename_tac d n x e c i z)(*strict*)
    apply(rule_tac
      x="i"
      in exI)
    apply(force)
   apply(rename_tac d n x e c i z)(*strict*)
   apply(force)
  apply(rename_tac d n x e c i z)(*strict*)
  apply(force)
  done

lemma cfg_sub__trans: "
  cfg_sub G1 G2
  \<Longrightarrow> cfg_sub G2 G3
  \<Longrightarrow> cfg_sub G1 G3"
  apply(simp add: cfg_sub_def)
  apply(rule conjI)
   apply(force)
  apply(rule conjI)
   apply(force)
  apply(force)
  done

lemma CFG_prod_lhs_in_nonterms: "
  valid_cfg G
  \<Longrightarrow> p \<in> cfg_productions G
  \<Longrightarrow> prod_lhs p \<in> cfg_nonterminals G"
  apply(simp add: valid_cfg_def)
  done

lemma CFG_prod_rhs_in_two_elements_construct_domain: "
  valid_cfg G
  \<Longrightarrow> p \<in> cfg_productions G
  \<Longrightarrow> set (prod_rhs p)
          \<subseteq> two_elements_construct_domain
             (cfg_nonterminals
               G)
             (cfg_events G)"
  apply(simp add: valid_cfg_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(erule_tac
      x="p"
      in ballE)
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      A="set(prod_rhs p)"
      in set_mp)
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(rule SetxBiElem_check_vs_set_two_elements_construct_domain_check)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(force)
  done

lemma cfg_sub_trans: "
  cfg_sub a b
  \<Longrightarrow> cfg_sub b c
  \<Longrightarrow> cfg_sub a c"
  apply(simp add: cfg_sub_def)
  apply(clarsimp)
  apply(rule conjI)
   apply(force)
  apply(rule conjI)
   apply(force)
  apply(force)
  done

lemma cfg_sub_reflexive: "
  cfg_sub G G"
  apply(simp add: cfg_sub_def)
  done

lemma cfg_equal_by_mutual_cfg_sub: "
  cfg_sub G1 G2
  \<Longrightarrow> cfg_sub G2 G1
  \<Longrightarrow> G1 = G2"
  apply(simp add: cfg_sub_def)
  apply(force)
  done

lemma hlp3: "
  \<lparr>cfg_conf = liftB w\<rparr> \<in> cfg_configurations G
  \<Longrightarrow> i < length (liftB w)
  \<Longrightarrow> \<lparr>cfg_conf = [liftB w ! i]\<rparr> \<in> cfg_configurations G"
  apply(simp add: cfg_configurations_def)
  apply(clarsimp)
  apply(case_tac "liftB w ! i")
   apply(rename_tac a)(*strict*)
   apply(rule_tac
      t="liftB w ! i"
      and s="teA SSa" for SSa
      in ssubst)
    apply(rename_tac a)(*strict*)
    apply(force)
   apply(rename_tac a)(*strict*)
   apply(clarsimp)
   apply(rule hlp2)
    apply(rename_tac a)(*strict*)
    apply(force)
   apply(rename_tac a)(*strict*)
   apply(force)
  apply(rename_tac b)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      A="setB (liftB w)"
      in set_mp)
   apply(rename_tac b)(*strict*)
   apply(force)
  apply(rename_tac b)(*strict*)
  apply (metis liftB_reflects_length teB_in_setB_nth set_setBliftB)
  done

lemma cfg_initial_conf_is_conf: "
  valid_cfg G
  \<Longrightarrow> \<lparr>cfg_conf = [teA (cfg_initial G)]\<rparr> \<in> cfg_configurations G"
  apply(simp add: cfg_initial_configurations_def cfg_configurations_def valid_cfg_def)
  done

lemma cfg_initial_conf_is_initial_conf: "
  valid_cfg G
  \<Longrightarrow> \<lparr>cfg_conf = [teA (cfg_initial G)]\<rparr> \<in> cfg_initial_configurations G"
  apply(simp add: cfg_initial_configurations_def cfg_configurations_def valid_cfg_def)
  done

lemma cfg_sub_cfg_productions_set_mp: "
  p \<in> cfg_productions G
  \<Longrightarrow> cfg_sub G G'
  \<Longrightarrow> p \<in> cfg_productions G'"
  apply(simp add: cfg_sub_def)
  apply(force)
  done

lemma cfg_sub_cfg_configurations_set_mp: "
  c \<in> cfg_configurations G
  \<Longrightarrow> cfg_sub G G'
  \<Longrightarrow> c \<in> cfg_configurations G'"
  apply(simp add: cfg_sub_def)
  apply(clarsimp)
  apply(simp add: cfg_configurations_def)
  apply(clarsimp)
  apply(rename_tac c)(*strict*)
  apply(force)
  done

lemma foldl_hlp: "
  foldl (@) [] (map (cfg_conf \<circ> (\<lambda>x. \<lparr>cfg_conf = [x]\<rparr>)) w) = w"
  apply(induct w)
   apply(clarsimp)
  apply(rename_tac a w)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      t="foldl (@) [a] (map (\<lambda>a. [a]) w)"
      and s="[a]@foldl (@) [] (map (\<lambda>a. [a]) w)"
      in ssubst)
   apply(rename_tac a w)(*strict*)
   apply(rule foldl_first)
  apply(rename_tac a w)(*strict*)
  apply(force)
  done

definition LR1ProdFormSimp :: "('a,'b) cfg \<Rightarrow> bool" where
  "LR1ProdFormSimp G \<equiv> (\<forall>p\<in> cfg_productions G. \<exists>b A B C.
  prod_rhs p = []
  \<or> (p=\<lparr>prod_lhs=A,prod_rhs=[teB b,teA B]\<rparr>)
  \<or> (p=\<lparr>prod_lhs=A,prod_rhs=[teA B]\<rparr>)
  \<or> (p=\<lparr>prod_lhs=A,prod_rhs=[teA B,teA C]\<rparr>)
  )"

end