section \<open>Factorization into Monic Polynomials\label{sec:monic}\<close>

theory Monic_Polynomial_Factorization
imports
  Finite_Fields_Factorization_Ext
  Formal_Polynomial_Derivatives
begin

hide_const Factorial_Ring.multiplicity
hide_const Factorial_Ring.irreducible

lemma (in domain) finprod_mult_of:
  assumes "finite A"
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<in> carrier (mult_of R)"
  shows "finprod R f A = finprod (mult_of R) f A"
  using assms by (induction A rule:finite_induct, auto)

lemma (in ring) finite_poly:
  assumes "subring K R"
  assumes "finite K"
  shows
    "finite {f. f \<in> carrier (K[X]) \<and> degree f = n}" (is "finite ?A")
    "finite {f. f \<in> carrier (K[X]) \<and> degree f \<le> n}" (is "finite ?B")
proof -
  have "finite {f. set f \<subseteq> K \<and> length f \<le> n + 1}" (is "finite ?C")
    using assms(2) finite_lists_length_le by auto
  moreover have "?B \<subseteq> ?C"
    by (intro subsetI)
      (auto simp:univ_poly_carrier[symmetric] polynomial_def)
  ultimately show a: "finite ?B"
    using finite_subset by auto
  moreover have "?A \<subseteq> ?B"
    by (intro subsetI, simp)
  ultimately show "finite ?A"
    using finite_subset by auto
qed

definition pmult :: "_ \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> nat" ("pmult\<index>")
  where "pmult\<^bsub>R\<^esub> d p = multiplicity (mult_of (poly_ring R)) d p"

definition monic_poly :: "_ \<Rightarrow> 'a list \<Rightarrow> bool"
  where "monic_poly R f =
    (f \<noteq> [] \<and> lead_coeff f = \<one>\<^bsub>R\<^esub> \<and> f \<in> carrier (poly_ring R))"

definition monic_irreducible_poly where
  "monic_irreducible_poly R f =
    (monic_poly R f \<and> pirreducible\<^bsub>R\<^esub> (carrier R) f)"

abbreviation "m_i_p \<equiv> monic_irreducible_poly"

locale polynomial_ring = field +
  fixes K
  assumes polynomial_ring_assms: "subfield K R"
begin

lemma K_subring: "subring K R"
  using polynomial_ring_assms subfieldE(1) by auto

abbreviation P where "P \<equiv> K[X]"

text \<open>This locale is used to specialize the following lemmas for a fixed coefficient ring.
It can be introduced in a context as an intepretation to be able to use the following specialized
lemmas. Because it is not (and should not) introduced as a sublocale it has no lasting effect
for the field locale itself.\<close>

lemmas
    poly_mult_lead_coeff = poly_mult_lead_coeff[OF K_subring]
and degree_add_distinct = degree_add_distinct[OF K_subring]
and coeff_add = coeff_add[OF K_subring]
and var_closed = var_closed[OF K_subring]
and degree_prod = degree_prod[OF _ K_subring]
and degree_pow = degree_pow[OF K_subring]
and pirreducible_degree = pirreducible_degree[OF polynomial_ring_assms]
and degree_one_imp_pirreducible =
    degree_one_imp_pirreducible[OF polynomial_ring_assms]
and var_pow_closed = var_pow_closed[OF K_subring]
and var_pow_carr = var_pow_carr[OF K_subring]
and univ_poly_a_inv_degree = univ_poly_a_inv_degree[OF K_subring]
and var_pow_degree = var_pow_degree[OF K_subring]
and pdivides_zero = pdivides_zero[OF K_subring]
and pdivides_imp_degree_le = pdivides_imp_degree_le[OF K_subring]
and var_carr = var_carr[OF K_subring]
and rupture_eq_0_iff = rupture_eq_0_iff[OF polynomial_ring_assms]
and rupture_is_field_iff_pirreducible =
    rupture_is_field_iff_pirreducible[OF polynomial_ring_assms]
and rupture_surj_hom = rupture_surj_hom[OF K_subring]
and canonical_embedding_ring_hom =
    canonical_embedding_ring_hom[OF K_subring]
and rupture_surj_norm_is_hom = rupture_surj_norm_is_hom[OF K_subring]
and rupture_surj_as_eval = rupture_surj_as_eval[OF K_subring]
and eval_cring_hom = eval_cring_hom[OF K_subring]
and coeff_range = coeff_range[OF K_subring]
and finite_poly = finite_poly[OF K_subring]
and int_embed_consistent_with_poly_of_const =
    int_embed_consistent_with_poly_of_const[OF K_subring]
and pderiv_var_pow = pderiv_var_pow[OF _ K_subring]
and pderiv_add = pderiv_add[OF K_subring]
and pderiv_inv = pderiv_inv[OF K_subring]
and pderiv_mult = pderiv_mult[OF K_subring]
and pderiv_pow = pderiv_pow[OF _ K_subring]
and pderiv_carr = pderiv_carr[OF K_subring]

sublocale p:principal_domain "poly_ring R"
  by (simp add: carrier_is_subfield univ_poly_is_principal)

end

context field
begin

interpretation polynomial_ring "R" "carrier R"
  using carrier_is_subfield field_axioms
  by (simp add:polynomial_ring_def polynomial_ring_axioms_def)

lemma pdivides_mult_r:
  assumes "a \<in> carrier (mult_of P)"
  assumes "b \<in> carrier (mult_of P)"
  assumes "c \<in> carrier (mult_of P)"
  shows "a \<otimes>\<^bsub>P\<^esub> c pdivides b \<otimes>\<^bsub>P\<^esub> c \<longleftrightarrow> a pdivides b"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  have a:"b \<otimes>\<^bsub>P\<^esub> c \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
    using assms p.mult_of.m_closed by force
  have b:"a \<otimes>\<^bsub>P\<^esub> c \<in> carrier P"
    using assms by simp
  have c:"b \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
    using assms p.mult_of.m_closed by force
  have d:"a \<in> carrier P" using assms by simp
  have "?lhs \<longleftrightarrow> a \<otimes>\<^bsub>P\<^esub> c divides\<^bsub>mult_of P\<^esub> b \<otimes>\<^bsub>P\<^esub> c"
    unfolding pdivides_def using p.divides_imp_divides_mult a b
    by (meson divides_mult_imp_divides)
  also have "... \<longleftrightarrow> a divides\<^bsub>mult_of P\<^esub> b"
    using p.mult_of.divides_mult_r[OF assms] by simp
  also have "... \<longleftrightarrow> ?rhs"
    unfolding pdivides_def using p.divides_imp_divides_mult c d
    by (meson divides_mult_imp_divides)
  finally show ?thesis by simp
qed

lemma lead_coeff_carr:
  assumes "x \<in> carrier (mult_of P)"
  shows "lead_coeff x \<in> carrier R - {\<zero>}"
proof (cases x)
  case Nil
  then show ?thesis using assms by (simp add:univ_poly_zero)
next
  case (Cons a list)
  hence a: "polynomial (carrier R) (a # list)"
    using assms univ_poly_carrier by auto
  have "lead_coeff x = a"
    using Cons by simp
  also have "a \<in> carrier R - {\<zero>}"
    using lead_coeff_not_zero a by simp
  finally show ?thesis by simp
qed

lemma lead_coeff_poly_of_const:
  assumes "r \<noteq> \<zero>"
  shows "lead_coeff (poly_of_const r) = r"
  using assms
  by (simp add:poly_of_const_def)

lemma lead_coeff_mult:
  assumes "f \<in> carrier (mult_of P)"
  assumes "g \<in> carrier (mult_of P)"
  shows "lead_coeff (f \<otimes>\<^bsub>P\<^esub> g) = lead_coeff f \<otimes> lead_coeff g"
  unfolding univ_poly_mult using assms
  using univ_poly_carrier[where R="R" and K="carrier R"]
  by (subst poly_mult_lead_coeff) (simp_all add:univ_poly_zero)

lemma monic_poly_carr:
  assumes "monic_poly R f"
  shows "f \<in> carrier P"
  using assms unfolding monic_poly_def by simp

lemma monic_poly_add_distinct:
  assumes "monic_poly R f"
  assumes "g \<in> carrier P" "degree g < degree f"
  shows "monic_poly R (f \<oplus>\<^bsub>P\<^esub> g)"
proof (cases "g \<noteq> \<zero>\<^bsub>P\<^esub>")
  case True
  define n where "n = degree f"
  have "f \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
    using assms(1) univ_poly_zero
    unfolding monic_poly_def by auto
  hence "degree (f \<oplus>\<^bsub>P\<^esub> g) = max (degree f) (degree g)"
    using assms(2,3) True
    by (subst degree_add_distinct, simp_all)
  also have "... = degree f"
    using assms(3) by simp
  finally have b: "degree (f \<oplus>\<^bsub>P\<^esub> g) = n"
    unfolding n_def by simp
  moreover have "n > 0"
    using assms(3) unfolding n_def by simp
  ultimately have "degree (f \<oplus>\<^bsub>P\<^esub> g) \<noteq> degree ([])"
    by simp
  hence a:"f \<oplus>\<^bsub>P\<^esub> g \<noteq> []" by auto

  have "degree [] = 0" by simp
  also have  "... < degree f"
    using assms(3) by simp
  finally have "degree f \<noteq> degree []" by simp
  hence c: "f \<noteq> []" by auto

  have d: "length g \<le> n"
    using  assms(3) unfolding n_def by simp

  have "lead_coeff (f \<oplus>\<^bsub>P\<^esub> g) = coeff (f \<oplus>\<^bsub>P\<^esub> g) n"
    using a b by (cases "f \<oplus>\<^bsub>P\<^esub> g", auto)
  also have "... = coeff f n \<oplus> coeff g n"
    using monic_poly_carr assms
    by (subst coeff_add, auto)
  also have "... = lead_coeff f \<oplus> coeff g n"
    using c unfolding n_def by (cases "f", auto)
  also have "... = \<one> \<oplus> \<zero>"
    using assms(1) unfolding monic_poly_def
    unfolding subst coeff_length[OF d] by simp
  also have "... = \<one>"
    by simp
  finally have "lead_coeff (f \<oplus>\<^bsub>P\<^esub> g) = \<one>" by simp
  moreover have "f \<oplus>\<^bsub>P\<^esub> g \<in> carrier P"
    using monic_poly_carr assms by simp
  ultimately show  ?thesis
    using a  unfolding monic_poly_def by auto
next
  case False
  then show ?thesis using assms monic_poly_carr by simp
qed

lemma monic_poly_one: "monic_poly R \<one>\<^bsub>P\<^esub>"
proof -
  have "\<one>\<^bsub>P\<^esub> \<in> carrier P"
    by simp
  thus ?thesis
    by (simp add:univ_poly_one monic_poly_def)
qed

lemma monic_poly_var: "monic_poly R X"
proof -
  have "X \<in> carrier P"
    using var_closed by simp
  thus ?thesis
    by (simp add:var_def monic_poly_def)
qed

lemma monic_poly_carr_2:
  assumes "monic_poly R f"
  shows "f \<in> carrier (mult_of P)"
  using assms unfolding monic_poly_def
  by (simp add:univ_poly_zero)

lemma monic_poly_mult:
  assumes "monic_poly R f"
  assumes "monic_poly R g"
  shows "monic_poly R (f \<otimes>\<^bsub>P\<^esub> g)"
proof -
  have "lead_coeff (f \<otimes>\<^bsub>P\<^esub> g) = lead_coeff f \<otimes>\<^bsub>R\<^esub> lead_coeff g"
    using assms monic_poly_carr_2
    by (subst lead_coeff_mult) auto
  also have "... =  \<one>"
    using assms unfolding monic_poly_def by simp
  finally have "lead_coeff (f \<otimes>\<^bsub>P\<^esub> g) = \<one>\<^bsub>R\<^esub>" by simp
  moreover have "(f \<otimes>\<^bsub>P\<^esub> g) \<in> carrier (mult_of P)"
    using monic_poly_carr_2 assms by blast
  ultimately show ?thesis
    by (simp add:monic_poly_def univ_poly_zero)
qed

lemma monic_poly_pow:
  assumes "monic_poly R f"
  shows "monic_poly R (f [^]\<^bsub>P\<^esub> (n::nat))"
  using assms monic_poly_one monic_poly_mult
  by (induction n, auto)

lemma monic_poly_prod:
  assumes "finite A"
  assumes "\<And>x. x \<in> A \<Longrightarrow> monic_poly R (f x)"
  shows "monic_poly R (finprod P f A)"
  using assms
proof (induction A rule:finite_induct)
  case empty
  then show ?case by (simp add:monic_poly_one)
next
  case (insert x F)
  have a: "f \<in> F \<rightarrow> carrier P"
    using insert monic_poly_carr by simp
  have b: "f x \<in> carrier P"
    using insert monic_poly_carr by simp
  have "monic_poly R (f x \<otimes>\<^bsub>P\<^esub> finprod P f F)"
    using insert by (intro monic_poly_mult) auto
  thus ?case
    using insert a b by (subst p.finprod_insert, auto)
qed

lemma monic_poly_not_assoc:
  assumes "monic_poly R f"
  assumes "monic_poly R g"
  assumes "f \<sim>\<^bsub>(mult_of P)\<^esub> g"
  shows "f = g"
proof -
  obtain u where u_def: "f = g \<otimes>\<^bsub>P\<^esub> u" "u \<in> Units (mult_of P)"
    using p.mult_of.associatedD2 assms monic_poly_carr_2
    by blast

  hence "u \<in> Units P" by simp
  then obtain v where v_def: "u = [v]" "v \<noteq> \<zero>\<^bsub>R\<^esub>" "v \<in> carrier R"
    using univ_poly_carrier_units by auto

  have "\<one> = lead_coeff f"
    using assms(1) by (simp add:monic_poly_def)
  also have  "... = lead_coeff (g \<otimes>\<^bsub>P\<^esub> u)"
    by (simp add:u_def)
  also have "... = lead_coeff g \<otimes> lead_coeff u"
    using assms(2) monic_poly_carr_2 v_def u_def(2)
    by (subst lead_coeff_mult, auto simp add:univ_poly_zero)
  also have "... = lead_coeff g \<otimes> v"
    using v_def by simp
  also have "... = v"
    using assms(2) v_def(3) by (simp add:monic_poly_def)
  finally have "\<one> = v" by simp
  hence "u = \<one>\<^bsub>P\<^esub>"
    using v_def by (simp add:univ_poly_one)
  thus "f = g"
    using u_def assms monic_poly_carr by simp
qed

lemma monic_poly_span:
  assumes "x \<in> carrier (mult_of P)" "irreducible (mult_of P) x"
  shows "\<exists>y. monic_irreducible_poly R y \<and> x \<sim>\<^bsub>(mult_of P)\<^esub> y"
proof -
  define z where "z = poly_of_const (inv (lead_coeff x))"
  define y where "y = x \<otimes>\<^bsub>P\<^esub> z"

  have x_carr: "x \<in> carrier (mult_of P)" using assms by simp

  hence lx_ne_0: "lead_coeff x \<noteq> \<zero>"
    and lx_unit: "lead_coeff x \<in> Units R"
    using lead_coeff_carr[OF x_carr] by (auto simp add:field_Units)
  have lx_inv_ne_0: "inv (lead_coeff x) \<noteq> \<zero>"
    using lx_unit
    by (metis Units_closed Units_r_inv r_null zero_not_one)
  have lx_inv_carr: "inv (lead_coeff x) \<in> carrier R"
    using lx_unit by simp

  have "z \<in> carrier P"
    using lx_inv_carr poly_of_const_over_carrier
    unfolding z_def by auto
  moreover have "z \<noteq> \<zero>\<^bsub>P\<^esub>"
    using lx_inv_ne_0
    by (simp add:z_def poly_of_const_def univ_poly_zero)
  ultimately have z_carr: "z \<in> carrier (mult_of P)" by simp
  have z_unit: "z \<in> Units (mult_of P)"
    using lx_inv_ne_0 lx_inv_carr
    by (simp add:univ_poly_carrier_units z_def poly_of_const_def)
  have y_exp: "y = x \<otimes>\<^bsub>(mult_of P)\<^esub> z"
    by (simp add:y_def)
  hence y_carr: "y \<in> carrier (mult_of P)"
    using x_carr z_carr p.mult_of.m_closed by simp

  have "irreducible (mult_of P) y"
    unfolding y_def using assms z_unit z_carr
    by (intro p.mult_of.irreducible_prod_rI, auto)
  moreover have "lead_coeff y = \<one>\<^bsub>R\<^esub>"
    unfolding y_def using x_carr z_carr lx_inv_ne_0 lx_unit
    by (simp add: lead_coeff_mult z_def lead_coeff_poly_of_const)
  hence "monic_poly R y"
    using y_carr unfolding monic_poly_def
    by (simp add:univ_poly_zero)
  ultimately have "monic_irreducible_poly R y"
    using p.irreducible_mult_imp_irreducible y_carr
    by (simp add:monic_irreducible_poly_def ring_irreducible_def)
  moreover have "y \<sim>\<^bsub>(mult_of P)\<^esub> x"
    by (intro p.mult_of.associatedI2[OF z_unit] y_def x_carr)
  hence "x \<sim>\<^bsub>(mult_of P)\<^esub> y"
    using x_carr y_carr by (simp add:p.mult_of.associated_sym)
  ultimately show ?thesis by auto
qed

lemma monic_polys_are_canonical_irreducibles:
  "canonical_irreducibles (mult_of P) {d. monic_irreducible_poly R d}"
  (is "canonical_irreducibles (mult_of P) ?S")
proof -
  have sp_1:
    "?S \<subseteq> {x \<in> carrier (mult_of P). irreducible (mult_of P) x}"
    unfolding monic_irreducible_poly_def ring_irreducible_def
    using monic_poly_carr
    by (intro subsetI, simp add: p.irreducible_imp_irreducible_mult)
  have sp_2: "x = y"
      if "x \<in> ?S" "y \<in> ?S" "x \<sim>\<^bsub>(mult_of P)\<^esub> y" for x y
    using that monic_poly_not_assoc
    by (simp add:monic_irreducible_poly_def)

  have sp_3: "\<exists>y \<in> ?S. x \<sim>\<^bsub>(mult_of P)\<^esub> y"
    if "x \<in> carrier (mult_of P)" "irreducible (mult_of P) x" for x
    using that monic_poly_span by simp

  thus ?thesis using sp_1 sp_2 sp_3
    unfolding canonical_irreducibles_def by simp
qed

lemma
  assumes "monic_poly R a"
  shows factor_monic_poly:
    "a = (\<Otimes>\<^bsub>P\<^esub>d\<in>{d. monic_irreducible_poly R d \<and> pmult d a > 0}.
      d [^]\<^bsub>P\<^esub> pmult d a)" (is "?lhs = ?rhs")
    and factor_monic_poly_fin:
      "finite {d. monic_irreducible_poly R d \<and> pmult d a > 0}"
proof -
  let ?S = "{d. monic_irreducible_poly R d}"
  let ?T = "{d. monic_irreducible_poly R d \<and> pmult d a > 0}"
  let ?mip = "monic_irreducible_poly R"

  have sp_4: "a \<in> carrier (mult_of P)"
    using assms monic_poly_carr_2
    unfolding monic_irreducible_poly_def by simp

  have b_1: "x \<in> carrier (mult_of P)" if "?mip x" for x
    using that monic_poly_carr_2
    unfolding monic_irreducible_poly_def by simp
  have b_2:"irreducible (mult_of P) x" if "?mip x" for x
    using that
    unfolding monic_irreducible_poly_def ring_irreducible_def
    by (simp add: monic_poly_carr p.irreducible_imp_irreducible_mult)
  have b_3:"x \<in> carrier P" if "?mip x" for x
    using that monic_poly_carr
    unfolding monic_irreducible_poly_def
    by simp

  have a_carr: "a \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
    using sp_4 by simp

  have "?T = {d. ?mip d \<and> multiplicity (mult_of P) d a > 0}"
    by (simp add:pmult_def)
  also have "... = {d \<in> ?S. multiplicity (mult_of P) d a > 0}"
    using p.mult_of.multiplicity_gt_0_iff[OF b_1 b_2 sp_4]
    by (intro order_antisym subsetI, auto)
  finally have t:"?T = {d \<in> ?S. multiplicity (mult_of P) d a > 0}"
    by simp

  show fin_T: "finite ?T"
    unfolding t
    using p.mult_of.split_factors(1)
      [OF monic_polys_are_canonical_irreducibles]
    using sp_4 by auto

  have a:"x [^]\<^bsub>P\<^esub> (n::nat) \<in> carrier (mult_of P)" if "?mip x" for x n
  proof -
    have "monic_poly R (x [^]\<^bsub>P\<^esub> n)"
      using that monic_poly_pow
      unfolding monic_irreducible_poly_def by auto
    thus ?thesis
      using monic_poly_carr_2 by simp
  qed

  have "?lhs \<sim>\<^bsub>(mult_of P)\<^esub>
    finprod (mult_of P)
      (\<lambda>d. d [^]\<^bsub>(mult_of P)\<^esub> (multiplicity (mult_of P) d a)) ?T"
    unfolding t
    by (intro p.mult_of.split_factors(2)
        [OF monic_polys_are_canonical_irreducibles sp_4])
  also have "... =
    finprod (mult_of P) (\<lambda>d. d [^]\<^bsub>P\<^esub> (multiplicity (mult_of P) d a)) ?T"
    by (simp add:nat_pow_mult_of)
  also have "... = ?rhs"
    using fin_T a
    by (subst p.finprod_mult_of, simp_all add:pmult_def)
  finally have "?lhs \<sim>\<^bsub>(mult_of P)\<^esub> ?rhs" by simp
  moreover have "monic_poly R ?rhs"
    using fin_T
    by (intro monic_poly_prod monic_poly_pow)
      (auto simp:monic_irreducible_poly_def)
  ultimately show "?lhs = ?rhs"
    using monic_poly_not_assoc assms monic_irreducible_poly_def
    by blast
qed

lemma degree_monic_poly':
  assumes "monic_poly R f"
  shows
    "sum' (\<lambda>d. pmult d f * degree d) {d. monic_irreducible_poly R d} =
    degree f"
proof -
  let ?mip = "monic_irreducible_poly R"

  have b: "d \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}" if "?mip d" for d
    using that monic_poly_carr_2
    unfolding monic_irreducible_poly_def by simp
  have a: "d [^]\<^bsub>P\<^esub> n \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}" if "?mip d" for d and n :: "nat"
    using b that monic_poly_pow
    unfolding monic_irreducible_poly_def
    by (simp add: p.pow_non_zero)

  have "degree f =
    degree (\<Otimes>\<^bsub>P\<^esub>d\<in>{d. ?mip d \<and> pmult d f > 0}. d [^]\<^bsub>P\<^esub> pmult d f)"
    using factor_monic_poly[OF assms(1)] by simp
  also have "... =
    (\<Sum>i\<in>{d. ?mip d \<and> 0 < pmult d f}. degree (i [^]\<^bsub>P\<^esub> pmult i f))"
    using a assms(1)
    by (subst degree_prod[OF factor_monic_poly_fin])
     (simp_all add:Pi_def)
  also have "... =
    (\<Sum>i\<in>{d. ?mip d \<and> 0 < pmult d f}. degree i * pmult i f)"
    using b degree_pow by (intro sum.cong, auto)
  also have "... =
    (\<Sum>d\<in>{d. ?mip d \<and> 0 < pmult d f}. pmult d f * degree d)"
    by (simp add:mult.commute)
  also have "... =
    sum' (\<lambda>d. pmult d f * degree d) {d. ?mip d \<and> 0 < pmult d f}"
    using sum.eq_sum factor_monic_poly_fin[OF assms(1)] by simp
  also have "... = sum' (\<lambda>d. pmult d f * degree d) {d. ?mip d}"
    by (intro sum.mono_neutral_cong_left' subsetI, auto)
  finally show ?thesis by simp
qed

lemma monic_poly_min_degree:
  assumes "monic_irreducible_poly R f"
  shows  "degree f \<ge> 1"
  using assms unfolding monic_irreducible_poly_def monic_poly_def
  by (intro pirreducible_degree) auto

lemma degree_one_monic_poly:
  "monic_irreducible_poly R f \<and> degree f = 1 \<longleftrightarrow>
  (\<exists>x \<in> carrier R. f = [\<one>, \<ominus>x])"
proof
  assume "monic_irreducible_poly R f \<and> degree f = 1"
  hence a:"monic_poly R f" "length f = 2"
    unfolding monic_irreducible_poly_def by auto
  then obtain u v where f_def: "f = [u,v]"
    by (cases f, simp, cases "tl f", auto)

  have "u = \<one>" using a unfolding monic_poly_def f_def by simp
  moreover have "v \<in> carrier R"
    using a unfolding monic_poly_def univ_poly_carrier[symmetric]
    unfolding polynomial_def f_def by simp
  ultimately have "f =  [\<one>, \<ominus>(\<ominus>v)]" "(\<ominus>v) \<in> carrier R"
    using a_inv_closed f_def by auto
  thus "(\<exists>x \<in> carrier R. f = [\<one>\<^bsub>R\<^esub>, \<ominus>\<^bsub>R\<^esub>x])" by auto
next
  assume "(\<exists>x \<in> carrier R. f = [\<one>, \<ominus>x])"
  then obtain x where f_def: "f = [\<one>,\<ominus>x]" "x \<in> carrier R" by auto
  have a:"degree f = 1" using f_def(2) unfolding f_def by simp
  have b:"f \<in> carrier P"
    using f_def(2) unfolding univ_poly_carrier[symmetric]
    unfolding f_def polynomial_def by simp
  have c: "pirreducible (carrier R) f"
    by (intro degree_one_imp_pirreducible a b)
  have d: "lead_coeff f = \<one>" unfolding f_def by simp
  show "monic_irreducible_poly R f \<and> degree f = 1"
    using a b c d
    unfolding monic_irreducible_poly_def monic_poly_def
    by auto
qed

lemma multiplicity_ge_iff:
  assumes "monic_irreducible_poly R d"
  assumes "f \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
  shows "pmult d f \<ge> k \<longleftrightarrow> d [^]\<^bsub>P\<^esub> k pdivides f"
proof -
  have a:"f \<in> carrier (mult_of P)"
    using assms(2) by simp
  have b: "d \<in> carrier (mult_of P)"
    using assms(1) monic_poly_carr_2
    unfolding monic_irreducible_poly_def by simp
  have c: "irreducible (mult_of P) d"
    using assms(1) monic_poly_carr_2
    using p.irreducible_imp_irreducible_mult
    unfolding monic_irreducible_poly_def
    unfolding ring_irreducible_def monic_poly_def
    by simp
  have d: "d [^]\<^bsub>P\<^esub> k \<in> carrier P" using b by simp

  have "pmult d f \<ge> k \<longleftrightarrow> d [^]\<^bsub>(mult_of P)\<^esub> k divides\<^bsub>(mult_of P)\<^esub> f"
    unfolding pmult_def
    by (intro p.mult_of.multiplicity_ge_iff a b c)
  also have "... \<longleftrightarrow> d [^]\<^bsub>P\<^esub> k pdivides\<^bsub>R\<^esub> f"
    using p.divides_imp_divides_mult[OF d assms(2)]
    using divides_mult_imp_divides
    unfolding pdivides_def nat_pow_mult_of
    by auto
  finally show ?thesis by simp
qed

lemma multiplicity_ge_1_iff_pdivides:
  assumes "monic_irreducible_poly R d" "f \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
  shows "pmult d f \<ge> 1 \<longleftrightarrow> d pdivides f"
proof -
  have "d \<in> carrier P"
    using assms(1) monic_poly_carr
    unfolding monic_irreducible_poly_def
    by simp
  thus ?thesis
    using multiplicity_ge_iff[OF assms, where k="1"]
    by simp
qed

lemma divides_monic_poly:
  assumes "monic_poly R f" "monic_poly R g"
  assumes "\<And>d. monic_irreducible_poly R d
    \<Longrightarrow> pmult d f \<le> pmult d g"
  shows "f pdivides g"
proof -
  have a:"f \<in> carrier (mult_of P)" "g \<in> carrier (mult_of P)"
    using monic_poly_carr_2 assms(1,2) by auto

  have "f divides\<^bsub>(mult_of P)\<^esub> g"
    using assms(3) unfolding pmult_def
    by (intro p.mult_of.divides_iff_mult_mono
        [OF a monic_polys_are_canonical_irreducibles]) simp
  thus ?thesis
    unfolding pdivides_def using divides_mult_imp_divides by simp
qed

end

lemma monic_poly_hom:
  assumes "monic_poly R f"
  assumes "h \<in> ring_iso R S" "domain R" "domain S"
  shows "monic_poly S (map h f)"
proof -
  have c: "h \<in> ring_hom R S"
    using assms(2) ring_iso_def by auto
  have e: "f \<in> carrier (poly_ring R)"
    using assms(1) unfolding monic_poly_def by simp

  have a:"f \<noteq> []"
    using assms(1) unfolding monic_poly_def by simp
  hence "map h f \<noteq> []" by simp
  moreover have "lead_coeff f = \<one>\<^bsub>R\<^esub>"
    using assms(1) unfolding monic_poly_def by simp
  hence "lead_coeff (map h f) = \<one>\<^bsub>S\<^esub>"
    using ring_hom_one[OF c] by (simp add: hd_map[OF a])
  ultimately show ?thesis
    using carrier_hom[OF e assms(2-4)]
    unfolding monic_poly_def by simp
qed

lemma monic_irreducible_poly_hom:
  assumes "monic_irreducible_poly R f"
  assumes "h \<in> ring_iso R S" "domain R" "domain S"
  shows "monic_irreducible_poly S (map h f)"
proof -
  have a:
    "pirreducible\<^bsub>R\<^esub> (carrier R) f"
    "f \<in> carrier (poly_ring R)"
    "monic_poly R f"
    using assms(1)
    unfolding monic_poly_def monic_irreducible_poly_def
    by auto

  have "pirreducible\<^bsub>S\<^esub> (carrier S) (map h f)"
    using a pirreducible_hom assms by auto
  moreover have "monic_poly S (map h f)"
    using a monic_poly_hom[OF _ assms(2,3,4)] by simp
  ultimately show ?thesis
    unfolding monic_irreducible_poly_def by simp
qed

end


theory Globular_Set

imports "HOL-Library.FuncSet"

begin

section \<open>Background material on extensional functions\<close>

lemma PiE_imp_Pi: "f \<in> A \<rightarrow>\<^sub>E B \<Longrightarrow> f \<in> A \<rightarrow> B" by fast

lemma PiE_iff': "f \<in> A \<rightarrow>\<^sub>E B = (f \<in> A \<rightarrow> B \<and> f \<in> extensional A)"
  by (simp add: PiE_iff Pi_iff)

abbreviation composing ("_ \<circ> _ \<down> _" [60,0,60]59)
  where "g \<circ> f \<down> D \<equiv> compose D g f"

lemma compose_PiE: "f \<in> A \<rightarrow> B \<Longrightarrow> g \<in> B \<rightarrow> C \<Longrightarrow> g \<circ> f \<down> A \<in> A \<rightarrow>\<^sub>E C"
  by (metis funcset_compose compose_extensional PiE_iff')

lemma compose_eq_iff: "(g \<circ> f \<down> A = k \<circ> h \<down> A) = (\<forall>x \<in> A. g (f x) = k (h x))"
proof (safe)
  fix x assume "g \<circ> f \<down> A = k \<circ> h \<down> A" "x \<in> A"
  then show "g (f x) = k (h x)" by (metis compose_eq)
next
  assume "\<forall>x \<in> A. g (f x) = k (h x)"
  hence "\<And>x. x \<in> A \<Longrightarrow> (g \<circ> f \<down> A) x = (k \<circ> h \<down> A) x" by (metis compose_eq)
  then show "g \<circ> f \<down> A = k \<circ> h \<down> A" by (metis extensionalityI compose_extensional)
qed

lemma compose_eq_if: "(\<And>x. x \<in> A \<Longrightarrow> g (f x) = k (h x)) \<Longrightarrow> g \<circ> f \<down> A = k \<circ> h \<down> A"
  using compose_eq_iff by blast

lemma compose_compose_eq_iff2: "(h \<circ> (g \<circ> f \<down> A) \<down> A = h' \<circ> (g' \<circ> f' \<down> A) \<down> A) =
  (\<forall>x \<in> A. h (g (f x)) = h' (g' (f' x)))"
  by (simp add: compose_eq compose_eq_iff)

lemma compose_compose_eq_iff1: assumes "f \<in> A \<rightarrow> B" "f' \<in> A \<rightarrow> B"
  shows "((h \<circ> g \<down> B) \<circ> f \<down> A = (h' \<circ> g' \<down> B) \<circ> f' \<down> A) = (\<forall>x \<in> A. h (g (f x)) = h' (g' (f' x)))"
proof -
  have "(h \<circ> g \<down> B) \<circ> f \<down> A = h \<circ> (g \<circ> f \<down> A) \<down> A" by (metis assms(1) compose_assoc)
  moreover have "(h' \<circ> g' \<down> B) \<circ> f' \<down> A = h' \<circ> (g' \<circ> f' \<down> A) \<down> A" by (metis assms(2) compose_assoc)
  ultimately have h: "((h \<circ> g \<down> B) \<circ> f \<down> A = (h' \<circ> g' \<down> B) \<circ> f' \<down> A) =
    (h \<circ> (g \<circ> f \<down> A) \<down> A = h' \<circ> (g' \<circ> f' \<down> A) \<down> A)" by presburger
  then show ?thesis by (simp only: h compose_compose_eq_iff2)
qed

lemma compose_compose_eq_if1: "\<lbrakk>f \<in> A \<rightarrow> B; f' \<in> A \<rightarrow> B; \<forall>x \<in> A. h (g (f x)) = h' (g' (f' x))\<rbrakk> \<Longrightarrow>
  (h \<circ> g \<down> B) \<circ> f \<down> A = (h' \<circ> g' \<down> B) \<circ> f' \<down> A"
  using compose_compose_eq_iff1 by blast

lemma compose_compose_eq_if2: "\<forall>x \<in> A. h (g (f x)) = h' (g' (f' x)) \<Longrightarrow>
  h \<circ> (g \<circ> f \<down> A) \<down> A = h' \<circ> (g' \<circ> f' \<down> A) \<down> A"
  using compose_compose_eq_iff2 by blast

lemma compose_restrict_eq1: "f \<in> A \<rightarrow> B \<Longrightarrow>  restrict g B \<circ> f \<down> A = g \<circ> f \<down> A"
  by (smt (verit) PiE compose_eq_iff restrict_apply')

lemma compose_restrict_eq2: "g \<circ> (restrict f A) \<down> A = g \<circ> f \<down> A"
  by (metis (mono_tags, lifting) compose_eq_if restrict_apply')

lemma compose_Id_eq_restrict: "g \<circ> (\<lambda>x \<in> A. x) \<down> A = restrict g A"
  by (smt (verit) compose_restrict_eq1 compose_def restrict_apply' restrict_ext)

section \<open>Globular sets\<close>

subsection \<open>Globular sets\<close>

text \<open>
  We define a locale \<open>globular_set\<close> that encodes the cell data of a strict $\omega$-category
  \cite[Def 1.4.5]{Leinster2004}. The elements of \<open>X n\<close> are the \<open>n\<close>-cells, and the maps \<open>s\<close>
  and \<open>t\<close> give the source and target of a cell, respectively.
\<close>

locale globular_set =
  fixes X :: "nat \<Rightarrow> 'a set" and s :: "nat \<Rightarrow> 'a \<Rightarrow> 'a" and t :: "nat \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes s_fun: "s n \<in> X (Suc n) \<rightarrow> X n"
    and   t_fun: "t n \<in> X (Suc n) \<rightarrow> X n"
    and  s_comp: "x \<in> X (Suc (Suc n)) \<Longrightarrow> s n (t (Suc n) x) = s n (s (Suc n) x)"
    and  t_comp: "x \<in> X (Suc (Suc n)) \<Longrightarrow> t n (s (Suc n) x) = t n (t (Suc n) x)"
begin

lemma s_comp': "s n \<circ> t (Suc n) \<down> X (Suc (Suc n)) = s n \<circ> s (Suc n) \<down> X (Suc (Suc n))"
  by (metis (full_types) compose_eq_if s_comp)

lemma t_comp': "t n \<circ> s (Suc n) \<down> X (Suc (Suc n)) = t n \<circ> t (Suc n) \<down> X (Suc (Suc n))"
  by (metis (full_types) compose_eq_if t_comp)

text \<open>These are the generalised source and target maps. The arguments are the dimension of the
input and output, respectively. They allow notation similar to \<open>s\<^sup>m\<^sup>-\<^sup>p\<close> in \cite{Leinster2004}.\<close>

fun s' :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" where
"s' 0 0 = id" |
"s' 0 (Suc n) = undefined" |
"s' (Suc m) n = (if Suc m < n then undefined
  else if Suc m = n then id
  else s' m n \<circ> s m)"

fun t' :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" where
"t' 0 0 = id" |
"t' 0 (Suc n) = undefined" |
"t' (Suc m) n = (if Suc m < n then undefined
  else if Suc m = n then id
  else t' m n \<circ> t m)"

lemma s'_n_n [simp]: "s' n n = id"
  by (cases n, simp_all)

lemma s'_Suc_n_n [simp]: "s' (Suc n) n = s n"
  by simp

lemma s'_Suc_Suc_n_n [simp]: "s' (Suc (Suc n)) n = s n \<circ> s (Suc n)"
  by simp

lemma s'_Suc [simp]: "n \<le> m \<Longrightarrow> s' (Suc m) n = s' m n \<circ> s m"
  by simp

lemma s'_Suc': "n < m \<Longrightarrow> s' m n = s n \<circ> s' m (Suc n)"
proof (induction m arbitrary: n)
  case 0
  then show ?case by blast
next
  case (Suc m)
  hence "n \<le> m" by fastforce
  show ?case proof (cases "n = m", simp)
    assume "n \<noteq> m"
    then show "s' (Suc m) n = s n \<circ> s' (Suc m) (Suc n)" using Suc by fastforce
  qed
qed

lemma t'_n_n [simp]: "t' n n = id"
  by (cases n, simp_all)

lemma t'_Suc_n_n [simp]: "t' (Suc n) n = t n"
  by simp

lemma t'_Suc_Suc_n_n [simp]: "t' (Suc (Suc n)) n = t n \<circ> t (Suc n)"
  by simp

lemma t'_Suc [simp]: "n \<le> m \<Longrightarrow> t' (Suc m) n = t' m n \<circ> t m"
  by simp

lemma t'_Suc': "n < m \<Longrightarrow> t' m n = t n \<circ> t' m (Suc n)"
proof (induction m arbitrary: n)
  case 0
  then show ?case by blast
next
  case (Suc m)
  hence "n \<le> m" by fastforce
  show ?case proof (cases "n = m", simp)
    assume "n \<noteq> m"
    then show "t' (Suc m) n = t n \<circ> t' (Suc m) (Suc n)" using Suc by fastforce
  qed
qed

lemma s'_fun: "n \<le> m \<Longrightarrow> s' m n \<in> X m \<rightarrow> X n"
proof (induction m arbitrary: n)
  case 0
  thus ?case by force
next
  case (Suc m)
  thus ?case proof (cases "n = Suc m")
    case True
    then show ?thesis by auto
  next
    case False
    hence "n \<le> m" using `n \<le> Suc m` by force
    thus ?thesis using Suc.IH s_fun s'_Suc by auto
  qed
qed

lemma t'_fun: "n \<le> m \<Longrightarrow> t' m n \<in> X m \<rightarrow> X n"
proof (induction m arbitrary: n)
  case 0
  thus ?case by force
next
  case (Suc m)
  thus ?case proof (cases "n = Suc m")
    case True
    then show ?thesis by auto
  next
    case False
    hence "n \<le> m" using `n \<le> Suc m` by force
    thus ?thesis using Suc.IH t_fun t'_Suc by auto
  qed
qed

lemma s'_comp: "\<lbrakk> n < m; x \<in> X m \<rbrakk> \<Longrightarrow> s n (t' m (Suc n) x) = s' m n x"
proof (induction "m - n" arbitrary: n)
  case 0
  then show ?case by force
next
  case IH: (Suc k)
  show ?case proof (cases k)
    case 0
    with IH(2) have "m = Suc n" by fastforce
    then show ?thesis using s'_Suc' by auto
  next
    case (Suc k')
    with \<open>Suc k = m - n\<close> have hle: "Suc (Suc n) \<le> m" by simp
    hence "Suc n < m" by force
    hence "Suc (Suc n) \<le> m" by fastforce
    have "s n (t' m (Suc n) x)
       = s n (t (Suc n) (t' m (Suc (Suc n)) x))" using t'_Suc' \<open>Suc n < m\<close> by simp
    also have "\<dots> = s n (s (Suc n) (t' m (Suc (Suc n)) x))"
      using t'_fun \<open>Suc (Suc n) \<le> m\<close> s_comp IH(4) by blast
    also have "\<dots> = s n (s' m (Suc n) x)"
      using IH Suc_diff_Suc Suc_inject \<open>Suc n < m\<close> by presburger
    finally show ?thesis using \<open>n < m\<close> s'_Suc' by simp
  qed
qed

lemma t'_comp: "\<lbrakk> n < m; x \<in> X m \<rbrakk> \<Longrightarrow> t n (s' m (Suc n) x) = t' m n x"
proof (induction "m - n" arbitrary: n)
  case 0
  then show ?case by force
next
  case IH: (Suc k)
  show ?case proof (cases k)
    case 0
    with IH(2) have "m = Suc n" by fastforce
    then show ?thesis using IH.prems(1) by auto
  next
    case (Suc k')
    with \<open>Suc k = m - n\<close> have hle: "Suc (Suc n) \<le> m" by simp
    hence "Suc n < m" by force
    hence "Suc (Suc n) \<le> m" by fastforce
    have "t n (s' m (Suc n) x)
       = t n (s (Suc n) (s' m (Suc (Suc n)) x))" using s'_Suc' \<open>Suc n < m\<close> by simp
    also have "\<dots> = t n (t (Suc n) (s' m (Suc (Suc n)) x))"
      using s'_fun \<open>Suc (Suc n) \<le> m\<close> t_comp IH(4) by blast
    also have "\<dots> = t n (t' m (Suc n) x)"
      using IH Suc_diff_Suc Suc_inject \<open>Suc n < m\<close> by presburger
    finally show ?thesis using \<open>n < m\<close> t'_Suc' by simp
  qed
qed

text \<open>The following predicates and sets are needed to define composition in an $\omega$-category.\<close>

definition is_parallel_pair :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
"is_parallel_pair m n x y \<equiv> n \<le> m \<and> x \<in> X m \<and> y \<in> X m \<and> s' m n x = s' m n y \<and> t' m n x = t' m n y"

text \<open>\cite[p. 44]{Leinster2004}\<close>
definition is_composable_pair :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
"is_composable_pair m n y x \<equiv> n < m \<and> y \<in> X m \<and> x \<in> X m \<and> t' m n x = s' m n y"

definition composable_pairs :: "nat \<Rightarrow> nat \<Rightarrow> ('a \<times> 'a) set" where
"composable_pairs m n = {(y, x). is_composable_pair m n y x}"

lemma composable_pairs_empty: "m \<le> n \<Longrightarrow> composable_pairs m n = {}"
  using is_composable_pair_def composable_pairs_def by simp

end

subsection \<open>Maps between globular sets\<close>

text \<open>We define maps between globular sets to be natural transformations of the corresponding
functors \cite[Def 1.4.5]{Leinster2004}.\<close>

locale globular_map = source: globular_set X s\<^sub>X t\<^sub>X + target: globular_set Y s\<^sub>Y t\<^sub>Y
  for X s\<^sub>X t\<^sub>X Y s\<^sub>Y t\<^sub>Y +
  fixes \<phi> :: "nat \<Rightarrow> 'a \<Rightarrow> 'b"
  assumes map_fun: "\<phi> m \<in> X m \<rightarrow> Y m"
    and   is_natural_wrt_s: "x \<in> X (Suc m) \<Longrightarrow> \<phi> m (s\<^sub>X m x) = s\<^sub>Y m (\<phi> (Suc m) x)"
    and   is_natural_wrt_t: "x \<in> X (Suc m) \<Longrightarrow> \<phi> m (t\<^sub>X m x) = t\<^sub>Y m (\<phi> (Suc m) x)"
begin

lemma is_natural_wrt_s': "\<lbrakk> n \<le> m; x \<in> X m \<rbrakk> \<Longrightarrow> \<phi> n (source.s' m n x) = target.s' m n (\<phi> m x)"
proof (induction "m - n" arbitrary: n)
  case 0
  hence "m = n" by simp
  then show ?case by fastforce
next
  case (Suc k)
  hence "n < m" by force
  hence "Suc n \<le> m" by auto
  have "\<phi> n (source.s' m n x) = \<phi> n (s\<^sub>X n (source.s' m (Suc n) x))"
    using source.s'_Suc' \<open>n < m\<close> by simp
  also have "\<dots> = s\<^sub>Y n (\<phi> (Suc n) (source.s' m (Suc n) x))"
    using source.s'_fun \<open>Suc n \<le> m\<close> Suc(1) Suc(4) is_natural_wrt_s by blast
  also have "\<dots> = s\<^sub>Y n (target.s' m (Suc n) (\<phi> m x))"
    using Suc \<open>Suc n \<le> m\<close> Suc_diff_Suc Suc_inject \<open>n < m\<close> by presburger
  finally show ?case using target.s'_Suc' \<open>n < m\<close> by simp
qed

lemma is_natural_wrt_t': "\<lbrakk> n \<le> m; x \<in> X m \<rbrakk> \<Longrightarrow> \<phi> n (source.t' m n x) = target.t' m n (\<phi> m x)"
proof (induction "m - n" arbitrary: n)
  case 0
  hence "m = n" by simp
  then show ?case by fastforce
next
  case (Suc k)
  hence "n < m" by force
  hence "Suc n \<le> m" by auto
  have "\<phi> n (source.t' m n x) = \<phi> n (t\<^sub>X n (source.t' m (Suc n) x))"
    using source.t'_Suc' \<open>n < m\<close> by simp
  also have "\<dots> = t\<^sub>Y n (\<phi> (Suc n) (source.t' m (Suc n) x))"
    using source.t'_fun \<open>Suc n \<le> m\<close> Suc(1) Suc(4) is_natural_wrt_t by blast
  also have "\<dots> = t\<^sub>Y n (target.t' m (Suc n) (\<phi> m x))"
    using Suc \<open>Suc n \<le> m\<close> Suc_diff_Suc Suc_inject \<open>n < m\<close> by presburger
  finally show ?case using target.t'_Suc' \<open>n < m\<close> by simp
qed

end

text \<open>The composition of two globular maps is itself a globular map. This intermediate
  locale gathers the data needed for such a statement.\<close>
locale two_globular_maps = fst: globular_map X s\<^sub>X t\<^sub>X Y s\<^sub>Y t\<^sub>Y \<phi> + snd: globular_map Y s\<^sub>Y t\<^sub>Y Z s\<^sub>Z t\<^sub>Z \<psi>
  for X s\<^sub>X t\<^sub>X Y s\<^sub>Y t\<^sub>Y Z s\<^sub>Z t\<^sub>Z \<phi> \<psi>

sublocale two_globular_maps \<subseteq> comp: globular_map X s\<^sub>X t\<^sub>X Z s\<^sub>Z t\<^sub>Z "\<lambda>m. \<psi> m \<circ> \<phi> m"
proof (unfold_locales)
  fix m
  show "\<psi> m \<circ> \<phi> m \<in> X m \<rightarrow> Z m" using fst.map_fun snd.map_fun by fastforce
next
  fix x m assume "x \<in> X (Suc m)"
  then show "(\<psi> m \<circ> \<phi> m) (s\<^sub>X m x) = s\<^sub>Z m ((\<psi> (Suc m) \<circ> \<phi> (Suc m)) x)"
    using fst.is_natural_wrt_s snd.is_natural_wrt_s comp_apply fst.map_fun by fastforce
next
  fix x m assume "x \<in> X (Suc m)"
  then show "(\<psi> m \<circ> \<phi> m) (t\<^sub>X m x) = t\<^sub>Z m ((\<psi> (Suc m) \<circ> \<phi> (Suc m)) x)"
    using fst.is_natural_wrt_t snd.is_natural_wrt_t comp_apply fst.map_fun by fastforce
qed

sublocale two_globular_maps \<subseteq> compose: globular_map X s\<^sub>X t\<^sub>X Z s\<^sub>Z t\<^sub>Z "\<lambda>m. \<psi> m \<circ> \<phi> m \<down> X m"
proof (unfold_locales)
  fix m
  show "\<psi> m \<circ> \<phi> m \<down> X m \<in> X m \<rightarrow> Z m" using funcset_compose fst.map_fun snd.map_fun by fast
next
  fix x m assume "x \<in> X (Suc m)"
  then show "(\<psi> m \<circ> \<phi> m \<down> X m) (s\<^sub>X m x) = s\<^sub>Z m ((\<psi> (Suc m) \<circ> \<phi> (Suc m) \<down> X (Suc m)) x)"
    by (metis PiE fst.is_natural_wrt_s snd.is_natural_wrt_s fst.map_fun compose_eq fst.source.s_fun)
next
  fix x m assume "x \<in> X (Suc m)"
  then show "(\<psi> m \<circ> \<phi> m \<down> X m) (t\<^sub>X m x) = t\<^sub>Z m ((\<psi> (Suc m) \<circ> \<phi> (Suc m) \<down> X (Suc m)) x)"
    by (metis PiE fst.is_natural_wrt_t snd.is_natural_wrt_t fst.map_fun compose_eq fst.source.t_fun)
qed

subsection \<open>The terminal globular set\<close>

text \<open>The terminal globular set, with a unique m-cell for each m \cite[p. 264]{Leinster2004}.\<close>

interpretation final_glob: globular_set "\<lambda>m. {()}" "\<lambda>m. id" "\<lambda>m. id"
  by (unfold_locales, auto)

context globular_set
begin

text \<open>\cite[p. 272]{Leinster2004}\<close>

interpretation map_to_final_glob: globular_map X s t
  "\<lambda>m. {()}" "\<lambda>m. id" "\<lambda>m. id"
  "\<lambda>m. (\<lambda>x. ())"
  by (unfold_locales, simp_all)

end

end


theory Set_Monad
imports
  Main
  "~~/src/HOL/Library/Monad_Syntax"
begin

lemma member_SUP: (* FIXME delete candidate: should be subsumed by default simpset as soon as SUP_apply is included *)
  "x \<in> UNION A f = (SUP B:A. (\<lambda>x. x \<in> f B)) x"
  by auto

abbreviation (input) "of_pred == Predicate.set_of_pred" (* FIXME delte alias *)
abbreviation (input) "of_seq == Predicate.set_of_seq" (* FIXME delte alias *)

lemmas bind_def = Set.bind_def (* FIXME delte alias *)
lemmas bind_bind = Set.bind_bind (* FIXME delte alias *)
lemmas empty_bind = Set.empty_bind (* FIXME delte alias *)
lemmas bind_const = Set.bind_const (* FIXME delte alias *)
lemmas member_of_pred = Predicate.member_set_of_pred (* FIXME delte alias *)
lemmas member_of_seq = Predicate.member_set_of_seq (* FIXME delte alias *)

definition single :: "'a \<Rightarrow> 'a set"
  where "single a = {a}"

definition undefined :: "'a set"
  where [simp]: "undefined = Collect HOL.undefined"

declare [[code abort: undefined]]

definition Undefined :: "unit \<Rightarrow> 'a set"
  where "Undefined _ = Collect HOL.undefined"

declare [[code abort: Undefined]]

lemma undefined_code [code_unfold]:
  "undefined = Undefined ()"
  by (simp add: Undefined_def)

lemma bind_single [simp, code_unfold]:
  "A \<guillemotright>= single = A"
  by (simp add: bind_def single_def)

lemma single_bind [simp, code_unfold]:
  "single a \<guillemotright>= B = B a"
  by (simp add: bind_def single_def)

declare Set.empty_bind [code_unfold]

lemma member_single [simp]:
  "x \<in> single a <-> x = a"
by (simp add: single_def)

lemma single_sup_simps [simp, code_unfold]:
  shows single_sup: "sup (single a) A = insert a A"
  and sup_single: "sup A (single a) = insert a A"
  by (unfold set_eq_iff) auto

end


(*  Title:       Tree Automata
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header "Abstract Tree Automata Algorithms"
theory AbsAlgo
imports
  Ta
  "../Collections/Examples/ICF/Exploration"
  "../Collections/ICF/CollectionsV1"
begin

no_notation fun_rel_syn (infixr "\<rightarrow>" 60)

text_raw {*\label{sec:absalgo}*}
text {* This theory defines tree automata algorithms on an abstract level,
  that is using non-executable datatypes and constructs like sets,
  set-collecting operations, etc.

  These algorithms are then refined to executable algorithms in
  Section~\ref{sec:taimpl}.
  *}

subsection {* Word Problem *}

text {*
  First, a recursive version of the @{const accs}-predicate is defined.
*}

fun r_match :: "'a set list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "r_match [] [] \<longleftrightarrow> True" |
  "r_match (A#AS) (a#as) \<longleftrightarrow> a\<in>A \<and> r_match AS as" |
  "r_match _ _ \<longleftrightarrow> False"

-- {* @{const r_match} accepts two lists, if they have the same length and
  the elements in the second list are contained in the respective
  elements of the first list: *}
lemma r_match_alt:
  "r_match L l \<longleftrightarrow> length L = length l \<and> (\<forall>i<length l. l!i \<in> L!i)"
  apply (induct L l rule: r_match.induct)
  apply auto
  apply (case_tac i)
  apply auto
  done

-- "Whether a rule matches the given state, label and list of sets of states"
fun r_matchc where
  "r_matchc q l Qs (qr \<rightarrow> lr qsr) \<longleftrightarrow> q=qr \<and> l=lr \<and> r_match Qs qsr"

-- {* recursive version of @{const accs}-predicate *}
fun faccs :: "('Q,'L) ta_rule set \<Rightarrow> 'L tree \<Rightarrow> 'Q set" where
  "faccs \<delta> (NODE f ts) = (
    let Qs = map (faccs \<delta>) (ts) in
      {q. \<exists>r\<in>\<delta>. r_matchc q f Qs r }
  )"

lemma faccs_correct_aux:
  "q\<in>faccs \<delta> n = accs \<delta> n q" (is ?T1)
  "(map (faccs \<delta>) ts = map (\<lambda>t. { q . accs \<delta> t q}) ts)" (is ?T2)
proof -
  have "(\<forall>q. q\<in>faccs \<delta> n = accs \<delta> n q)
        \<and> (map (faccs \<delta>) ts = map (\<lambda>t. { q . accs \<delta> t q}) ts)"
  proof (induct rule: compat_tree_tree_list.induct)
    case (NODE f ts)
    thus ?case
      apply (intro allI iffI)
      apply simp
      apply (erule bexE)
      apply (case_tac x)
      apply simp
      apply (rule accs.intros)
      apply assumption
      apply (unfold r_match_alt)
      apply simp
      apply fastforce
      apply simp
      apply (erule accs.cases)
      apply auto
      apply (rule_tac x="qa \<rightarrow> f qs" in bexI)
      apply simp
      apply (unfold r_match_alt)
      apply auto
      done
  qed auto
  thus ?T1 ?T2 by auto
qed

theorem faccs_correct1: "q\<in>faccs \<delta> n \<Longrightarrow> accs \<delta> n q"
  by (simp add: faccs_correct_aux)
theorem faccs_correct2: "accs \<delta> n q \<Longrightarrow> q\<in>faccs \<delta> n"
  by (simp add: faccs_correct_aux)

theorems faccs_correct = faccs_correct1 faccs_correct2

lemma faccs_alt: "faccs \<delta> t = {q. accs \<delta> t q}" by (auto intro: faccs_correct)

subsection {* Backward Reduction and Emptiness Check *}
subsubsection "Auxiliary Definitions"

-- {*
  Step function, that maps a set of states to those states
  that are reachable via one backward step.
  *}
inductive_set bacc_step :: "('Q,'L) ta_rule set \<Rightarrow> 'Q set \<Rightarrow> 'Q set"
  for \<delta> Q
  where
  "\<lbrakk> r\<in>\<delta>; set (rhsq r) \<subseteq> Q \<rbrakk> \<Longrightarrow> lhs r \<in> bacc_step \<delta> Q"

-- {*
  If a set is closed under adding all states that are reachable from the set
  by one backward step, then this set contains all backward accessible states.
  *}
lemma b_accs_as_closed:
  assumes A: "bacc_step \<delta> Q \<subseteq> Q"
  shows "b_accessible \<delta> \<subseteq> Q"
proof (rule subsetI)
  fix q
  assume "q\<in>b_accessible \<delta>"
  thus "q\<in>Q"
  proof (induct rule: b_accessible.induct)
    fix q f qs
    assume BC: "(q\<rightarrow>f qs)\<in>\<delta>"
               "!!x. x\<in>set qs \<Longrightarrow> x\<in>b_accessible \<delta>"
               "!!x. x\<in>set qs \<Longrightarrow> x\<in>Q"
    from bacc_step.intros[OF BC(1)] BC(3) have "q\<in>bacc_step \<delta> Q" by auto
    with A show "q\<in>Q" by blast
  qed
qed

subsubsection "Algorithms"

text {*
  First, the basic workset algorithm is specified.
  Then, it is refined to contain a counter for each rule,
  that counts the number of undiscovered states on the RHS.
  For both levels of abstraction, a version that computes the
  backwards reduction, and a version that checks for emptiness is specified.

  Additionally, a version of the algorithm that computes a witness
  for non-emptiness is provided.

  Levels of abstraction:
  \begin{itemize}
    \item[@{text \<alpha>}] On this level, the state consists of a set of
      discovered states and a workset.
    \item[@{text \<alpha>'}] On this level, the state consists of a set of
      discovered states, a workset and a map from rules to number of
      undiscovered rhs states. This map can be used to make the discovery of
      rules that have to be considered more efficient.
  \end{itemize}
*}

text_raw {* \paragraph {@{text \<alpha>} - Level:} *}

  -- "A state contains the set of discovered states and a workset"
type_synonym ('Q,'L) br_state = "'Q set \<times> 'Q set"

  -- {* Set of states that are non-empty (accept a tree) after adding the
  state $q$ to the set of discovered states *}
definition br_dsq
  :: "('Q,'L) ta_rule set \<Rightarrow> 'Q \<Rightarrow> ('Q,'L) br_state \<Rightarrow> 'Q set"
  where
  "br_dsq \<delta> q == \<lambda>(Q,W). { lhs r | r. r\<in>\<delta> \<and> set (rhsq r) \<subseteq> (Q-(W-{q})) }"

  -- {*
  Description of a step: One state is removed from the workset, and all
  new states that become non-empty due to this state are added to, both,
  the workset and the set of discovered states *}
inductive_set br_step
  :: "('Q,'L) ta_rule set \<Rightarrow> (('Q,'L) br_state \<times> ('Q,'L) br_state) set"
  for \<delta> where
  "\<lbrakk>
     q\<in>W;
     Q' = Q \<union> br_dsq \<delta> q (Q,W);
     W' = W - {q} \<union> (br_dsq \<delta> q (Q,W) - Q)
   \<rbrakk> \<Longrightarrow> ((Q,W),(Q',W'))\<in>br_step \<delta>"

  -- "Termination condition for backwards reduction: The workset is empty"
definition br_cond :: "('Q,'L) br_state set"
  where "br_cond == {(Q,W). W\<noteq>{}}"

  -- "Termination condition for emptiness check:
      The workset is empty or a non-empty initial state has been discovered"
definition bre_cond :: "'Q set \<Rightarrow> ('Q,'L) br_state set"
  where "bre_cond Qi == {(Q,W). W\<noteq>{} \<and> (Qi\<inter>Q={})}"

  -- "Set of all states that occur on the lhs of a constant-rule"
definition br_iq :: "('Q,'L) ta_rule set \<Rightarrow> 'Q set"
  where "br_iq \<delta> == { lhs r | r. r\<in>\<delta> \<and> rhsq r = [] }"

  -- "Initial state for the iteration"
definition br_initial :: "('Q,'L) ta_rule set \<Rightarrow> ('Q,'L) br_state"
  where "br_initial \<delta> == (br_iq \<delta>, br_iq \<delta>)"

  -- {*
  Invariant for the iteration:
    \begin{itemize}
      \item States on the workset have been discovered
      \item Only accessible states have been discovered
      \item If a state is non-empty due to a rule whose
            rhs-states have been discovered and processed
            (i.e. are in $Q-W$), then the lhs state of the
            rule has also been discovered.
      \item The set of discovered states is finite
    \end{itemize}
  *}
definition br_invar :: "('Q,'L) ta_rule set \<Rightarrow> ('Q,'L) br_state set"
  where "br_invar \<delta> == {(Q,W).
    W\<subseteq>Q \<and>
    Q \<subseteq> b_accessible \<delta> \<and>
    bacc_step \<delta> (Q - W) \<subseteq> Q \<and>
    finite Q}"

definition "br_algo \<delta> == \<lparr>
  wa_cond = br_cond,
  wa_step = br_step \<delta>,
  wa_initial = {br_initial \<delta>},
  wa_invar = br_invar \<delta>
\<rparr>"

definition "bre_algo Qi \<delta> == \<lparr>
  wa_cond = bre_cond Qi,
  wa_step = br_step \<delta>,
  wa_initial = {br_initial \<delta>},
  wa_invar = br_invar \<delta>
\<rparr>"

  -- {* Termination: Either a new state is added, or the workset decreases. *}
definition "br_termrel \<delta> ==
  ({(Q',Q). Q \<subset> Q' \<and> Q' \<subseteq> b_accessible \<delta>}) <*lex*> finite_psubset"

lemma bre_cond_imp_br_cond[intro, simp]: "bre_cond Qi \<subseteq> br_cond"
  by (auto simp add: br_cond_def bre_cond_def)

  -- "Only accessible states are discovered"
lemma br_dsq_ss:
  assumes A: "(Q,W)\<in>br_invar \<delta>" "W \<noteq> {}" "q\<in>W"
  shows "br_dsq \<delta> q (Q,W) \<subseteq> b_accessible \<delta>"
proof (rule subsetI)
  fix q'
  assume B: "q'\<in>br_dsq \<delta> q (Q,W)"
  then obtain r where
    R: "q' = lhs r" "r\<in>\<delta>" and
    S: "set (rhsq r) \<subseteq> (Q-(W-{q}))"
    by (unfold br_dsq_def) auto
  note S
  also have "(Q-(W-{q})) \<subseteq> b_accessible \<delta>" using A(1,3)
    by (auto simp add: br_invar_def)
  finally show "q'\<in>b_accessible \<delta>" using R
    by (cases r)
  (auto intro: b_accessible.intros)
qed

lemma br_step_in_termrel:
  assumes A: "\<Sigma>\<in>br_cond" "\<Sigma>\<in>br_invar \<delta>" "(\<Sigma>,\<Sigma>')\<in>br_step \<delta>"
  shows "(\<Sigma>', \<Sigma>)\<in>br_termrel \<delta>"
proof -
  obtain Q W Q' W' where
    [simp]: "\<Sigma>=(Q,W)" "\<Sigma>'=(Q',W')"
    by (cases \<Sigma>, cases \<Sigma>', auto)
  obtain q where
    QIW: "q\<in>W" and
    ASSFMT[simp]: "Q' = Q \<union> br_dsq \<delta> q (Q, W)"
                  "W' = W - {q} \<union> (br_dsq \<delta> q (Q, W) - Q)"
    by (auto intro: br_step.cases[OF A(3)[simplified]])

  from A(2) have [simp]: "finite Q"
    by (auto simp add: br_invar_def)
  from A(2)[unfolded br_invar_def] have [simp]: "finite W"
    by (auto simp add: finite_subset)
  from A(1) have WNE: "W\<noteq>{}" by (unfold br_cond_def) auto

  note DSQSS = br_dsq_ss[OF A(2)[simplified] WNE QIW]
  {
    assume "br_dsq \<delta> q (Q,W) - Q = {}"
    hence ?thesis using QIW
      by (simp add: br_termrel_def set_simps)
  } moreover {
    assume "br_dsq \<delta> q (Q,W) - Q \<noteq> {}"
    hence "Q \<subset> Q'" by auto
    moreover from DSQSS A(2)[unfolded br_invar_def] have
      "Q' \<subseteq> b_accessible \<delta>"
      by auto
    ultimately have ?thesis
      by (simp add: br_termrel_def)
  } ultimately show ?thesis by blast
qed

lemma br_invar_initial[simp]: "finite \<delta> \<Longrightarrow> (br_initial \<delta>)\<in>br_invar \<delta>"
  apply (auto simp add: br_initial_def br_invar_def br_iq_def)

  apply (case_tac r)
  apply (fastforce intro: b_accessible.intros)
  apply (fastforce elim!: bacc_step.cases)
  done

lemma br_invar_step:
  assumes [simp]: "finite \<delta>"
  assumes A: "\<Sigma>\<in>br_cond" "\<Sigma>\<in>br_invar \<delta>" "(\<Sigma>,\<Sigma>')\<in>br_step \<delta>"
  shows "\<Sigma>'\<in>br_invar \<delta>"
proof -
  obtain Q W Q' W' where SF[simp]: "\<Sigma>=(Q,W)" "\<Sigma>'=(Q',W')"
    by (cases \<Sigma>, cases \<Sigma>', auto)
  obtain q where
    QIW: "q\<in>W" and
    ASSFMT[simp]: "Q' = Q \<union> br_dsq \<delta> q (Q, W)"
                  "W' = W - {q} \<union> (br_dsq \<delta> q (Q, W) - Q)"
    by (auto intro: br_step.cases[OF A(3)[simplified]])

  from A(1) have WNE: "W\<noteq>{}" by (unfold br_cond_def) auto

  have DSQSS: "br_dsq \<delta> q (Q,W) \<subseteq> b_accessible \<delta>"
    using br_dsq_ss[OF A(2)[simplified] WNE QIW] .

  show ?thesis
    apply (simp add: br_invar_def del: ASSFMT)
  proof (intro conjI)
    from A(2) have "W \<subseteq> Q" by (simp add: br_invar_def)
    thus "W' \<subseteq> Q'" by auto
  next
    from A(2) have "Q \<subseteq> b_accessible \<delta>" by (simp add: br_invar_def)
    with DSQSS show "Q' \<subseteq> b_accessible \<delta>" by auto
  next
    show "bacc_step \<delta> (Q' - W') \<subseteq> Q'"
      apply (rule subsetI)
      apply (erule bacc_step.cases)
      apply (auto simp add: br_dsq_def)
      done
  next
    show "finite Q'" using A(2) by (simp add: br_invar_def br_dsq_def)
  qed
qed

lemma br_invar_final:
  "\<forall>\<Sigma>. \<Sigma>\<in>wa_invar (br_algo \<delta>) \<and> \<Sigma>\<notin>wa_cond (br_algo \<delta>)
   \<longrightarrow> fst \<Sigma> = b_accessible \<delta>"
  apply (simp add: br_invar_def br_cond_def br_algo_def)
  apply (auto intro: set_rev_mp[OF _ b_accs_as_closed])
  done
(*  shows "\<lbrakk>(Q,W)\<in>br_invar \<delta>; (Q,W)\<notin>br_cond\<rbrakk> \<Longrightarrow> Q = b_accessible \<delta>"
  apply (simp add: br_invar_def br_cond_def)
  apply (auto intro: set_rev_mp[OF _ b_accs_as_closed])
  done*)

theorem br_while_algo:
  assumes FIN[simp]: "finite \<delta>"
  shows "while_algo (br_algo \<delta>)"
  apply (unfold_locales)
  apply (simp_all add: br_algo_def br_invar_step br_invar_initial
                       br_step_in_termrel)
  apply (rule_tac r="br_termrel \<delta>" in wf_subset)
  apply (auto intro: br_step_in_termrel)
  done

lemma bre_invar_final:
  "\<forall>\<Sigma>. \<Sigma>\<in>wa_invar (bre_algo Qi \<delta>) \<and> \<Sigma>\<notin>wa_cond (bre_algo Qi \<delta>)
     \<longrightarrow> ((Qi\<inter>fst \<Sigma>={}) \<longleftrightarrow> (Qi \<inter> b_accessible \<delta> = {}))"
  apply (simp add: br_invar_def bre_cond_def bre_algo_def)
  apply safe
  apply (auto dest!: b_accs_as_closed)
  done

theorem bre_while_algo:
  assumes FIN[simp]: "finite \<delta>"
  shows "while_algo (bre_algo Qi \<delta>)"
  apply (unfold_locales)
  apply (unfold bre_algo_def)
  apply (auto simp add: br_invar_initial br_step_in_termrel
    intro: br_invar_step
    dest: set_rev_mp[OF _ bre_cond_imp_br_cond])
  apply (rule_tac r="br_termrel \<delta>" in wf_subset)
  apply (auto intro: br_step_in_termrel
              dest: set_rev_mp[OF _ bre_cond_imp_br_cond])
  done

text_raw {* \paragraph{@{text \<alpha>'} - Level} *}
text {*
  Here, an optimization is added:
    For each rule, the algorithm now maintains a counter that counts the number
    of undiscovered states on the rules RHS. Whenever a new state is discovered,
    this counter is decremented for all rules where the state occurs on the RHS.
    The LHS states of rules where the counter falls to 0 are added to the
    worklist. The idea is that decrementing the counter is more efficient than
    checking whether all states on the rule's RHS have been discovered.

  A similar algorithm is sketched in \cite{tata2007}(Exercise~1.18).
*}
type_synonym ('Q,'L) br'_state = "'Q set \<times> 'Q set \<times> (('Q,'L) ta_rule \<rightharpoonup> nat)"

  -- {* Abstraction to @{text \<alpha>}-level *}
definition br'_\<alpha> :: "('Q,'L) br'_state \<Rightarrow> ('Q,'L) br_state"
  where "br'_\<alpha> = (\<lambda>(Q,W,rcm). (Q,W))"

definition br'_invar_add :: "('Q,'L) ta_rule set \<Rightarrow> ('Q,'L) br'_state set"
  where "br'_invar_add \<delta> == {(Q,W,rcm).
    (\<forall>r\<in>\<delta>. rcm r = Some (card (set (rhsq r) - (Q - W)))) \<and>
    {lhs r | r. r\<in>\<delta> \<and> the (rcm r) = 0} \<subseteq> Q
  }"

definition br'_invar :: "('Q,'L) ta_rule set \<Rightarrow> ('Q,'L) br'_state set"
  where "br'_invar \<delta> == br'_invar_add \<delta> \<inter> {\<Sigma>. br'_\<alpha> \<Sigma> \<in> br_invar \<delta>}"

inductive_set br'_step
  :: "('Q,'L) ta_rule set \<Rightarrow> (('Q,'L) br'_state \<times> ('Q,'L) br'_state) set"
  for \<delta> where
  "\<lbrakk> q\<in>W;
     Q' = Q \<union> { lhs r | r. r\<in>\<delta> \<and> q \<in> set (rhsq r) \<and> the (rcm r) \<le> 1 };
     W' = (W-{q})
          \<union> ({ lhs r | r. r\<in>\<delta> \<and> q \<in> set (rhsq r) \<and> the (rcm r) \<le> 1 }
              - Q);
     !!r. r\<in>\<delta> \<Longrightarrow> rcm' r = ( if q \<in> set (rhsq r) then
                               Some (the (rcm r) - 1)
                             else rcm r
                           )
   \<rbrakk> \<Longrightarrow> ((Q,W,rcm),(Q',W',rcm')) \<in> br'_step \<delta>"

definition br'_cond :: "('Q,'L) br'_state set"
  where "br'_cond == {(Q,W,rcm). W\<noteq>{}}"
definition bre'_cond :: "'Q set \<Rightarrow> ('Q,'L) br'_state set"
  where "bre'_cond Qi == {(Q,W,rcm). W\<noteq>{} \<and> (Qi\<inter>Q={})}"

inductive_set br'_initial :: "('Q,'L) ta_rule set \<Rightarrow> ('Q,'L) br'_state set"
  for \<delta> where
  "\<lbrakk> !!r. r\<in>\<delta> \<Longrightarrow> rcm r = Some (card (set (rhsq r))) \<rbrakk>
     \<Longrightarrow> (br_iq \<delta>, br_iq \<delta>, rcm)\<in>br'_initial \<delta>"

definition "br'_algo \<delta> == \<lparr>
  wa_cond=br'_cond,
  wa_step = br'_step \<delta>,
  wa_initial = br'_initial \<delta>,
  wa_invar = br'_invar \<delta>
\<rparr>"

definition "bre'_algo Qi \<delta> == \<lparr>
  wa_cond=bre'_cond Qi,
  wa_step = br'_step \<delta>,
  wa_initial = br'_initial \<delta>,
  wa_invar = br'_invar \<delta>
\<rparr>"

lemma br'_step_invar:
  assumes finite[simp]: "finite \<delta>"
  assumes INV: "\<Sigma>\<in>br'_invar_add \<delta>" "br'_\<alpha> \<Sigma> \<in> br_invar \<delta>"
  assumes STEP: "(\<Sigma>,\<Sigma>') \<in> br'_step \<delta>"
  shows "\<Sigma>'\<in>br'_invar_add \<delta>"
proof -
  obtain Q W rcm where [simp]: "\<Sigma>=(Q,W,rcm)"
    by (cases \<Sigma>) auto
  obtain Q' W' rcm' where [simp]: "\<Sigma>'=(Q',W',rcm')"
    by (cases \<Sigma>') auto

  from STEP obtain q where
    STEPF:
    "q\<in>W"
    "Q' = Q \<union> { lhs r | r. r\<in>\<delta> \<and> q \<in> set (rhsq r) \<and> the (rcm r) \<le> 1 }"
    "W' = (W-{q})
          \<union> ({ lhs r | r. r\<in>\<delta> \<and> q \<in> set (rhsq r) \<and> the (rcm r) \<le> 1 }
              - Q)"
    "!!r. r\<in>\<delta> \<Longrightarrow> rcm' r = ( if q \<in> set (rhsq r) then
                               Some (the (rcm r) - 1)
                             else rcm r
                           )"
    by (auto elim: br'_step.cases)

  from INV[unfolded br'_invar_def br_invar_def br'_invar_add_def br'_\<alpha>_def,
           simplified]
  have INV:
    "(\<forall>r\<in>\<delta>. rcm r = Some (card (set (rhsq r) - (Q - W))))"
    "{lhs r |r. r \<in> \<delta> \<and> the (rcm r) = 0} \<subseteq> Q"
    "W \<subseteq> Q"
    "Q \<subseteq> b_accessible \<delta>"
    "bacc_step \<delta> (Q - W) \<subseteq> Q"
    "finite Q"
    by auto

  {
    fix r
    assume A: "r\<in>\<delta>"
    with INV(1) have RCMR: "rcm r = Some (card (set (rhsq r) - (Q - W)))"
      by auto

    have "rcm' r = Some (card (set (rhsq r) - (Q' - W')))"
    proof (cases "q\<in>set (rhsq r)")
      case False
      with A STEPF(4) have "rcm' r = rcm r" by auto
      moreover from STEPF INV(3) False have
        "set (rhsq r) - (Q-W) = set (rhsq r) - (Q'-W')"
        by auto
      ultimately show ?thesis
        by (simp add: RCMR)
    next
      case True
      with A STEPF(4) RCMR have
        "rcm' r = Some ((card (set (rhsq r) - (Q - W))) - 1)"
        by simp
      moreover from STEPF INV(3) True have
        "set (rhsq r) - (Q-W) = insert q (set (rhsq r) - (Q'-W'))"
        "q\<notin>(set (rhsq r) - (Q'-W'))"
        by auto
      ultimately show ?thesis
        by (simp add: RCMR card_insert_disjoint')
    qed
  } moreover {
    fix r
    assume A: "r\<in>\<delta>" "the (rcm' r) = 0"
    have "lhs r \<in> Q'" proof (cases "q\<in>set (rhsq r)")
      case True
      with A(1) STEPF(4) have "rcm' r = Some (the (rcm r) - 1)" by auto
      with A(2) have "the (rcm r) - 1 = 0" by auto
      hence "the (rcm r) \<le> 1" by auto
      with STEPF(2) A(1) True show ?thesis by auto
    next
      case False
      with A(1) STEPF(4) have "rcm' r = rcm r" by auto
      with A(2) have "the (rcm r) = 0" by auto
      with A(1) INV(2) have "lhs r \<in> Q" by auto
      with STEPF(2) show ?thesis by auto
    qed
  } ultimately show ?thesis
    by (auto simp add: br'_invar_add_def)
qed

lemma br'_invar_initial:
  "br'_initial \<delta> \<subseteq> br'_invar_add \<delta>"
  apply safe
  apply (erule br'_initial.cases)
  apply (unfold br'_invar_add_def)
  apply (auto simp add: br_iq_def)
  done

lemma br'_rcm_aux':
  "\<lbrakk> (Q,W,rcm)\<in>br'_invar \<delta>; q\<in>W \<rbrakk>
    \<Longrightarrow> {r \<in> \<delta>. q \<in> set (rhsq r) \<and> the (rcm r) \<le> Suc 0}
         = {r\<in>\<delta>. q\<in>set (rhsq r) \<and> set (rhsq r) \<subseteq> (Q - (W-{q}))}"
proof (intro subsetI equalityI)
  case (goal1 r)
  hence  B: "r\<in>\<delta>" "q\<in>set (rhsq r)" "the (rcm r) \<le> Suc 0" by auto
  from B(1,3) goal1(1)[unfolded br'_invar_def br'_invar_add_def] have
    CARD: "card (set (rhsq r) - (Q - W)) \<le> Suc 0"
    by auto
  from goal1(1)[unfolded br'_invar_def br_invar_def br'_\<alpha>_def] have WSQ: "W\<subseteq>Q"
    by auto
  have "set (rhsq r) - (Q - W) = {q}"
  proof -
    from B(2) goal1(2) have R1: "q\<in>set (rhsq r) - (Q - W)" by auto
    moreover
    {
      fix x
      assume A: "x\<noteq>q" "x\<in>set (rhsq r) - (Q - W)"
      with R1 have "{x,q} \<subseteq> set (rhsq r) - (Q - W)" by auto
      hence "card {x,q} \<le> card (set (rhsq r) - (Q - W))"
        by (auto simp add: card_mono)
      with CARD A(1) have False by auto
    }
    ultimately show ?thesis by auto
  qed
  with goal1(2) WSQ have "set (rhsq r) \<subseteq> Q - (W - {q})" by auto
  thus ?case using B(1,2) by auto
next
  case (goal2 r)
  hence B: "r\<in>\<delta>" "q\<in>set (rhsq r)" "set (rhsq r) \<subseteq> Q - (W - {q})" by auto
  with goal2(1)[unfolded br'_invar_def br'_invar_add_def
                         br'_\<alpha>_def br_invar_def]
  have
    IC: "W\<subseteq>Q" "the (rcm r) = card (set (rhsq r) - (Q - W))"
    by auto
  have "set (rhsq r) - (Q - W) \<subseteq> {q}" using B(2,3) IC(1) by auto
  from card_mono[OF _ this] have "the (rcm r) \<le> Suc 0" by (simp add: IC(2))
  with B(1,2) show ?case by auto
qed

lemma br'_rcm_aux:
  assumes A: "(Q,W,rcm)\<in>br'_invar \<delta>" "q\<in>W"
  shows "{lhs r |r. r \<in> \<delta> \<and> q \<in> set (rhsq r) \<and> the (rcm r) \<le> Suc 0}
         = {lhs r | r. r\<in>\<delta> \<and> q\<in>set (rhsq r) \<and> set (rhsq r) \<subseteq> (Q - (W-{q}))}"
proof -
  have "{lhs r |r. r \<in> \<delta> \<and> q \<in> set (rhsq r) \<and> the (rcm r) \<le> Suc 0}
        = lhs ` {r \<in> \<delta>. q \<in> set (rhsq r) \<and> the (rcm r) \<le> Suc 0}"
    by auto
  also from br'_rcm_aux'[OF A] have
    "\<dots> = lhs ` {r \<in> \<delta>. q \<in> set (rhsq r) \<and> set (rhsq r) \<subseteq> Q - (W - {q})}"
    by simp
  also have
    "\<dots> = {lhs r | r. r\<in>\<delta> \<and> q\<in>set (rhsq r) \<and> set (rhsq r) \<subseteq> (Q - (W-{q}))}"
    by auto
  finally show ?thesis .
qed

lemma br'_invar_QcD:
  "(Q,W,rcm) \<in> br'_invar \<delta> \<Longrightarrow> {lhs r | r. r\<in>\<delta> \<and> set (rhsq r) \<subseteq> (Q-W)} \<subseteq> Q"
proof (safe)
  fix r
  assume A: "(Q,W,rcm)\<in>br'_invar \<delta>" "r\<in>\<delta>" "set (rhsq r) \<subseteq> Q - W"
  from A(1)[unfolded br'_invar_def br'_invar_add_def br'_\<alpha>_def br_invar_def,
            simplified]
  have
    IC: "W \<subseteq> Q"
        "finite Q"
        "(\<forall>r\<in>\<delta>. rcm r = Some (card (set (rhsq r) - (Q - W))))"
        "{lhs r |r. r \<in> \<delta> \<and> the (rcm r) = 0} \<subseteq> Q" by auto
  from IC(3) A(2,3) have "the (rcm r) = 0" by auto
  with IC(4) A(2) show "lhs r \<in> Q" by auto
qed

lemma br'_rcm_aux2:
  "\<lbrakk> (Q,W,rcm)\<in>br'_invar \<delta>; q\<in>W \<rbrakk>
    \<Longrightarrow> Q \<union> br_dsq \<delta> q (Q,W)
        = Q \<union> {lhs r |r. r \<in> \<delta> \<and> q \<in> set (rhsq r) \<and> the (rcm r) \<le> Suc 0}"
  apply (simp only: br'_rcm_aux)
  apply (unfold br_dsq_def)
  apply simp
  apply (frule br'_invar_QcD)
  apply auto
  done

lemma br'_rcm_aux3:
  "\<lbrakk> (Q,W,rcm)\<in>br'_invar \<delta>; q\<in>W \<rbrakk>
    \<Longrightarrow> br_dsq \<delta> q (Q,W) - Q
        = {lhs r |r. r \<in> \<delta> \<and> q \<in> set (rhsq r) \<and> the (rcm r) \<le> Suc 0} - Q"
  apply (simp only: br'_rcm_aux)
  apply (unfold br_dsq_def)
  apply simp
  apply (frule br'_invar_QcD)
  apply auto
  done

lemma br'_step_abs:
  "\<lbrakk>
     \<Sigma>\<in>br'_invar \<delta>;
     (\<Sigma>,\<Sigma>') \<in> br'_step \<delta>
   \<rbrakk> \<Longrightarrow> (br'_\<alpha> \<Sigma>, br'_\<alpha> \<Sigma>')\<in>br_step \<delta>"
  apply (cases \<Sigma>, cases \<Sigma>', simp)
  apply (erule br'_step.cases)
  apply (simp add: br'_\<alpha>_def)
  apply (rule_tac q=q in br_step.intros)
  apply simp
  apply (simp only: br'_rcm_aux2)
  apply (simp only: br'_rcm_aux3)
  done

lemma br'_initial_abs: "br'_\<alpha>`(br'_initial \<delta>) = {br_initial \<delta>}"
  apply (force simp add: br_initial_def br'_\<alpha>_def
               elim: br'_initial.cases
               intro: br'_initial.intros)
  done

lemma br'_cond_abs: "\<Sigma>\<in>br'_cond \<longleftrightarrow> (br'_\<alpha> \<Sigma>) \<in> br_cond"
  by (cases \<Sigma>)
     (simp add: br'_cond_def br_cond_def br'_\<alpha>_def image_Collect
                br'_algo_def br_algo_def)

lemma bre'_cond_abs: "\<Sigma>\<in>bre'_cond Qi \<longleftrightarrow> (br'_\<alpha> \<Sigma>)\<in>bre_cond Qi"
  by (cases \<Sigma>) (simp add: bre'_cond_def bre_cond_def br'_\<alpha>_def image_Collect
                          bre'_algo_def bre_algo_def)

lemma br'_invar_abs: "br'_\<alpha>`br'_invar \<delta> \<subseteq> br_invar \<delta>"
  by (auto simp add: br'_invar_def)

theorem br'_pref_br: "wa_precise_refine (br'_algo \<delta>) (br_algo \<delta>) br'_\<alpha>"
  apply unfold_locales
  apply (simp_all add: br'_algo_def br_algo_def)
  apply (simp_all add: br'_cond_abs br'_step_abs br'_invar_abs br'_initial_abs)
  done

interpretation br'_pref: wa_precise_refine "br'_algo \<delta>" "br_algo \<delta>" "br'_\<alpha>"
  using br'_pref_br .

theorem br'_while_algo:
  "finite \<delta> \<Longrightarrow> while_algo (br'_algo \<delta>)"
  apply (rule br'_pref.wa_intro)
  apply (simp add: br_while_algo)
  apply (simp_all add: br'_algo_def br_algo_def)
  apply (simp add: br'_invar_def)
  apply (erule (3) br'_step_invar)
  apply (simp add: br'_invar_initial)
  done

lemma fst_br'_\<alpha>: "fst (br'_\<alpha> s) = fst s" by (cases s) (simp add: br'_\<alpha>_def)

theorems br'_invar_final =
  br'_pref.transfer_correctness[OF br_invar_final, unfolded fst_br'_\<alpha>]

theorem bre'_pref_br: "wa_precise_refine (bre'_algo Qi \<delta>) (bre_algo Qi \<delta>) br'_\<alpha>"
  apply unfold_locales
  apply (simp_all add: bre'_algo_def bre_algo_def)
  apply (simp_all add: bre'_cond_abs br'_step_abs br'_invar_abs br'_initial_abs)
  done

interpretation bre'_pref:
  wa_precise_refine "bre'_algo Qi \<delta>" "bre_algo Qi \<delta>" "br'_\<alpha>"
  using bre'_pref_br .

theorem bre'_while_algo:
  "finite \<delta> \<Longrightarrow> while_algo (bre'_algo Qi \<delta>)"
  apply (rule bre'_pref.wa_intro)
  apply (simp add: bre_while_algo)
  apply (simp_all add: bre'_algo_def bre_algo_def)
  apply (simp add: br'_invar_def)
  apply (erule (3) br'_step_invar)
  apply (simp add: br'_invar_initial)
  done

theorems bre'_invar_final =
  bre'_pref.transfer_correctness[OF bre_invar_final, unfolded fst_br'_\<alpha>]

text_raw {* \paragraph{Implementing a Step} *}
text {*
  In this paragraph, it is shown how to implement a step of the br'-algorithm
  by iteration over the rules that have the discovered state on their RHS.
*}

definition br'_inner_step
  :: "('Q,'L) ta_rule \<Rightarrow> ('Q,'L) br'_state \<Rightarrow> ('Q,'L) br'_state"
  where
  "br'_inner_step == \<lambda>r (Q,W,rcm). let c=the (rcm r) in (
    if c\<le>1 then insert (lhs r) Q else Q,
    if c\<le>1 \<and> (lhs r) \<notin> Q then insert (lhs r) W else W,
    rcm ( r \<mapsto> (c-(1::nat)))
  )
"

definition br'_inner_invar
  :: "('Q,'L) ta_rule set \<Rightarrow> 'Q \<Rightarrow> ('Q,'L) br'_state
      \<Rightarrow> ('Q,'L) ta_rule set \<Rightarrow> ('Q,'L) br'_state \<Rightarrow> bool"
  where
  "br'_inner_invar rules q == \<lambda>(Q,W,rcm) it (Q',W',rcm').
    Q' = Q \<union> { lhs r | r. r\<in>rules-it \<and> the (rcm r) \<le> 1 } \<and>
    W' = (W-{q}) \<union> ({ lhs r | r. r\<in>rules-it \<and> the (rcm r) \<le> 1 } - Q) \<and>
    (\<forall>r. rcm' r = (if r\<in>rules-it then Some (the (rcm r) - 1) else rcm r))
  "

lemma br'_inner_invar_imp_final:
  "\<lbrakk> q\<in>W; br'_inner_invar {r\<in>\<delta>. q\<in>set (rhsq r)} q (Q,W-{q},rcm) {} \<Sigma>' \<rbrakk>
     \<Longrightarrow> ((Q,W,rcm),\<Sigma>') \<in> br'_step \<delta>"
  apply (unfold br'_inner_invar_def)
  apply auto
  apply (rule br'_step.intros)
  apply assumption
  apply auto
  done

lemma br'_inner_invar_step:
  "\<lbrakk> q\<in>W; br'_inner_invar {r\<in>\<delta>. q\<in>set (rhsq r)} q (Q,W-{q},rcm) it \<Sigma>';
     r\<in>it; it\<subseteq>{r\<in>\<delta>. q\<in>set (rhsq r)}
   \<rbrakk> \<Longrightarrow> br'_inner_invar {r\<in>\<delta>. q\<in>set (rhsq r)} q (Q,W-{q},rcm)
                         (it-{r}) (br'_inner_step r \<Sigma>')
  "
  apply (cases \<Sigma>', simp)
  apply (unfold br'_inner_invar_def br'_inner_step_def Let_def)
  apply auto
  done

lemma br'_inner_invar_initial:
  "\<lbrakk> q\<in>W \<rbrakk> \<Longrightarrow> br'_inner_invar {r\<in>\<delta>. q\<in>set (rhsq r)} q (Q,W-{q},rcm)
                               {r\<in>\<delta>. q\<in>set (rhsq r)} (Q,W-{q},rcm)"
  apply (simp add: br'_inner_invar_def)
  apply auto
  done

lemma br'_inner_step_proof:
  fixes \<alpha>s :: "'\<Sigma> \<Rightarrow> ('Q,'L) br'_state"
  fixes cstep :: "('Q,'L) ta_rule \<Rightarrow> '\<Sigma> \<Rightarrow> '\<Sigma>"
  fixes \<Sigma>h :: "'\<Sigma>"
  fixes cinvar :: "('Q,'L) ta_rule set \<Rightarrow> '\<Sigma> \<Rightarrow> bool"

  assumes iterable_set: "set_iteratei \<alpha> invar iteratei"
  assumes invar_initial: "cinvar {r\<in>\<delta>. q\<in>set (rhsq r)} \<Sigma>h"
  assumes invar_step:
    "!!it r \<Sigma>. \<lbrakk> r\<in>it; it \<subseteq> {r\<in>\<delta>. q\<in>set (rhsq r)}; cinvar it \<Sigma> \<rbrakk>
                 \<Longrightarrow> cinvar (it-{r}) (cstep r \<Sigma>)"
  assumes step_desc:
    "!!it r \<Sigma>. \<lbrakk> r\<in>it; it\<subseteq>{r\<in>\<delta>. q\<in>set (rhsq r)}; cinvar it \<Sigma> \<rbrakk>
                 \<Longrightarrow> \<alpha>s (cstep r \<Sigma>) = br'_inner_step r (\<alpha>s \<Sigma>)"
  assumes it_set_desc: "invar it_set" "\<alpha> it_set = {r\<in>\<delta>. q\<in>set (rhsq r)}"

  assumes QIW[simp]: "q\<in>W"

  assumes \<Sigma>_desc[simp]: "\<alpha>s \<Sigma> = (Q,W,rcm)"
  assumes \<Sigma>h_desc[simp]: "\<alpha>s \<Sigma>h = (Q,W-{q},rcm)"

  shows "(\<alpha>s \<Sigma>, \<alpha>s (iteratei it_set (\<lambda>_. True) cstep \<Sigma>h))\<in>br'_step \<delta>"
proof -
  interpret set_iteratei \<alpha> invar iteratei by fact

  show ?thesis
    apply (rule_tac
      I="\<lambda>it \<Sigma>. cinvar it \<Sigma>
                \<and> br'_inner_invar {r\<in>\<delta>. q\<in>set (rhsq r)} q (Q,W-{q},rcm)
                                  it (\<alpha>s \<Sigma>)"
      in iterate_rule_P)
    apply (simp_all
      add: it_set_desc invar_initial br'_inner_invar_initial invar_step
           step_desc br'_inner_invar_step)
    apply (rule br'_inner_invar_imp_final)
    apply (rule QIW)
    apply simp
    done
qed

text_raw {* \paragraph{Computing Witnesses} *}
text {*
  The algorithm is now refined further, such that it stores, for each discovered
  state, a witness for non-emptiness, i.e. a tree that is accepted with the
  discovered state.
*}

-- "A map from states to trees has the witness-property, if it maps states to
    trees that are accepted with that state:"
definition "witness_prop \<delta> m == \<forall>q t. m q = Some t \<longrightarrow> accs \<delta> t q"

-- "Construct a witness for the LHS of a rule, provided that the map contains
    witnesses for all states on the RHS:"
definition construct_witness
  :: "('Q \<rightharpoonup> 'L tree) \<Rightarrow> ('Q,'L) ta_rule \<Rightarrow> 'L tree"
  where
  "construct_witness Q r == NODE (rhsl r) (List.map (\<lambda>q. the (Q q)) (rhsq r))"

lemma witness_propD: "\<lbrakk>witness_prop \<delta> m; m q = Some t\<rbrakk> \<Longrightarrow> accs \<delta> t q"
  by (auto simp add: witness_prop_def)

lemma construct_witness_correct:
  "\<lbrakk> witness_prop \<delta> Q; r\<in>\<delta>; set (rhsq r) \<subseteq> dom Q \<rbrakk>
    \<Longrightarrow> accs \<delta> (construct_witness Q r) (lhs r)"
  apply (unfold construct_witness_def witness_prop_def)
  apply (cases r)
  apply simp
  apply (erule accs.intros)
  apply (auto dest: nth_mem)
  done

lemma construct_witness_eq:
  "\<lbrakk> Q |` set (rhsq r) = Q' |` set (rhsq r) \<rbrakk> \<Longrightarrow>
    construct_witness Q r = construct_witness Q' r"
  apply (unfold construct_witness_def)
  apply auto
  apply (subgoal_tac "Q x = Q' x")
  apply (simp)
  apply (drule_tac x=x in fun_cong)
  apply auto
  done

text {*
  The set of discovered states is refined by a map from discovered states to
  their witnesses:
*}
type_synonym ('Q,'L) brw_state = "('Q\<rightharpoonup>'L tree) \<times> 'Q set \<times> (('Q,'L) ta_rule \<rightharpoonup> nat)"

definition brw_\<alpha> :: "('Q,'L) brw_state \<Rightarrow> ('Q,'L) br'_state"
  where "brw_\<alpha> = (\<lambda>(Q,W,rcm). (dom Q,W,rcm))"

definition brw_invar_add :: "('Q,'L) ta_rule set \<Rightarrow> ('Q,'L) brw_state set"
  where "brw_invar_add \<delta> == {(Q,W,rcm). witness_prop \<delta> Q}"

definition "brw_invar \<delta> == brw_invar_add \<delta> \<inter> {s. brw_\<alpha> s \<in> br'_invar \<delta>}"

(* TODO:
    This step description does not allow full flexibility, because
    we may want to construct new witnesses from other witnesses constructed
    in the same step!

    However, if we say t = construct_witness Q' r, may we run into cyclicity
    problems, where a cycle of witnesses
    may witness itself?. Hmm? As these cyclic witnesses would have to
    be infinite, they cannot exist?

    But, if we use a BFS search strategy, the current step description will
    compute minimal depth witnesses.
    The argumentation is, that:
      Initially, all witnesses of depth 1 (definitely minimal) are discovered
      A witness of depth n has children of length < n
      The states that are initially on the workset are all those with
      witnesses of depth 1. Thus,
      after they have been processed, all states with witnesses of depth 2 have
      been discovered. This argument can be iterated inductively.
*)
inductive_set brw_step
  :: "('Q,'L) ta_rule set \<Rightarrow> (('Q,'L) brw_state \<times> ('Q,'L) brw_state) set"
  for \<delta> where
  "\<lbrakk>
     q\<in>W;
     dsqr = { r\<in>\<delta>. q \<in> set (rhsq r) \<and> the (rcm r) \<le> 1 };
     dom Q' = dom Q \<union> lhs`dsqr;
     !!q t. Q' q = Some t \<Longrightarrow> Q q = Some t
                              \<or> (\<exists>r\<in>dsqr. q=lhs r \<and> t=construct_witness Q r);
     W' = (W-{q}) \<union> (lhs`dsqr - dom Q);
     !!r. r\<in>\<delta> \<Longrightarrow> rcm' r = ( if q \<in> set (rhsq r) then
                               Some (the (rcm r) - 1)
                             else rcm r
                           )
   \<rbrakk> \<Longrightarrow> ((Q,W,rcm),(Q',W',rcm')) \<in> brw_step \<delta>"

definition brw_cond :: "'Q set \<Rightarrow> ('Q,'L) brw_state set"
  where "brw_cond Qi == {(Q,W,rcm). W\<noteq>{} \<and> (Qi\<inter>dom Q={})}"

inductive_set brw_iq :: "('Q,'L) ta_rule set \<Rightarrow> ('Q \<rightharpoonup> 'L tree) set"
  for \<delta> where
  "\<lbrakk>
    \<forall>q t. Q q = Some t \<longrightarrow> (\<exists>r\<in>\<delta>. rhsq r = [] \<and> q = lhs r
                                  \<and> t = NODE (rhsl r) []);
    \<forall>r\<in>\<delta>. rhsq r = [] \<longrightarrow> Q (lhs r) \<noteq> None
   \<rbrakk> \<Longrightarrow> Q \<in> brw_iq \<delta>"

inductive_set brw_initial :: "('Q,'L) ta_rule set \<Rightarrow> ('Q,'L) brw_state set"
  for \<delta> where
  "\<lbrakk> !!r. r\<in>\<delta> \<Longrightarrow> rcm r = Some (card (set (rhsq r))); Q\<in>brw_iq \<delta> \<rbrakk>
     \<Longrightarrow> (Q, br_iq \<delta>, rcm)\<in>brw_initial \<delta>"

definition "brw_algo Qi \<delta> == \<lparr>
  wa_cond=brw_cond Qi,
  wa_step = brw_step \<delta>,
  wa_initial = brw_initial \<delta>,
  wa_invar = brw_invar \<delta>
\<rparr>"

lemma brw_cond_abs: "\<Sigma>\<in>brw_cond Qi \<longleftrightarrow> (brw_\<alpha> \<Sigma>)\<in>bre'_cond Qi"
  apply (cases \<Sigma>)
  apply (simp add: brw_cond_def bre'_cond_def brw_\<alpha>_def)
  done

lemma brw_initial_abs: "\<Sigma>\<in>brw_initial \<delta> \<Longrightarrow> brw_\<alpha> \<Sigma> \<in> br'_initial \<delta>"
  apply (cases \<Sigma>, simp)
  apply (erule brw_initial.cases)
  apply (erule brw_iq.cases)
  apply (auto simp add: brw_\<alpha>_def)
  apply (subgoal_tac "dom Qa = br_iq \<delta>")
  apply simp
  apply (rule br'_initial.intros)
  apply auto [1]
  apply (force simp add: br_iq_def)
  done

lemma brw_invar_initial: "brw_initial \<delta> \<subseteq> brw_invar_add \<delta>"
  apply safe
  apply (unfold brw_invar_add_def)
  apply (auto simp add: witness_prop_def)
  apply (erule brw_initial.cases)
  apply (erule brw_iq.cases)
  apply auto
proof -
  case (goal1 q t rcm Q)
  from goal1(3)[rule_format, OF goal1(1)] obtain r where
    [simp]: "r\<in>\<delta>" "rhsq r = []" "q=lhs r" "t=NODE (rhsl r) []"
    by blast
  have RF[simplified]: "r=((lhs r) \<rightarrow> (rhsl r) (rhsq r))" by (cases r) simp
  show ?case
    apply (simp)
    apply (rule accs.intros)
    apply (subst RF[symmetric])
    apply auto
    done
qed

lemma brw_step_abs:
  "\<lbrakk> (\<Sigma>,\<Sigma>')\<in>brw_step \<delta> \<rbrakk> \<Longrightarrow> (brw_\<alpha> \<Sigma>, brw_\<alpha> \<Sigma>')\<in>br'_step \<delta>"
  apply (cases \<Sigma>, cases \<Sigma>', simp)
  apply (erule brw_step.cases)
  apply (simp add: brw_\<alpha>_def)
  apply hypsubst
  apply (rule br'_step.intros)
  apply assumption
  apply auto
  done

lemma brw_step_invar:
  assumes FIN[simp]: "finite \<delta>"
  assumes INV: "\<Sigma>\<in>brw_invar_add \<delta>" and BR'INV: "brw_\<alpha> \<Sigma> \<in> br'_invar \<delta>"
  assumes STEP: "(\<Sigma>,\<Sigma>') \<in> brw_step \<delta>"
  shows "\<Sigma>'\<in>brw_invar_add \<delta>"
proof -
  obtain Q W rcm Q' W' rcm' where
    [simp]: "\<Sigma>=(Q,W,rcm)" "\<Sigma>'=(Q',W',rcm')"
    by (cases \<Sigma>, cases \<Sigma>') force

  from INV have WP: "witness_prop \<delta> Q"
    by (simp_all add: brw_invar_add_def)

  obtain qw dsqr where SPROPS:
    "dsqr = {r \<in> \<delta>. qw \<in> set (rhsq r) \<and> the (rcm r) \<le> 1}"
    "qw\<in>W"
    "dom Q' = dom Q \<union> lhs ` dsqr"
    "!!q t. Q' q = Some t \<Longrightarrow> Q q = Some t
                              \<or> (\<exists>r\<in>dsqr. q=lhs r \<and> t=construct_witness Q r)"
    by (auto intro: brw_step.cases[OF STEP[simplified]])
  from br'_rcm_aux'[OF BR'INV[unfolded brw_\<alpha>_def, simplified] SPROPS(2)] have
    DSQR_ALT: "dsqr = {r \<in> \<delta>. qw \<in> set (rhsq r)
                              \<and> set (rhsq r) \<subseteq> dom Q - (W - {qw})}"
    by (simp add: SPROPS(1))
  have "witness_prop \<delta> Q'"
  proof (unfold witness_prop_def, safe)
    fix q t
    assume A: "Q' q = Some t"

    from SPROPS(4)[OF A] have
      "Q q = Some t \<or> (\<exists>r\<in>dsqr. q = lhs r \<and> t = construct_witness Q r)" .
    moreover {
      assume C: "Q q = Some t"
      from witness_propD[OF WP, OF C] have "accs \<delta> t q" .
    } moreover {
      fix r
      assume "r\<in>dsqr" and [simp]: "q=lhs r" "t=construct_witness Q r"
      from `r\<in>dsqr` have 1: "r\<in>\<delta>" "set (rhsq r) \<subseteq> dom Q"
        by (auto simp add: DSQR_ALT)
      from construct_witness_correct[OF WP 1] have "accs \<delta> t q" by simp
    } ultimately show "accs \<delta> t q" by blast
  qed
  thus ?thesis by (simp add: brw_invar_add_def)
qed

theorem brw_pref_bre': "wa_precise_refine (brw_algo Qi \<delta>) (bre'_algo Qi \<delta>) brw_\<alpha>"
  apply (unfold_locales)
  apply (simp_all add: brw_algo_def bre'_algo_def)
  apply (auto simp add: brw_cond_abs brw_step_abs brw_initial_abs brw_invar_def)
  done

interpretation brw_pref:
  wa_precise_refine "brw_algo Qi \<delta>" "bre'_algo Qi \<delta>" "brw_\<alpha>"
  using brw_pref_bre' .

theorem brw_while_algo: "finite \<delta> \<Longrightarrow> while_algo (brw_algo Qi \<delta>)"
  apply (rule brw_pref.wa_intro)
  apply (simp add: bre'_while_algo)
  apply (simp_all add: brw_algo_def bre'_algo_def)
  apply (simp add: brw_invar_def)
  apply (auto intro: brw_step_invar simp add: brw_invar_initial)
  done

lemma fst_brw_\<alpha>: "fst (brw_\<alpha> s) = dom (fst s)"
  by (cases s) (simp add: brw_\<alpha>_def)

theorem brw_invar_final:
  "\<forall>sc. sc \<in> wa_invar (brw_algo Qi \<delta>) \<and> sc \<notin> wa_cond (brw_algo Qi \<delta>)
    \<longrightarrow> (Qi \<inter> dom (fst sc) = {}) = (Qi \<inter> b_accessible \<delta> = {})
        \<and> (witness_prop \<delta> (fst sc))"
  apply (intro conjI allI impI)
  using brw_pref.transfer_correctness[OF bre'_invar_final, unfolded fst_brw_\<alpha>]
    apply blast
  apply (auto simp add: brw_algo_def brw_invar_def brw_invar_add_def)
  done

text_raw {* \paragraph{Implementing a Step} *}
inductive_set brw_inner_step
  :: "('Q,'L) ta_rule \<Rightarrow> (('Q,'L) brw_state \<times> ('Q,'L) brw_state) set"
  for r where
  "\<lbrakk>  c = the (rcm r); \<Sigma> = (Q,W,rcm); \<Sigma>'=(Q',W',rcm');
     if c\<le>1 \<and> (lhs r) \<notin> dom Q then
       Q' = Q(lhs r \<mapsto> construct_witness Q r)
     else Q' = Q;
     if c\<le>1 \<and> (lhs r) \<notin> dom Q then
       W' = insert (lhs r) W
     else W' = W;
     rcm' = rcm ( r \<mapsto> (c-(1::nat)))
   \<rbrakk> \<Longrightarrow> (\<Sigma>,\<Sigma>')\<in>brw_inner_step r"

definition brw_inner_invar
  :: "('Q,'L) ta_rule set \<Rightarrow> 'Q \<Rightarrow> ('Q,'L) brw_state \<Rightarrow> ('Q,'L) ta_rule set
      \<Rightarrow> ('Q,'L) brw_state \<Rightarrow> bool"
  where
  "brw_inner_invar rules q == \<lambda>(Q,W,rcm) it (Q',W',rcm').
    (br'_inner_invar rules q (brw_\<alpha> (Q,W,rcm)) it (brw_\<alpha> (Q',W',rcm')) \<and>
    (Q'|`dom Q = Q) \<and>
    (let dsqr = { r\<in>rules - it. the (rcm r) \<le> 1 } in
      (\<forall>q t. Q' q = Some t \<longrightarrow> (Q q = Some t
           \<or> (Q q = None \<and> (\<exists>r\<in>dsqr. q=lhs r \<and> t=construct_witness Q r))
                                )
      )))
  "

lemma brw_inner_step_abs:
  "(\<Sigma>,\<Sigma>')\<in>brw_inner_step r \<Longrightarrow> br'_inner_step r (brw_\<alpha> \<Sigma>) = brw_\<alpha> \<Sigma>'"
  apply (erule brw_inner_step.cases)
  apply (unfold br'_inner_step_def brw_\<alpha>_def Let_def)
  apply auto
  done

lemma brw_inner_invar_imp_final:
  "\<lbrakk> q\<in>W; brw_inner_invar {r\<in>\<delta>. q\<in>set (rhsq r)} q (Q,W-{q},rcm) {} \<Sigma>' \<rbrakk>
    \<Longrightarrow> ((Q,W,rcm),\<Sigma>') \<in> brw_step \<delta>"
  apply (unfold brw_inner_invar_def br'_inner_invar_def brw_\<alpha>_def)
  apply (auto simp add: Let_def)
  apply (rule brw_step.intros)
  apply assumption
  apply (rule refl)
  apply auto
  done

lemma brw_inner_invar_step:
  assumes INVI: "(Q,W,rcm)\<in>brw_invar \<delta>"
  assumes A: "q\<in>W" "r\<in>it" "it\<subseteq>{r\<in>\<delta>. q\<in>set (rhsq r)}"
  assumes INVH: "brw_inner_invar {r\<in>\<delta>. q\<in>set (rhsq r)} q (Q,W-{q},rcm) it \<Sigma>h"
  assumes STEP: "(\<Sigma>h,\<Sigma>')\<in>brw_inner_step r"
  shows "brw_inner_invar {r\<in>\<delta>. q\<in>set (rhsq r)} q (Q,W-{q},rcm) (it-{r}) \<Sigma>'"
proof -
  from INVI have BR'_INV: "(dom Q,W,rcm)\<in>br'_invar \<delta>"
    by (simp add: brw_invar_def brw_\<alpha>_def)

  obtain c Qh Wh rcmh Q' W' rcm' where
    SIGMAF[simp]: "\<Sigma>h=(Qh,Wh,rcmh)" "\<Sigma>'=(Q',W',rcm')" and
    CF[simp]: "c = the (rcmh r)" and
    SF: "if c\<le>1 \<and> (lhs r) \<notin> dom Qh then
           Q' = Qh(lhs r \<mapsto> (construct_witness Qh r))
         else Q' = Qh"

        "if c\<le>1 \<and> (lhs r) \<notin> dom Qh then
           W' = insert (lhs r) Wh
         else W' = Wh"

        "rcm' = rcmh ( r \<mapsto> (c-(1::nat)))"
    by (blast intro: brw_inner_step.cases[OF STEP])
  let ?rules = "{r\<in>\<delta>. q\<in>set (rhsq r)}"
  let ?dsqr = "\<lambda>it. { r\<in>?rules - it. the (rcm r) \<le> 1 }"
  from INVH have INVHF:
    "br'_inner_invar ?rules q (dom Q, W-{q}, rcm) (it) (dom Qh,Wh,rcmh)"
    "Qh|`dom Q = Q"
    "(\<forall>q t. Qh q = Some t \<longrightarrow> (Q q = Some t
         \<or> (Q q = None \<and> (\<exists>r\<in>?dsqr it. q=lhs r \<and> t=construct_witness Q r))
                               )
     )"
    by (auto simp add: brw_inner_invar_def Let_def brw_\<alpha>_def)
  from INVHF(1)[unfolded br'_inner_invar_def] have INV'HF:
    "dom Qh = dom Q \<union> lhs`?dsqr it"
    "(\<forall>r. rcmh r = (if r \<in> ?rules - it then
                      Some (the (rcm r) - 1)
                    else rcm r))"
    by auto
  from brw_inner_step_abs[OF STEP]
       br'_inner_invar_step[OF A(1) INVHF(1) A(2,3)] have
    G1: "br'_inner_invar ?rules q (dom Q, W-{q}, rcm) (it-{r}) (dom Q',W',rcm')"
    by (simp add: brw_\<alpha>_def)
  moreover have
    "(\<forall>q t. Q' q = Some t \<longrightarrow> (Q q = Some t
        \<or> ( Q q = None
            \<and> (\<exists>r\<in>?dsqr (it-{r}). q=lhs r \<and> t=construct_witness Q r)
           )
                              )
     )" (is ?G1)

    "Q'|`dom Q = Q" (is ?G2)
  proof -
    {
      assume C: "\<not> c\<le>1 \<or> lhs r \<in> dom Qh"
      with SF have "Q'=Qh" by auto
      with INVHF(2,3) have ?G1 ?G2 by auto
    } moreover {
      assume C: "c\<le>1" "lhs r\<notin> dom Qh"
      with SF have Q'F: "Q'=Qh(lhs r \<mapsto> (construct_witness Qh r))" by auto
      from C(2) INVHF(2) INV'HF(1) have G2: ?G2 by (auto simp add: Q'F)
      from C(1) INV'HF A have
        RI: "r\<in>?dsqr (it-{r})" and
        DSS: "dom Q \<subseteq> dom Qh"
        by (auto)
      from br'_rcm_aux'[OF BR'_INV A(1)] RI have
        RDQ: "set (rhsq r) \<subseteq> dom Q"
        by auto
      with INVHF(2) have "Qh |` set (rhsq r) = Q |` set (rhsq r)"
        by (blast intro: restrict_map_subset_eq)
      hence [simp]: "construct_witness Qh r = construct_witness Q r"
        by (blast dest: construct_witness_eq)

      from DSS C(2) have [simp]: "Q (lhs r) = None" "Qh (lhs r) = None" by auto
      have G1: ?G1 proof (intro allI impI)
        case goal1
        {
          assume [simp]: "q=lhs r"
          from goal1 Q'F have [simp]: "t = (construct_witness Qh r)" by simp
          from RI have ?case by auto
        } moreover {
          assume "q\<noteq>lhs r"
          with Q'F goal1 have "Qh q = Some t" by auto
          with INVHF(3) have ?case by auto
        } ultimately show ?case by blast
      qed
      note G1 G2
    } ultimately show ?G1 ?G2 by blast+
  qed
  ultimately show ?thesis
    by (unfold brw_inner_invar_def Let_def brw_\<alpha>_def) auto
qed

lemma brw_inner_invar_initial:
  "\<lbrakk>q\<in>W\<rbrakk> \<Longrightarrow> brw_inner_invar {r\<in>\<delta>. q\<in>set (rhsq r)} q (Q,W-{q},rcm)
                             {r\<in>\<delta>. q\<in>set (rhsq r)} (Q,W-{q},rcm)"
  by (simp add: brw_inner_invar_def br'_inner_invar_initial brw_\<alpha>_def)

theorem brw_inner_step_proof:
  fixes \<alpha>s :: "'\<Sigma> \<Rightarrow> ('Q,'L) brw_state"
  fixes cstep :: "('Q,'L) ta_rule \<Rightarrow> '\<Sigma> \<Rightarrow> '\<Sigma>"
  fixes \<Sigma>h :: "'\<Sigma>"
  fixes cinvar :: "('Q,'L) ta_rule set \<Rightarrow> '\<Sigma> \<Rightarrow> bool"

  assumes set_iterate: "set_iteratei \<alpha> invar iteratei"
  assumes invar_start: "(\<alpha>s \<Sigma>)\<in>brw_invar \<delta>"
  assumes invar_initial: "cinvar {r\<in>\<delta>. q\<in>set (rhsq r)} \<Sigma>h"
  assumes invar_step:
    "!!it r \<Sigma>. \<lbrakk> r\<in>it; it \<subseteq> {r\<in>\<delta>. q\<in>set (rhsq r)}; cinvar it \<Sigma> \<rbrakk>
                \<Longrightarrow> cinvar (it-{r}) (cstep r \<Sigma>)"
  assumes step_desc:
    "!!it r \<Sigma>. \<lbrakk> r\<in>it; it\<subseteq>{r\<in>\<delta>. q\<in>set (rhsq r)}; cinvar it \<Sigma> \<rbrakk>
                \<Longrightarrow> (\<alpha>s \<Sigma>, \<alpha>s (cstep r \<Sigma>)) \<in> brw_inner_step r"
  assumes it_set_desc: "invar it_set" "\<alpha> it_set = {r\<in>\<delta>. q\<in>set (rhsq r)}"

  assumes QIW[simp]: "q\<in>W"

  assumes \<Sigma>_desc[simp]: "\<alpha>s \<Sigma> = (Q,W,rcm)"
  assumes \<Sigma>h_desc[simp]: "\<alpha>s \<Sigma>h = (Q,W-{q},rcm)"

  shows "(\<alpha>s \<Sigma>, \<alpha>s (iteratei it_set (\<lambda>_. True) cstep \<Sigma>h))\<in>brw_step \<delta>"
proof -
  interpret set_iteratei \<alpha> invar iteratei by fact

  show ?thesis
    apply (rule_tac
      I="\<lambda>it \<Sigma>. cinvar it \<Sigma> \<and> brw_inner_invar {r\<in>\<delta>. q\<in>set (rhsq r)} q
                                                (Q,W-{q},rcm) it (\<alpha>s \<Sigma>)"
      in iterate_rule_P)
    apply (auto
      simp add: it_set_desc invar_initial brw_inner_invar_initial invar_step
                step_desc brw_inner_invar_step[OF invar_start[simplified]]
                brw_inner_invar_imp_final[OF QIW])
    done
qed

subsection {* Product Automaton *}

text {*
  The forward-reduced product automaton can be described as a state-space
  exploration problem.

  In this section, the DFS-algorithm for state-space exploration
  (cf. Theory~@{theory "Exploration"} in the Isabelle Collections Framework) is refined to compute the product automaton.
*}

type_synonym ('Q1,'Q2,'L) frp_state =
  "('Q1\<times>'Q2) set \<times> ('Q1\<times>'Q2) list \<times> (('Q1\<times>'Q2),'L) ta_rule set"

definition frp_\<alpha> :: "('Q1,'Q2,'L) frp_state \<Rightarrow> ('Q1\<times>'Q2) dfs_state"
  where "frp_\<alpha> S == let (Q,W,\<delta>)=S in (Q, W)"

definition "frp_invar_add \<delta>1 \<delta>2 ==
  { (Q,W,\<delta>d). \<delta>d = { r. r\<in>\<delta>_prod \<delta>1 \<delta>2 \<and> lhs r \<in> Q - set W} }"

definition frp_invar
  :: "('Q1, 'L) tree_automaton_rec \<Rightarrow> ('Q2, 'L) tree_automaton_rec
      \<Rightarrow> ('Q1,'Q2,'L) frp_state set"
  where "frp_invar T1 T2 ==
  frp_invar_add (ta_rules T1) (ta_rules T2)
  \<inter> { s. frp_\<alpha> s \<in> dfs_invar (ta_initial T1 \<times> ta_initial T2)
                              (f_succ (\<delta>_prod (ta_rules T1) (ta_rules T2))) }"

inductive_set frp_step
  :: "('Q1,'L) ta_rule set \<Rightarrow> ('Q2,'L) ta_rule set
      \<Rightarrow> (('Q1,'Q2,'L) frp_state \<times> ('Q1,'Q2,'L) frp_state) set"
  for \<delta>1 \<delta>2 where
  "\<lbrakk> W=(q1,q2)#Wtl;
     distinct Wn;
     set Wn = f_succ (\<delta>_prod \<delta>1 \<delta>2) `` {(q1,q2)} - Q;
     W'=Wn@Wtl;
     Q'=Q \<union> f_succ (\<delta>_prod \<delta>1 \<delta>2) `` {(q1,q2)};
     \<delta>d'=\<delta>d \<union> {r\<in>\<delta>_prod \<delta>1 \<delta>2. lhs r = (q1,q2) }
  \<rbrakk> \<Longrightarrow> ((Q,W,\<delta>d),(Q',W',\<delta>d'))\<in>frp_step \<delta>1 \<delta>2"

inductive_set frp_initial :: "'Q1 set \<Rightarrow> 'Q2 set \<Rightarrow> ('Q1,'Q2,'L) frp_state set"
  for Q10 Q20 where
  "\<lbrakk> distinct W; set W = Q10\<times>Q20 \<rbrakk> \<Longrightarrow> (Q10\<times>Q20,W,{}) \<in> frp_initial Q10 Q20"

definition frp_cond :: "('Q1,'Q2,'L) frp_state set" where
  "frp_cond == {(Q,W,\<delta>d). W\<noteq>[]}"

definition "frp_algo T1 T2 == \<lparr>
  wa_cond = frp_cond,
  wa_step = frp_step (ta_rules T1) (ta_rules T2),
  wa_initial = frp_initial (ta_initial T1) (ta_initial T2),
  wa_invar = frp_invar T1 T2
\<rparr>"

  -- "The algorithm refines the DFS-algorithm"
theorem frp_pref_dfs:
  "wa_precise_refine (frp_algo T1 T2)
     (dfs_algo (ta_initial T1 \<times> ta_initial T2)
               (f_succ (\<delta>_prod (ta_rules T1) (ta_rules T2))))
     frp_\<alpha>"
  apply unfold_locales
  apply (auto simp add: frp_algo_def frp_\<alpha>_def frp_cond_def dfs_algo_def
                        dfs_cond_def frp_invar_def
    elim!: frp_step.cases frp_initial.cases
    intro: dfs_step.intros dfs_initial.intros
  )
  done

interpretation frp_ref: wa_precise_refine "(frp_algo T1 T2)"
                  "(dfs_algo (ta_initial T1 \<times> ta_initial T2)
                             (f_succ (\<delta>_prod (ta_rules T1) (ta_rules T2))))"
                  "frp_\<alpha>" using frp_pref_dfs .

-- "The algorithm is a well-defined while-algorithm"
theorem frp_while_algo:
  assumes TA: "tree_automaton T1"
              "tree_automaton T2"
  shows "while_algo (frp_algo T1 T2)"
proof -
  interpret t1: tree_automaton T1 by fact
  interpret t2: tree_automaton T2 by fact

  have finite: "finite ((f_succ (\<delta>_prod (ta_rules T1) (ta_rules T2)))\<^sup>*
               `` (ta_initial T1 \<times> ta_initial T2))"
  proof -
    have "((f_succ (\<delta>_prod (ta_rules T1) (ta_rules T2)))\<^sup>*
               `` (ta_initial T1 \<times> ta_initial T2))
          \<subseteq> ((ta_initial T1 \<times> ta_initial T2)
             \<union> \<delta>_states (\<delta>_prod (ta_rules T1) (ta_rules T2)))"
      apply rule
      apply (drule f_accessible_subset[unfolded f_accessible_def])
      apply auto
      done
    moreover have "finite \<dots>"
      by auto
    ultimately show ?thesis by (simp add: finite_subset)
  qed

  show ?thesis
    apply (rule frp_ref.wa_intro)
    apply (rule dfs_while_algo[OF finite])
    apply (simp add: frp_algo_def dfs_algo_def frp_invar_def)
    apply (auto simp add: dfs_algo_def frp_algo_def frp_\<alpha>_def
                          dfs_\<alpha>_def frp_invar_add_def dfs_invar_def
                          dfs_invar_add_def sse_invar_def
                elim!: frp_step.cases) [1]
    apply (force simp add: frp_algo_def frp_invar_add_def
                 elim!: frp_initial.cases)
    done
qed

(* unused
lemma f_succ_adv:
  "\<lbrakk>lhs r \<in> (f_succ \<delta>)\<^sup>* `` Q0; r\<in>\<delta>\<rbrakk> \<Longrightarrow> set (rhsq r) \<subseteq> (f_succ \<delta>)\<^sup>* `` Q0"
  by (case_tac r) (auto dest: rtrancl_into_rtrancl intro: f_succ.intros)
*)

-- "If the algorithm terminates, the forward reduced product automaton
    can be constructed from the result"
theorem frp_inv_final:
  "\<forall>s. s\<in>wa_invar (frp_algo T1 T2) \<and> s\<notin>wa_cond (frp_algo T1 T2)
       \<longrightarrow> (case s of (Q,W,\<delta>d) \<Rightarrow>
             \<lparr> ta_initial = ta_initial T1 \<times> ta_initial T2,
               ta_rules = \<delta>d
             \<rparr> = ta_fwd_reduce (ta_prod T1 T2))"
  apply (intro allI impI)
  apply (case_tac s)
  apply simp
  apply (simp add: ta_reduce_def ta_prod_def frp_algo_def)
proof -
  fix Q W \<delta>d
  assume A: "(Q,W,\<delta>d)\<in>frp_invar T1 T2 \<and> (Q,W,\<delta>d)\<notin>frp_cond"

  from frp_ref.transfer_correctness[OF dfs_invar_final,
                                    unfolded frp_algo_def, simplified,
                                    rule_format, OF A]
  have [simp]: "Q = f_accessible (\<delta>_prod (ta_rules T1) (ta_rules T2))
                                 (ta_initial T1 \<times> ta_initial T2)"
    by (simp add: f_accessible_def dfs_\<alpha>_def frp_\<alpha>_def)

  from A show "\<delta>d = reduce_rules
    (\<delta>_prod (ta_rules T1) (ta_rules T2))
    (f_accessible (\<delta>_prod (ta_rules T1) (ta_rules T2))
                  (ta_initial T1 \<times> ta_initial T2))"
    apply (auto simp add: reduce_rules_def f_accessible_def frp_invar_def
                          frp_invar_add_def frp_\<alpha>_def frp_cond_def)
    apply (case_tac x)
    apply (auto dest: rtrancl_into_rtrancl intro: f_succ.intros)
    done
qed

end